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