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