module Facebook.Monad
( FacebookT
, Auth
, NoAuth
, runFacebookT
, runNoAuthFacebookT
, getCreds
, getManager
, runResourceInFb
, 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)
import Data.Typeable (Typeable)
import qualified Data.Conduit as C
import qualified Network.HTTP.Conduit as H
import Facebook.Types
newtype FacebookT auth m a = F { unF :: ReaderT FbData m a }
deriving ( Functor, Applicative, Alternative, Monad
, MonadFix, MonadPlus, MonadIO, MonadTrans )
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
data Auth deriving (Typeable)
data NoAuth deriving (Typeable)
data FbData = FbData { fbdCreds :: Credentials
, fbdManager :: !H.Manager }
deriving (Typeable)
runFacebookT :: Credentials
-> H.Manager
-> FacebookT Auth m a
-> m a
runFacebookT creds manager (F act) = runReaderT act (FbData creds manager)
runNoAuthFacebookT :: H.Manager -> FacebookT NoAuth m a -> m a
runNoAuthFacebookT manager (F act) = runReaderT act (FbData creds manager)
where creds = error "runNoAuthFacebookT: never here, serious bug"
getCreds :: Monad m => FacebookT Auth m Credentials
getCreds = fbdCreds `liftM` F ask
getManager :: Monad m => FacebookT anyAuth m H.Manager
getManager = fbdManager `liftM` F ask
runResourceInFb :: C.Resource m =>
FacebookT anyAuth (C.ResourceT m) a
-> FacebookT anyAuth m a
runResourceInFb (F inner) = F $ ask >>= lift . C.runResourceT . runReaderT inner