module Facebook.Monad
( FacebookT
, Auth
, NoAuth
, FbTier(..)
, runFacebookT
, runNoAuthFacebookT
, beta_runFacebookT
, beta_runNoAuthFacebookT
, getCreds
, getManager
, getTier
, withTier
, runResourceInFb
, mapFacebookT
, 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.Logger (MonadLogger(..))
import Control.Monad.Trans.Class (MonadTrans(lift))
import UnliftIO
import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT)
import Data.Typeable (Typeable)
import qualified Control.Monad.Trans.Resource as R
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, R.MonadThrow)
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 (MonadIO m, MonadUnliftIO m) =>
MonadUnliftIO (FacebookT auth m) where
askUnliftIO :: FacebookT auth m (UnliftIO (FacebookT auth m))
askUnliftIO =
F
(ReaderT $
\(r :: FbData) ->
withUnliftIO $
\(u :: UnliftIO m) ->
return
(UnliftIO
(\(x :: FacebookT auth m a) ->
(unliftIO u ((flip runReaderT r) (unF x))))))
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 :: Credentials
, fbdManager :: !H.Manager
, fbdTier :: !FbTier
} deriving (Typeable)
data FbTier
= Production
| Beta
deriving (Eq, Ord, Show, Read, Enum, Typeable)
runFacebookT
:: Credentials
-> H.Manager
-> FacebookT Auth m a
-> m a
runFacebookT creds manager (F act) =
runReaderT act (FbData creds manager Production)
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)
beta_runFacebookT :: Credentials -> H.Manager -> FacebookT Auth m a -> m a
beta_runFacebookT creds manager (F act) =
runReaderT act (FbData creds manager Beta)
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)
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
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