{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Facebook.Monad
( FacebookT
, Auth
, NoAuth
, FbTier(..)
, runFacebookT
, runNoAuthFacebookT
, beta_runFacebookT
, beta_runNoAuthFacebookT
, getApiVersion
, getCreds
, getMCreds
, getManager
, getTier
, withTier
, addAppSecretProof
, makeAppSecretProof
, runResourceInFb
, mapFacebookT
, setApiVersion
, lift
) where
import Control.Applicative (Alternative, Applicative)
import Control.Monad (MonadPlus, liftM)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Fail (MonadFail(..))
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Logger (MonadLogger(..))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT)
import qualified Control.Monad.Trans.Resource as R
import Crypto.Hash.Algorithms (SHA256)
import Crypto.MAC.HMAC (HMAC(..), hmac)
import Data.ByteArray.Encoding (Base(..), convertToBase)
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import Facebook.Types
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import UnliftIO
import qualified UnliftIO.Exception as E
newtype FacebookT auth m a =
F
{ unF :: ReaderT FbData m a
}
deriving ( Functor
, Applicative
, Alternative
, Monad
, MonadFix
, MonadPlus
, MonadIO
, MonadTrans
, R.MonadThrow
, MonadFail
, MonadUnliftIO
)
deriving instance
(R.MonadResource m, MonadBase IO m) =>
R.MonadResource (FacebookT auth m)
instance MonadBase b m => MonadBase b (FacebookT auth m) where
liftBase = lift . liftBase
instance MonadLogger m => MonadLogger (FacebookT auth m) where
monadLoggerLog loc src lvl msg = lift (monadLoggerLog loc src lvl msg)
data Auth
deriving (Typeable)
data NoAuth
deriving (Typeable)
data FbData =
FbData
{ fbdCreds :: Maybe Credentials
, fbdManager :: !H.Manager
, fbdTier :: !FbTier
, fbdApiVersion :: IORef ApiVersion
}
deriving (Typeable)
data FbTier
= Production
| Beta
deriving (Eq, Ord, Show, Read, Enum, Typeable)
defaultApiVersion :: ApiVersion
defaultApiVersion = "v3.2"
setApiVersion :: (MonadIO m) => ApiVersion -> FacebookT anyAuth m ()
setApiVersion apiVersion = do
ref <- fbdApiVersion `liftM` F ask
atomicModifyIORef' ref (\_ -> (apiVersion, ()))
return ()
runFacebookT ::
(MonadIO m)
=> Credentials
-> H.Manager
-> FacebookT Auth m a
-> m a
runFacebookT creds manager (F act) = do
apiref <- newIORef defaultApiVersion
runReaderT act (FbData (Just creds) manager Production apiref)
addAppSecretProof ::
Credentials
-> Maybe (AccessToken anykind)
-> HT.SimpleQuery
-> HT.SimpleQuery
addAppSecretProof (Credentials _ _ _ False) _ query = query
addAppSecretProof creds mtoken query = makeAppSecretProof creds mtoken <> query
makeAppSecretProof ::
Credentials
-> Maybe (AccessToken anyKind)
-> HT.SimpleQuery
makeAppSecretProof creds (Just (UserAccessToken _ accessToken _)) =
[(TE.encodeUtf8 "appsecret_proof", proof)]
where
hmacData :: HMAC SHA256
hmacData = hmac (appSecretBS creds) (TE.encodeUtf8 accessToken)
proof = convertToBase Base16 hmacData
makeAppSecretProof _ _ = []
runNoAuthFacebookT ::
(MonadIO m)
=> H.Manager
-> FacebookT NoAuth m a
-> m a
runNoAuthFacebookT manager (F act) = do
apiref <- newIORef defaultApiVersion
runReaderT act (FbData Nothing manager Production apiref)
beta_runFacebookT ::
(MonadIO m) => Credentials -> H.Manager -> FacebookT Auth m a -> m a
beta_runFacebookT creds manager (F act) = do
apiref <- newIORef defaultApiVersion
runReaderT act (FbData (Just creds) manager Beta apiref)
beta_runNoAuthFacebookT ::
(MonadIO m) => H.Manager -> FacebookT NoAuth m a -> m a
beta_runNoAuthFacebookT manager (F act) = do
apiref <- newIORef defaultApiVersion
runReaderT act (FbData Nothing manager Beta apiref)
getCreds :: (Monad m, MonadIO m) => FacebookT Auth m Credentials
getCreds = do
mCreds <- getMCreds
case mCreds of
Nothing -> E.throwIO $ FbLibraryException "Couldn't get credentials."
Just creds -> return creds
getMCreds :: Monad m => FacebookT anyAuth m (Maybe Credentials)
getMCreds = fbdCreds `liftM` F ask
getApiVersion :: MonadIO m => FacebookT anyAuth m ApiVersion
getApiVersion = do
ref <- fbdApiVersion `liftM` F ask
apiVersion <- readIORef ref
pure apiVersion
getManager :: Monad m => FacebookT anyAuth m H.Manager
getManager = fbdManager `liftM` F ask
getTier :: Monad m => FacebookT anyAuth m FbTier
getTier = fbdTier `liftM` F ask
withTier :: Monad m => (FbTier -> a) -> FacebookT anyAuth m a
withTier = flip liftM getTier
runResourceInFb ::
(R.MonadResource m, MonadUnliftIO m)
=> FacebookT anyAuth (R.ResourceT m) a
-> FacebookT anyAuth m a
runResourceInFb (F inner) = F $ ask >>= lift . R.runResourceT . runReaderT inner
mapFacebookT :: (m a -> n b) -> FacebookT anyAuth m a -> FacebookT anyAuth n b
mapFacebookT f = F . mapReaderT f . unF