module Facebook.Base
( fbreq
, ToSimpleQuery(..)
, asJson
, asJsonHelper
, asBS
, FacebookException(..)
, fbhttp
, fbhttpHelper
, httpCheck
, apiVersion
) where
import Control.Applicative
import Control.Monad (mzero)
import Control.Monad.IO.Class (MonadIO)
import Data.ByteString.Char8 (ByteString)
import Data.Text (Text)
import Data.Typeable (Typeable)
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
apiVersion :: Text
apiVersion = "v2.8"
fbreq :: Monad m =>
Text
-> Maybe (AccessToken anyKind)
-> HT.SimpleQuery
-> FacebookT anyAuth m H.Request
fbreq path mtoken query =
withTier $ \tier ->
let host = case tier of
Production -> "graph.facebook.com"
Beta -> "graph.beta.facebook.com"
in H.defaultRequest { H.secure = True
, H.host = host
, H.port = 443
, H.path = TE.encodeUtf8 ("/" <> apiVersion <> path)
, H.redirectCount = 3
, H.queryString =
HT.renderSimpleQuery False $
maybe id tsq mtoken query
#if MIN_VERSION_http_client(0,5,0)
, H.responseTimeout = H.responseTimeoutMicro 120000000
#else
, H.responseTimeout = Just 120000000
#endif
}
class ToSimpleQuery a where
tsq :: a -> HT.SimpleQuery -> HT.SimpleQuery
tsq _ = id
instance ToSimpleQuery Credentials where
tsq creds = (:) ("client_id", appIdBS creds) .
(:) ("client_secret", appSecretBS creds)
instance ToSimpleQuery (AccessToken anyKind) where
tsq token = (:) ("access_token", TE.encodeUtf8 $ accessTokenData token)
asJson :: (MonadIO m, MonadTrans t, R.MonadThrow m, A.FromJSON a) =>
H.Response (C.ConduitT () ByteString m ())
-> t m a
asJson = lift . asJsonHelper
asJsonHelper :: (MonadIO m, R.MonadThrow m, A.FromJSON a) =>
H.Response (C.ConduitT () ByteString m ())
-> m a
asJsonHelper 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
val <- C.runConduit $ (H.responseBody response) .| C.sinkParser A.json'
#endif
case A.fromJSON val of
A.Success r -> return r
A.Error str ->
E.throwIO $ FbLibraryException $ T.concat
[ "Facebook.Base.asJson: could not parse "
, " Facebook's response as a JSON value ("
, T.pack str, ")" ]
asBS :: (Monad m) =>
H.Response (C.ConduitT () ByteString m ())
-> FacebookT anyAuth m ByteString
asBS response = lift $ C.runConduit $ H.responseBody response .| fmap B.concat CL.consume
data FacebookException =
FacebookException { fbeType :: Text
, fbeMessage :: Text
}
| FbLibraryException { fbeMessage :: Text }
deriving (Eq, Ord, Show, Read, Typeable)
instance A.FromJSON FacebookException where
parseJSON (A.Object v) =
FacebookException <$> v A..: "type"
<*> v A..: "message"
parseJSON _ = mzero
instance E.Exception FacebookException where
fbhttp :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) =>
H.Request
-> FacebookT anyAuth m (H.Response (C.ConduitT () ByteString m ()))
fbhttp req = do
manager <- getManager
lift (fbhttpHelper manager req)
fbhttpHelper :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) =>
H.Manager
-> H.Request
-> m (H.Response (C.ConduitT () ByteString m ()))
fbhttpHelper manager req = do
#if MIN_VERSION_http_client(0,5,0)
let req' = req { H.checkResponse = \_ _ -> 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 <- H.http req' manager
let status = H.responseStatus response
headers = H.responseHeaders response
#if DEBUG
_ <- liftIO $ printf "fbhttp response status: %s\n" (show status)
#endif
if isOkay status
then return response
else do
#if MIN_VERSION_http_client(0,5,0)
fullResp <- C.runConduit $ (H.responseBody response) .| CB.sinkLbs
let res' = fmap (const ()) response
let statusexc = H.HttpExceptionRequest req $ H.StatusCodeException res' (L.toStrict fullResp)
#else
let cookies = H.responseCookieJar response
let statusexc = H.StatusCodeException status headers cookies
#endif
val <- E.try $ asJsonHelper response
case val :: Either E.SomeException FacebookException of
Right fbexc -> E.throwIO fbexc
Left _ -> do
case AT.parse wwwAuthenticateParser <$>
lookup "WWW-Authenticate" headers of
Just (AT.Done _ fbexc) -> E.throwIO fbexc
_ -> E.throwIO statusexc
wwwAuthenticateParser :: AT.Parser FacebookException
wwwAuthenticateParser =
FacebookException <$ AT.string "OAuth \"Facebook Platform\" "
<*> text
<* AT.char ' '
<*> text
where
text = T.pack <$ AT.char '"' <*> many tchar <* AT.char '"'
tchar = (AT.char '\\' *> AT.anyChar) <|> AT.notChar '"'
httpCheck :: (R.MonadResource m, R.MonadUnliftIO m) =>
H.Request
-> FacebookT anyAuth m Bool
httpCheck req = runResourceInFb $ do
manager <- getManager
let req' = req { H.method = HT.methodHead
#if MIN_VERSION_http_client(0,5,0)
, H.checkResponse = \_ _ -> return ()
#else
, H.checkStatus = \_ _ _ -> Nothing
#endif
}
isOkay . H.responseStatus <$> lift (H.httpLbs req' manager)
isOkay :: HT.Status -> Bool
isOkay status =
let sc = HT.statusCode status
in 200 <= sc && sc < 300