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     }