module Facebook.Base
( Credentials(..)
, AccessToken(..)
, AccessTokenData
, accessTokenData
, accessTokenExpires
, User
, App
, fbreq
, ToSimpleQuery(..)
, asJson
, asJson'
, FacebookException(..)
, fbhttp
, httpCheck
) where
import Control.Applicative
import Control.Monad (mzero)
import Data.ByteString.Char8 (ByteString)
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.Typeable (Typeable, Typeable1)
import Network.HTTP.Types (Ascii)
import qualified Control.Exception.Lifted as E
import qualified Data.Aeson as A
import qualified Data.Attoparsec.Char8 as AT
import qualified Data.Conduit as C
import qualified Data.Conduit.Attoparsec as C
import qualified Data.Text as T
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
data Credentials =
Credentials { clientId :: Ascii
, clientSecret :: Ascii
}
deriving (Eq, Ord, Show, Typeable)
data AccessToken kind where
UserAccessToken :: AccessTokenData -> UTCTime -> AccessToken User
AppAccessToken :: AccessTokenData -> AccessToken App
deriving instance Eq (AccessToken kind)
deriving instance Ord (AccessToken kind)
deriving instance Show (AccessToken kind)
deriving instance Typeable1 AccessToken
type AccessTokenData = Ascii
accessTokenData :: AccessToken kind -> AccessTokenData
accessTokenData (UserAccessToken d _) = d
accessTokenData (AppAccessToken d) = d
accessTokenExpires :: AccessToken kind -> Maybe UTCTime
accessTokenExpires (UserAccessToken _ expt) = Just expt
accessTokenExpires (AppAccessToken _) = Nothing
data User deriving (Typeable)
data App deriving (Typeable)
fbreq :: HT.Ascii -> Maybe (AccessToken kind) -> HT.SimpleQuery -> H.Request m
fbreq path mtoken query =
H.def { H.secure = True
, H.host = "graph.facebook.com"
, H.port = 443
, H.path = path
, H.redirectCount = 3
, H.queryString =
HT.renderSimpleQuery False $
maybe id tsq mtoken query
}
class ToSimpleQuery a where
tsq :: a -> HT.SimpleQuery -> HT.SimpleQuery
tsq _ = id
instance ToSimpleQuery Credentials where
tsq creds = (:) ("client_id", clientId creds) .
(:) ("client_secret", clientSecret creds)
instance ToSimpleQuery (AccessToken kind) where
tsq token = (:) ("access_token", accessTokenData token)
asJson :: (C.ResourceThrow m, C.BufferSource bsrc, A.FromJSON a) =>
H.Response (bsrc m ByteString)
-> C.ResourceT m (H.Response a)
asJson (H.Response status headers body) = do
val <- body C.$$ C.sinkParser A.json'
case A.fromJSON val of
A.Error str -> fail $ "Facebook.Base.asJson: " ++ str
A.Success r -> return (H.Response status headers r)
asJson' :: (C.ResourceThrow m, C.BufferSource bsrc, A.FromJSON a) =>
H.Response (bsrc m ByteString)
-> C.ResourceT m a
asJson' = fmap H.responseBody . asJson
data FacebookException =
FacebookException { fbeType :: Text
, fbeMessage :: Text
}
| FbLibraryException { fbeMessage :: Text }
deriving (Eq, Ord, Show, 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 :: C.ResourceIO m =>
H.Request m
-> H.Manager
-> C.ResourceT m (H.Response (C.BufferedSource m ByteString))
fbhttp req manager = do
let req' = req { H.checkStatus = \_ _ -> Nothing }
response@(H.Response status headers _) <- H.http req' manager
if isOkay status
then return response
else do
let statusexc = H.StatusCodeException status headers
val <- E.try $ asJson' response
case val :: Either E.SomeException FacebookException of
Right fbexc -> E.throw fbexc
Left _ -> do
case AT.parse wwwAuthenticateParser <$>
lookup "WWW-Authenticate" headers of
Just (AT.Done _ fbexc) -> E.throw fbexc
_ -> E.throw 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 :: C.ResourceIO m =>
H.Request m
-> H.Manager
-> C.ResourceT m Bool
httpCheck req manager = do
let req' = req { H.method = HT.methodHead
, H.checkStatus = \_ _ -> Nothing }
H.Response status _ _ <- H.httpLbs req' manager
return $! isOkay status
isOkay :: HT.Status -> Bool
isOkay status =
let sc = HT.statusCode status
in 200 <= sc && sc < 300