{-#LANGUAGE DeriveDataTypeable#-}
{-#LANGUAGE FlexibleContexts#-}
{-#LANGUAGE OverloadedStrings#-}
{-#LANGUAGE CPP#-}
module Facebook.Base
( fbreq
, ToSimpleQuery(..)
, asJson
, asJsonHelper
, asBS
, FacebookException(..)
, fbhttp
, fbhttpHelper
, httpCheck
) where
import Control.Applicative
import Control.Monad.IO.Class (MonadIO)
import Data.ByteString.Char8 (ByteString)
import Data.Text (Text)
import qualified UnliftIO.Exception as E
import Control.Monad.Trans.Class (MonadTrans)
import qualified Control.Monad.Trans.Resource as R
import qualified Data.Aeson as A
import qualified Data.Attoparsec.ByteString.Char8 as AT
import qualified Data.ByteString as B
import qualified Data.Conduit as C
import Data.Conduit ((.|))
import qualified Data.Conduit.Attoparsec as C
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as CB
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import qualified Data.ByteString.Lazy as L
#if DEBUG
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Printf (printf)
#endif
import Facebook.Types
import Facebook.Monad
fbreq :: MonadIO m
=> Text
-> Maybe (AccessToken anyKind)
-> HT.SimpleQuery
-> FacebookT anyAuth m H.Request
fbreq :: Text
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> FacebookT anyAuth m Request
fbreq Text
path Maybe (AccessToken anyKind)
mtoken SimpleQuery
query = do
Text
apiVersion <- FacebookT anyAuth m Text
forall (m :: * -> *) anyAuth. MonadIO m => FacebookT anyAuth m Text
getApiVersion
Maybe Credentials
creds <- FacebookT anyAuth m (Maybe Credentials)
forall (m :: * -> *) anyAuth.
Monad m =>
FacebookT anyAuth m (Maybe Credentials)
getMCreds
let appSecretProofAdder :: Maybe (AccessToken anykind) -> SimpleQuery -> SimpleQuery
appSecretProofAdder = case Maybe Credentials
creds of
Just c :: Credentials
c@( Credentials Text
_ Text
_ Text
_ Bool
True ) -> Credentials
-> Maybe (AccessToken anykind) -> SimpleQuery -> SimpleQuery
forall anykind.
Credentials
-> Maybe (AccessToken anykind) -> SimpleQuery -> SimpleQuery
addAppSecretProof Credentials
c
Maybe Credentials
_ -> (SimpleQuery -> SimpleQuery)
-> Maybe (AccessToken anykind) -> SimpleQuery -> SimpleQuery
forall a b. a -> b -> a
const SimpleQuery -> SimpleQuery
forall a. a -> a
id
(FbTier -> Request) -> FacebookT anyAuth m Request
forall (m :: * -> *) a anyAuth.
Monad m =>
(FbTier -> a) -> FacebookT anyAuth m a
withTier ((FbTier -> Request) -> FacebookT anyAuth m Request)
-> (FbTier -> Request) -> FacebookT anyAuth m Request
forall a b. (a -> b) -> a -> b
$ \FbTier
tier ->
let host :: ByteString
host = case FbTier
tier of
FbTier
Production -> ByteString
"graph.facebook.com"
FbTier
Beta -> ByteString
"graph.beta.facebook.com"
in Request
H.defaultRequest { secure :: Bool
H.secure = Bool
True
, host :: ByteString
H.host = ByteString
host
, port :: Int
H.port = Int
443
, path :: ByteString
H.path = Text -> ByteString
TE.encodeUtf8 (Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
apiVersion Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
, redirectCount :: Int
H.redirectCount = Int
3
, queryString :: ByteString
H.queryString =
Bool -> SimpleQuery -> ByteString
HT.renderSimpleQuery Bool
False
(SimpleQuery -> ByteString) -> SimpleQuery -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe (AccessToken anyKind) -> SimpleQuery -> SimpleQuery
forall anykind.
Maybe (AccessToken anykind) -> SimpleQuery -> SimpleQuery
appSecretProofAdder Maybe (AccessToken anyKind)
mtoken (SimpleQuery -> SimpleQuery) -> SimpleQuery -> SimpleQuery
forall a b. (a -> b) -> a -> b
$ (SimpleQuery -> SimpleQuery)
-> (AccessToken anyKind -> SimpleQuery -> SimpleQuery)
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> SimpleQuery
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SimpleQuery -> SimpleQuery
forall a. a -> a
id AccessToken anyKind -> SimpleQuery -> SimpleQuery
forall a. ToSimpleQuery a => a -> SimpleQuery -> SimpleQuery
tsq Maybe (AccessToken anyKind)
mtoken SimpleQuery
query
#if MIN_VERSION_http_client(0,5,0)
, responseTimeout :: ResponseTimeout
H.responseTimeout = Int -> ResponseTimeout
H.responseTimeoutMicro Int
120000000
#else
, H.responseTimeout = Just 120000000
#endif
}
class ToSimpleQuery a where
tsq :: a -> HT.SimpleQuery -> HT.SimpleQuery
tsq a
_ = SimpleQuery -> SimpleQuery
forall a. a -> a
id
instance ToSimpleQuery Credentials where
tsq :: Credentials -> SimpleQuery -> SimpleQuery
tsq Credentials
creds = (:) (ByteString
"client_id", Credentials -> ByteString
appIdBS Credentials
creds) (SimpleQuery -> SimpleQuery)
-> (SimpleQuery -> SimpleQuery) -> SimpleQuery -> SimpleQuery
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(:) (ByteString
"client_secret", Credentials -> ByteString
appSecretBS Credentials
creds)
instance ToSimpleQuery (AccessToken anyKind) where
tsq :: AccessToken anyKind -> SimpleQuery -> SimpleQuery
tsq AccessToken anyKind
token = (:) (ByteString
"access_token", Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AccessToken anyKind -> Text
forall anyKind. AccessToken anyKind -> Text
accessTokenData AccessToken anyKind
token)
asJson :: (MonadIO m, MonadTrans t, R.MonadThrow m, A.FromJSON a) =>
H.Response (C.ConduitT () ByteString m ())
-> t m a
asJson :: Response (ConduitT () ByteString m ()) -> t m a
asJson = m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> t m a)
-> (Response (ConduitT () ByteString m ()) -> m a)
-> Response (ConduitT () ByteString m ())
-> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response (ConduitT () ByteString m ()) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> m a
asJsonHelper
asJsonHelper :: (MonadIO m, R.MonadThrow m, A.FromJSON a) =>
H.Response (C.ConduitT () ByteString m ())
-> m a
asJsonHelper :: Response (ConduitT () ByteString m ()) -> m a
asJsonHelper Response (ConduitT () ByteString m ())
response = do
#if DEBUG
bs <- H.responseBody response C.$$+- fmap L.fromChunks CL.consume
_ <- liftIO $ printf "asJsonHelper: %s\n" (show bs)
val <- either (fail . ("asJsonHelper: A.decode returned " ++)) return (A.eitherDecode bs)
#else
Value
val <- ConduitT () Void m Value -> m Value
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit (ConduitT () Void m Value -> m Value)
-> ConduitT () Void m Value -> m Value
forall a b. (a -> b) -> a -> b
$ (Response (ConduitT () ByteString m ())
-> ConduitT () ByteString m ()
forall body. Response body -> body
H.responseBody Response (ConduitT () ByteString m ())
response) ConduitT () ByteString m ()
-> ConduitM ByteString Void m Value -> ConduitT () Void m Value
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Parser ByteString Value -> ConduitM ByteString Void m Value
forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Parser a b -> ConduitT a o m b
C.sinkParser Parser ByteString Value
A.json'
#endif
case Value -> Result a
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
val of
A.Success a
r -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
A.Error String
str ->
FacebookException -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (FacebookException -> m a) -> FacebookException -> m a
forall a b. (a -> b) -> a -> b
$ Text -> FacebookException
FbLibraryException (Text -> FacebookException) -> Text -> FacebookException
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"Facebook.Base.asJson: could not parse "
, Text
" Facebook's response as a JSON value ("
, String -> Text
T.pack String
str, Text
")" ]
asBS :: (Monad m) =>
H.Response (C.ConduitT () ByteString m ())
-> FacebookT anyAuth m ByteString
asBS :: Response (ConduitT () ByteString m ())
-> FacebookT anyAuth m ByteString
asBS Response (ConduitT () ByteString m ())
response = m ByteString -> FacebookT anyAuth m ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ByteString -> FacebookT anyAuth m ByteString)
-> m ByteString -> FacebookT anyAuth m ByteString
forall a b. (a -> b) -> a -> b
$ ConduitT () Void m ByteString -> m ByteString
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit (ConduitT () Void m ByteString -> m ByteString)
-> ConduitT () Void m ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Response (ConduitT () ByteString m ())
-> ConduitT () ByteString m ()
forall body. Response body -> body
H.responseBody Response (ConduitT () ByteString m ())
response ConduitT () ByteString m ()
-> ConduitM ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ([ByteString] -> ByteString)
-> ConduitT ByteString Void m [ByteString]
-> ConduitM ByteString Void m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> ByteString
B.concat ConduitT ByteString Void m [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
fbhttp :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) =>
H.Request
-> FacebookT anyAuth m (H.Response (C.ConduitT () ByteString m ()))
fbhttp :: Request
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
fbhttp Request
req = do
Manager
manager <- FacebookT anyAuth m Manager
forall (m :: * -> *) anyAuth.
Monad m =>
FacebookT anyAuth m Manager
getManager
m (Response (ConduitT () ByteString m ()))
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Manager -> Request -> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *).
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
Manager -> Request -> m (Response (ConduitT () ByteString m ()))
fbhttpHelper Manager
manager Request
req)
fbhttpHelper :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) =>
H.Manager
-> H.Request
-> m (H.Response (C.ConduitT () ByteString m ()))
fbhttpHelper :: Manager -> Request -> m (Response (ConduitT () ByteString m ()))
fbhttpHelper Manager
manager Request
req = do
#if MIN_VERSION_http_client(0,5,0)
let req' :: Request
req' = Request
req { checkResponse :: Request -> Response BodyReader -> IO ()
H.checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
#else
let req' = req { H.checkStatus = \_ _ _ -> Nothing }
#endif
#if DEBUG
_ <- liftIO $ printf "fbhttp doing request\n\tmethod: %s\n\tsecure: %s\n\thost: %s\n\tport: %s\n\tpath: %s\n\tqueryString: %s\n\trequestHeaders: %s\n" (show $ H.method req') (show $ H.secure req') (show $ H.host req') (show $ H.port req') (show $ H.path req') (show $ H.queryString req') (show $ H.requestHeaders req')
#endif
Response (ConduitT () ByteString m ())
response <- Request -> Manager -> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) i.
MonadResource m =>
Request -> Manager -> m (Response (ConduitM i ByteString m ()))
H.http Request
req' Manager
manager
let status :: Status
status = Response (ConduitT () ByteString m ()) -> Status
forall body. Response body -> Status
H.responseStatus Response (ConduitT () ByteString m ())
response
headers :: ResponseHeaders
headers = Response (ConduitT () ByteString m ()) -> ResponseHeaders
forall body. Response body -> ResponseHeaders
H.responseHeaders Response (ConduitT () ByteString m ())
response
#if DEBUG
_ <- liftIO $ printf "fbhttp response status: %s\n" (show status)
#endif
if Status -> Bool
isOkay Status
status
then Response (ConduitT () ByteString m ())
-> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Response (ConduitT () ByteString m ())
response
else do
#if MIN_VERSION_http_client(0,5,0)
ByteString
fullResp <- ConduitT () Void m ByteString -> m ByteString
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit (ConduitT () Void m ByteString -> m ByteString)
-> ConduitT () Void m ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ (Response (ConduitT () ByteString m ())
-> ConduitT () ByteString m ()
forall body. Response body -> body
H.responseBody Response (ConduitT () ByteString m ())
response) ConduitT () ByteString m ()
-> ConduitM ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void m ByteString
forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m ByteString
CB.sinkLbs
let res' :: Response ()
res' = (ConduitT () ByteString m () -> ())
-> Response (ConduitT () ByteString m ()) -> Response ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> ConduitT () ByteString m () -> ()
forall a b. a -> b -> a
const ()) Response (ConduitT () ByteString m ())
response
let statusexc :: HttpException
statusexc = Request -> HttpExceptionContent -> HttpException
H.HttpExceptionRequest Request
req (HttpExceptionContent -> HttpException)
-> HttpExceptionContent -> HttpException
forall a b. (a -> b) -> a -> b
$ Response () -> ByteString -> HttpExceptionContent
H.StatusCodeException Response ()
res' (ByteString -> ByteString
L.toStrict ByteString
fullResp)
#else
let cookies = H.responseCookieJar response
let statusexc = H.StatusCodeException status headers cookies
#endif
Either SomeException FacebookException
val <- m FacebookException -> m (Either SomeException FacebookException)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try (m FacebookException -> m (Either SomeException FacebookException))
-> m FacebookException
-> m (Either SomeException FacebookException)
forall a b. (a -> b) -> a -> b
$ Response (ConduitT () ByteString m ()) -> m FacebookException
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> m a
asJsonHelper Response (ConduitT () ByteString m ())
response
case Either SomeException FacebookException
val :: Either E.SomeException FacebookException of
Right FacebookException
fbexc -> FacebookException -> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO FacebookException
fbexc
Left SomeException
_ -> do
case Parser FacebookException -> ByteString -> Result FacebookException
forall a. Parser a -> ByteString -> Result a
AT.parse Parser FacebookException
wwwAuthenticateParser (ByteString -> Result FacebookException)
-> Maybe ByteString -> Maybe (Result FacebookException)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"WWW-Authenticate" ResponseHeaders
headers of
Just (AT.Done ByteString
_ FacebookException
fbexc) -> FacebookException -> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO FacebookException
fbexc
Maybe (Result FacebookException)
_ -> HttpException -> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HttpException
statusexc
wwwAuthenticateParser :: AT.Parser FacebookException
wwwAuthenticateParser :: Parser FacebookException
wwwAuthenticateParser =
Text -> Text -> FacebookException
FacebookException (Text -> Text -> FacebookException)
-> Parser ByteString ByteString
-> Parser ByteString (Text -> Text -> FacebookException)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
AT.string ByteString
"OAuth \"Facebook Platform\" "
Parser ByteString (Text -> Text -> FacebookException)
-> Parser ByteString Text
-> Parser ByteString (Text -> FacebookException)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Text
text
Parser ByteString (Text -> FacebookException)
-> Parser ByteString Char
-> Parser ByteString (Text -> FacebookException)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
AT.char Char
' '
Parser ByteString (Text -> FacebookException)
-> Parser ByteString Text -> Parser FacebookException
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Text
text
where
text :: Parser ByteString Text
text = String -> Text
T.pack (String -> Text)
-> Parser ByteString Char -> Parser ByteString (String -> Text)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
AT.char Char
'"' Parser ByteString (String -> Text)
-> Parser ByteString String -> Parser ByteString Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Char -> Parser ByteString String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString Char
tchar Parser ByteString Text
-> Parser ByteString Char -> Parser ByteString Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
AT.char Char
'"'
tchar :: Parser ByteString Char
tchar = (Char -> Parser ByteString Char
AT.char Char
'\\' Parser ByteString Char
-> Parser ByteString Char -> Parser ByteString Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Char
AT.anyChar) Parser ByteString Char
-> Parser ByteString Char -> Parser ByteString Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser ByteString Char
AT.notChar Char
'"'
httpCheck :: (R.MonadResource m, R.MonadUnliftIO m) =>
H.Request
-> FacebookT anyAuth m Bool
httpCheck :: Request -> FacebookT anyAuth m Bool
httpCheck Request
req = FacebookT anyAuth (ResourceT m) Bool -> FacebookT anyAuth m Bool
forall (m :: * -> *) anyAuth a.
(MonadResource m, MonadUnliftIO m) =>
FacebookT anyAuth (ResourceT m) a -> FacebookT anyAuth m a
runResourceInFb (FacebookT anyAuth (ResourceT m) Bool -> FacebookT anyAuth m Bool)
-> FacebookT anyAuth (ResourceT m) Bool -> FacebookT anyAuth m Bool
forall a b. (a -> b) -> a -> b
$ do
Manager
manager <- FacebookT anyAuth (ResourceT m) Manager
forall (m :: * -> *) anyAuth.
Monad m =>
FacebookT anyAuth m Manager
getManager
let req' :: Request
req' = Request
req { method :: ByteString
H.method = ByteString
HT.methodHead
#if MIN_VERSION_http_client(0,5,0)
, checkResponse :: Request -> Response BodyReader -> IO ()
H.checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
, H.checkStatus = \_ _ _ -> Nothing
#endif
}
Status -> Bool
isOkay (Status -> Bool)
-> (Response ByteString -> Status) -> Response ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> Status
forall body. Response body -> Status
H.responseStatus (Response ByteString -> Bool)
-> FacebookT anyAuth (ResourceT m) (Response ByteString)
-> FacebookT anyAuth (ResourceT m) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResourceT m (Response ByteString)
-> FacebookT anyAuth (ResourceT m) (Response ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Request -> Manager -> ResourceT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
H.httpLbs Request
req' Manager
manager)
isOkay :: HT.Status -> Bool
isOkay :: Status -> Bool
isOkay Status
status =
let sc :: Int
sc = Status -> Int
HT.statusCode Status
status
in Int
200 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
sc Bool -> Bool -> Bool
&& Int
sc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300