1 {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TemplateHaskell #-}
    2 module Databrary.Action.Types
    3   ( RequestContext(..)
    4   , Handler(..)
    5   , runHandler
    6   ) where
    7 
    8 import Control.Applicative (Alternative)
    9 import Control.Monad (MonadPlus)
   10 import Control.Monad.Base (MonadBase)
   11 import Control.Monad.IO.Class (MonadIO)
   12 import Control.Monad.Reader (MonadReader, ReaderT(..))
   13 import Control.Monad.Trans.Control (MonadBaseControl(..))
   14 import Control.Monad.Trans.Resource (MonadThrow, MonadResource(..), runInternalState, InternalState)
   15 
   16 import Databrary.Has
   17 import Databrary.Model.Id.Types
   18 import Databrary.Model.Identity
   19 import Databrary.Model.Party.Types
   20 import Databrary.Model.Permission.Types
   21 import Databrary.Model.Time
   22 import Databrary.HTTP.Client
   23 import Databrary.HTTP.Request
   24 import Databrary.Context
   25 import Databrary.Ingest.Service
   26 import Databrary.Solr.Service
   27 import Databrary.Static.Service
   28 import Databrary.Store.AV
   29 import Databrary.Store.Types
   30 import Databrary.Service.DB
   31 import Databrary.Service.Entropy
   32 import Databrary.Service.Log
   33 import Databrary.Service.Messages
   34 import Databrary.Service.Notification
   35 import Databrary.Service.Passwd
   36 import Databrary.Service.Types
   37 import Databrary.Web.Types
   38 
   39 data RequestContext = RequestContext
   40   { requestContext :: !ActionContext
   41   , contextRequest :: !Request
   42   , requestIdentity :: !Identity
   43   }
   44 
   45 -- makeHasRec ''RequestContext ['requestContext, 'contextRequest, 'requestIdentity]
   46 instance Has ActionContext RequestContext where
   47   view = requestContext
   48 instance Has Databrary.Service.DB.DBConn RequestContext where
   49   view = (view . requestContext)
   50 instance Has Control.Monad.Trans.Resource.InternalState RequestContext where
   51   view = (view . requestContext)
   52 -- instance Has time-1.6.0.1:Data.Time.Calendar.Days.Day RequestContext where
   53 --   view = (view . requestContext)
   54 instance Has Databrary.Model.Time.Timestamp RequestContext where
   55   view = (contextTimestamp . requestContext)
   56 instance Has Databrary.Service.Types.Secret RequestContext where
   57   view = (view . requestContext)
   58 instance Has Databrary.Service.Entropy.Entropy RequestContext where
   59   view = (view . requestContext)
   60 instance Has Databrary.Service.Passwd.Passwd RequestContext where
   61   view = (view . requestContext)
   62 instance Has Databrary.Service.Log.Logs RequestContext where
   63   view = (view . requestContext)
   64 instance Has Databrary.Service.Messages.Messages RequestContext where
   65   view = (view . requestContext)
   66 -- instance Has Databrary.Service.DB.DBPool RequestContext where
   67 --   view = (view . requestContext)
   68 instance Has Databrary.Store.Types.Storage RequestContext where
   69   view = (view . requestContext)
   70 instance Has Databrary.Store.AV.AV RequestContext where
   71   view = (view . requestContext)
   72 instance Has Databrary.Web.Types.Web RequestContext where
   73   view = (view . requestContext)
   74 instance Has Databrary.HTTP.Client.HTTPClient RequestContext where
   75   view = (view . requestContext)
   76 instance Has Databrary.Static.Service.Static RequestContext where
   77   view = (view . requestContext)
   78 instance Has Databrary.Ingest.Service.Ingest RequestContext where
   79   view = (view . requestContext)
   80 instance Has Databrary.Solr.Service.Solr RequestContext where
   81   view = (view . requestContext)
   82 instance Has Databrary.Service.Notification.Notifications RequestContext where
   83   view = (view . requestContext)
   84 instance Has Databrary.Service.Types.Service RequestContext where
   85   view = (view . requestContext)
   86 instance Has Request RequestContext where
   87   view = contextRequest
   88 instance Has Identity RequestContext where
   89   view = requestIdentity
   90 instance Has Databrary.Model.Permission.Types.Access RequestContext where
   91   view = (view . requestIdentity)
   92 instance Has (Databrary.Model.Id.Types.Id Databrary.Model.Party.Types.Party) RequestContext where
   93   view = (view . requestIdentity)
   94 instance Has Databrary.Model.Party.Types.Account RequestContext where
   95    view = (siteAccount . view . requestIdentity)
   96 instance Has Databrary.Model.Party.Types.Party RequestContext where
   97   view = (view . requestIdentity)
   98 instance Has Databrary.Model.Party.Types.SiteAuth RequestContext where
   99   view = (view . requestIdentity)
  100 
  101 -- | The monad in which route handlers run. At the top, each route 'Action'
  102 -- returns a 'Handler' 'Response'
  103 newtype Handler a = Handler { unHandler :: ReaderT RequestContext IO a }
  104     deriving
  105         ( Functor
  106         , Applicative
  107         , Alternative
  108         , Monad
  109         , MonadPlus
  110         , MonadIO
  111         , MonadBase IO
  112         , MonadThrow
  113         , MonadReader RequestContext
  114         )
  115 
  116 {-# INLINE runHandler #-}
  117 runHandler :: Handler a -> RequestContext -> IO a
  118 runHandler (Handler (ReaderT f)) = f
  119 
  120 instance MonadResource Handler where
  121   liftResourceT = focusIO . runInternalState
  122 
  123 instance MonadBaseControl IO Handler where
  124   type StM Handler a = a
  125   liftBaseWith f = Handler $ liftBaseWith $ \r -> f (r . unHandler)
  126   restoreM = Handler . restoreM