1 {-# LANGUAGE TemplateHaskell #-} 2 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 module Databrary.Context 4 ( ActionContext(..) 5 , ActionContextM 6 , runContextM 7 , BackgroundContext(..) 8 , BackgroundContextM 9 , withBackgroundContextM 10 ) where 11 12 import Control.Monad.Trans.Reader (ReaderT(..), withReaderT) 13 import Control.Monad.Trans.Resource (InternalState, runResourceT, withInternalState) 14 import Data.Time (getCurrentTime) 15 16 import Databrary.Has 17 import Databrary.HTTP.Client 18 import Databrary.Model.Time 19 import Databrary.Model.Id.Types 20 import Databrary.Model.Identity.Types 21 import Databrary.Model.Party.Types 22 import Databrary.Model.Permission.Types 23 import Databrary.Service.Log 24 import Databrary.Service.Types 25 import Databrary.Service.DB 26 import Databrary.Service.Entropy 27 import Databrary.Service.Messages 28 import Databrary.Service.Notification 29 import Databrary.Service.Passwd 30 import Databrary.Solr.Service 31 import Databrary.Static.Service 32 import Databrary.Ingest.Service 33 import Databrary.Store.AV 34 import Databrary.Store.Types 35 import Databrary.Web.Types 36 37 -- | This is the context for when you don't have an identity, but you have a 38 -- fully initialized, "command line" access to the system. 39 data ActionContext = ActionContext 40 { contextService :: !Service -- ^ All initialized services; "the imperative shell" 41 , contextTimestamp :: !Timestamp -- ^ When the ActionContextM action is running (i.e., NOW) 42 , contextResourceState :: !InternalState -- ^ Optimization for MonadResource 43 , contextDB :: !DBConn -- ^ The specific connection chosen for the running action? 44 } 45 46 instance Has Service ActionContext where 47 view = contextService 48 instance Has Databrary.Service.Notification.Notifications ActionContext where 49 view = (view . contextService) 50 instance Has Databrary.Solr.Service.Solr ActionContext where 51 view = (view . contextService) 52 instance Has Databrary.Ingest.Service.Ingest ActionContext where 53 view = (view . contextService) 54 instance Has Databrary.Static.Service.Static ActionContext where 55 view = (view . contextService) 56 instance Has Databrary.HTTP.Client.HTTPClient ActionContext where 57 view = (view . contextService) 58 instance Has Databrary.Web.Types.Web ActionContext where 59 view = (view . contextService) 60 instance Has Databrary.Store.AV.AV ActionContext where 61 view = (view . contextService) 62 instance Has Databrary.Store.Types.Storage ActionContext where 63 view = (view . contextService) 64 instance Has Databrary.Service.Messages.Messages ActionContext where 65 view = (view . contextService) 66 instance Has Databrary.Service.Log.Logs ActionContext where 67 view = (view . contextService) 68 instance Has Databrary.Service.Passwd.Passwd ActionContext where 69 view = (view . contextService) 70 instance Has Databrary.Service.Entropy.Entropy ActionContext where 71 view = (view . contextService) 72 instance Has Secret ActionContext where 73 view = (view . contextService) 74 instance Has InternalState ActionContext where 75 view = contextResourceState 76 instance Has DBConn ActionContext where 77 view = contextDB 78 79 type ActionContextM a = ReaderT ActionContext IO a 80 81 -- | Perform an atomic action without an identity with a guaranteed database 82 -- connection and a fixed version of 'now'. 83 runContextM 84 :: ActionContextM a 85 -> Service 86 -> IO a 87 runContextM action rc = do 88 t <- getCurrentTime 89 runResourceT $ withInternalState $ \is -> 90 withDB (serviceDB rc) $ runReaderT action . ActionContext rc t is 91 92 -- | A ActionContext with no Identity. 93 newtype BackgroundContext = BackgroundContext { backgroundContext :: ActionContext } 94 deriving 95 ( Has Service 96 , Has Notifications 97 , Has Solr 98 , Has Ingest 99 , Has HTTPClient 100 , Has Storage 101 , Has Logs 102 , Has DBConn 103 ) 104 105 instance Has Timestamp BackgroundContext where 106 view = (contextTimestamp . backgroundContext) 107 instance Has Identity BackgroundContext where 108 view _ = IdentityNotNeeded 109 instance Has SiteAuth BackgroundContext where 110 view _ = view IdentityNotNeeded 111 instance Has Party BackgroundContext where 112 view _ = view IdentityNotNeeded 113 instance Has (Id Party) BackgroundContext where 114 view _ = view IdentityNotNeeded 115 instance Has Access BackgroundContext where 116 view _ = view IdentityNotNeeded 117 118 type BackgroundContextM a = ReaderT BackgroundContext IO a 119 120 withBackgroundContextM :: BackgroundContextM a -> ActionContextM a 121 withBackgroundContextM = withReaderT BackgroundContext