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