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