1 2 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 module Context 4 ( ActionContext(..) 5 , ActionContextM 6 , runContextM 7 , BackgroundContext(..) 8 , BackgroundContextM 9 , withBackgroundContextM 10 , SolrIndexingContext(..) 11 , SolrIndexingContextM 12 , mkSolrIndexingContext 13 ) where 14 15 import Control.Monad.Trans.Reader (ReaderT(..), withReaderT) 16 import Control.Monad.Trans.Resource (InternalState, runResourceT, withInternalState) 17 import Data.Time (getCurrentTime) 18 19 import Has 20 import HTTP.Client 21 import Model.Time 22 import Model.Id.Types 23 import Model.Identity.Types 24 import Model.Party.Types 25 import Model.Permission.Types 26 import Service.Log 27 import Service.Types 28 import Service.DB 29 import Service.Entropy 30 import Service.Mail 31 import Service.Messages 32 import Service.Notification 33 import Service.Passwd 34 import Solr.Service 35 import Static.Service 36 import Ingest.Service 37 import Store.AV 38 import Store.Types 39 import Web.Types 40 41 -- | This is the context for when you don't have an identity, but you have a 42 -- fully initialized, "command line" access to the system. 43 data ActionContext = ActionContext 44 { contextService :: !Service -- ^ All initialized services; "the imperative shell" 45 , contextTimestamp :: !Timestamp -- ^ When the ActionContextM action is running (i.e., NOW) 46 , contextResourceState :: !InternalState -- ^ Optimization for MonadResource 47 , contextDB :: !DBConn -- ^ The specific connection chosen for the running action? 48 } 49 50 instance Has Service ActionContext where 51 view = contextService 52 instance Has Service.Notification.Notifications ActionContext where 53 view = view . contextService 54 instance Has Solr.Service.Solr ActionContext where 55 view = view . contextService 56 instance Has Ingest.Service.Ingest ActionContext where 57 view = view . contextService 58 instance Has Static.Service.Static ActionContext where 59 view = view . contextService 60 instance Has HTTP.Client.HTTPClient ActionContext where 61 view = view . contextService 62 instance Has Web.Types.Web ActionContext where 63 view = view . contextService 64 instance Has Store.AV.AV ActionContext where 65 view = view . contextService 66 instance Has Store.Types.Storage ActionContext where 67 view = view . contextService 68 instance Has Service.Messages.Messages ActionContext where 69 view = view . contextService 70 instance Has Service.Log.Logs ActionContext where 71 view = view . contextService 72 instance Has Service.Mail.Mailer ActionContext where 73 view = serviceMailer . contextService 74 instance Has Service.Passwd.Passwd ActionContext where 75 view = view . contextService 76 instance Has Service.Entropy.Entropy ActionContext where 77 view = view . contextService 78 instance Has Secret ActionContext where 79 view = view . contextService 80 instance Has InternalState ActionContext where 81 view = contextResourceState 82 instance Has DBConn ActionContext where 83 view = contextDB 84 85 type ActionContextM a = ReaderT ActionContext IO a 86 87 -- | Perform an atomic action without an identity with a guaranteed database 88 -- connection and a fixed version of 'now'. 89 runContextM 90 :: ActionContextM a 91 -> Service 92 -> IO a 93 runContextM action rc = do 94 t <- getCurrentTime 95 runResourceT $ withInternalState $ \is -> 96 withDB (serviceDB rc) $ runReaderT action . ActionContext rc t is 97 98 -- | A ActionContext with no Identity. 99 newtype BackgroundContext = BackgroundContext { backgroundContext :: ActionContext } 100 deriving 101 ( Has Service 102 , Has Notifications 103 , Has Solr 104 , Has Ingest 105 , Has HTTPClient 106 , Has Storage 107 , Has Logs 108 , Has DBConn 109 ) 110 111 instance Has Timestamp BackgroundContext where 112 view = contextTimestamp . backgroundContext 113 instance Has Identity BackgroundContext where 114 view _ = IdentityNotNeeded 115 instance Has SiteAuth BackgroundContext where 116 view _ = view IdentityNotNeeded 117 instance Has Party BackgroundContext where 118 view _ = view IdentityNotNeeded 119 instance Has (Id Party) BackgroundContext where 120 view _ = view IdentityNotNeeded 121 instance Has Access BackgroundContext where 122 view _ = view IdentityNotNeeded 123 124 type BackgroundContextM a = ReaderT BackgroundContext IO a 125 126 withBackgroundContextM :: BackgroundContextM a -> ActionContextM a 127 withBackgroundContextM = withReaderT BackgroundContext 128 129 -- | A ActionContext with no Identity, for running Solr indexing. 130 data SolrIndexingContext = SolrIndexingContext 131 { slcLogs :: !Logs 132 , slcHTTPClient :: !HTTPClient 133 , slcSolr :: !Solr 134 , slcDB :: !DBConn -- ^ The specific connection chosen for the running action? 135 } 136 137 instance Has Solr SolrIndexingContext where 138 view = slcSolr 139 instance Has Logs SolrIndexingContext where 140 view = slcLogs 141 instance Has HTTPClient SolrIndexingContext where 142 view = slcHTTPClient 143 instance Has DBConn SolrIndexingContext where 144 view = slcDB 145 146 instance Has Identity SolrIndexingContext where 147 view _ = IdentityNotNeeded 148 instance Has SiteAuth SolrIndexingContext where 149 view _ = view IdentityNotNeeded 150 instance Has Party SolrIndexingContext where 151 view _ = view IdentityNotNeeded 152 instance Has (Id Party) SolrIndexingContext where 153 view _ = view IdentityNotNeeded 154 instance Has Access SolrIndexingContext where 155 view _ = view IdentityNotNeeded 156 157 type SolrIndexingContextM a = ReaderT SolrIndexingContext IO a 158 159 -- | Build a simpler SolrIndexingContext from a complete ActionContext 160 mkSolrIndexingContext :: ActionContext -> SolrIndexingContext 161 mkSolrIndexingContext ac = 162 SolrIndexingContext { 163 slcLogs = (serviceLogs . contextService) ac 164 , slcHTTPClient = (serviceHTTPClient . contextService) ac 165 , slcSolr = (serviceSolr . contextService) ac 166 , slcDB = contextDB ac 167 }