{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

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.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

-- | @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 -- 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

-- askUnliftIO = ReaderT $ \r ->
--                 withUnliftIO $ \u ->
-- return (UnliftIO (unliftIO u . flip runReaderT r))
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))))))

-- | Since @fb-0.14.8@.
instance MonadLogger m =>
         MonadLogger (FacebookT auth m) where
  monadLoggerLog loc src lvl msg = lift (monadLoggerLog loc src lvl msg)

-- | 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
-- <https://developers.facebook.com/support/beta-tier/>).
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
-- <https://developers.facebook.com/support/beta-tier/>).
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 <https://developers.facebook.com/support/beta-tier/>).
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
  :: (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

-- | 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