{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
module Facebook.Monad
( FacebookT
, Auth
, NoAuth
, FbTier(..)
, runFacebookT
, runNoAuthFacebookT
, beta_runFacebookT
, beta_runNoAuthFacebookT
, getCreds
, getManager
, getTier
, withTier
, runResourceInFb
, mapFacebookT
-- * Re-export
, lift
) where
import Control.Applicative (Applicative, Alternative)
import Control.Monad (MonadPlus, liftM)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Trans.Control ( MonadTransControl(..), MonadBaseControl(..)
, ComposeSt, defaultLiftBaseWith
, defaultRestoreM )
import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT)
import Data.Typeable (Typeable)
import qualified Control.Monad.Trans.Resource as R
import qualified Data.Conduit as C
import qualified Network.HTTP.Conduit as H
import Facebook.Types
-- | @FacebookT auth m a@ is this library's monad transformer.
-- Contains information needed to issue commands and queries to
-- Facebook. The phantom type @auth@ may be either 'Auth' (you
-- have supplied your 'Credentials') or 'NoAuth' (you have not
-- supplied any 'Credentials').
newtype FacebookT auth m a = F { unF :: ReaderT FbData m a }
deriving ( Functor, Applicative, Alternative, Monad
, MonadFix, MonadPlus, MonadIO, MonadTrans
, R.MonadThrow, R.MonadActive, R.MonadResource )
instance MonadBase b m => MonadBase b (FacebookT auth m) where
liftBase = lift . liftBase
instance MonadTransControl (FacebookT auth) where
newtype StT (FacebookT auth) a = FbStT { unFbStT :: StT (ReaderT FbData) a }
liftWith f = F $ liftWith (\run -> f (liftM FbStT . run . unF))
restoreT = F . restoreT . liftM unFbStT
instance MonadBaseControl b m => MonadBaseControl b (FacebookT auth m) where
newtype StM (FacebookT auth m) a = StMT {unStMT :: ComposeSt (FacebookT auth) m a}
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT
-- | Phantom type stating that you have provided your
-- 'Credentials' and thus have access to the whole API.
data Auth deriving (Typeable)
-- | Phantom type stating that you have /not/ provided your
-- 'Credentials'. This means that you'll be limited about which
-- APIs you'll be able use.
data NoAuth deriving (Typeable)
-- | Internal data kept inside 'FacebookT'.
data FbData = FbData { fbdCreds :: Credentials -- ^ Can be 'undefined'!
, fbdManager :: !H.Manager
, fbdTier :: !FbTier
}
deriving (Typeable)
-- | Which Facebook tier should be used (see
-- ).
data FbTier = Production | Beta deriving (Eq, Ord, Show, Read, Enum, Typeable)
-- | Run a computation in the 'FacebookT' monad transformer with
-- your credentials.
runFacebookT :: Credentials -- ^ Your app's credentials.
-> H.Manager -- ^ Connection manager (see 'H.withManager').
-> FacebookT Auth m a
-> m a
runFacebookT creds manager (F act) =
runReaderT act (FbData creds manager Production)
-- | Run a computation in the 'FacebookT' monad without
-- credentials.
runNoAuthFacebookT :: H.Manager -> FacebookT NoAuth m a -> m a
runNoAuthFacebookT manager (F act) =
let creds = error "runNoAuthFacebookT: never here, serious bug"
in runReaderT act (FbData creds manager Production)
-- | Same as 'runFacebookT', but uses Facebook's beta tier (see
-- ).
beta_runFacebookT :: Credentials -> H.Manager -> FacebookT Auth m a -> m a
beta_runFacebookT creds manager (F act) =
runReaderT act (FbData creds manager Beta)
-- | Same as 'runNoAuthFacebookT', but uses Facebook's beta tier
-- (see ).
beta_runNoAuthFacebookT :: H.Manager -> FacebookT NoAuth m a -> m a
beta_runNoAuthFacebookT manager (F act) =
let creds = error "beta_runNoAuthFacebookT: never here, serious bug"
in runReaderT act (FbData creds manager Beta)
-- | Get the user's credentials.
getCreds :: Monad m => FacebookT Auth m Credentials
getCreds = fbdCreds `liftM` F ask
-- | Get the 'H.Manager'.
getManager :: Monad m => FacebookT anyAuth m H.Manager
getManager = fbdManager `liftM` F ask
-- | Get the 'FbTier'.
getTier :: Monad m => FacebookT anyAuth m FbTier
getTier = fbdTier `liftM` F ask
-- | Run a pure function that depends on the 'FbTier' being used.
withTier :: Monad m => (FbTier -> a) -> FacebookT anyAuth m a
withTier = flip liftM getTier
-- | Run a 'ResourceT' inside a 'FacebookT'.
runResourceInFb :: (C.MonadResource m, MonadBaseControl IO m) =>
FacebookT anyAuth (C.ResourceT m) a
-> FacebookT anyAuth m a
runResourceInFb (F inner) = F $ ask >>= lift . C.runResourceT . runReaderT inner
-- | Transform the computation inside a 'FacebookT'.
mapFacebookT :: (m a -> n b) -> FacebookT anyAuth m a -> FacebookT anyAuth n b
mapFacebookT f = F . mapReaderT f . unF