1 {-# LANGUAGE OverloadedStrings, RecordWildCards #-}
    2 module Service.Init
    3   ( withService
    4   ) where
    5 
    6 import Control.Exception (bracket)
    7 import Control.Monad (when, void)
    8 import Data.IORef (newIORef)
    9 import Data.Time.Clock (getCurrentTime)
   10 
   11 import Ops
   12 import qualified Store.Config as C
   13 import Service.DB (initDB, finiDB, runDBM)
   14 import Service.Entropy (initEntropy)
   15 import HTTP.Client (initHTTPClient)
   16 import Store.Service (initStorage, StorageLocationConfig (..))
   17 import Store.AV (initAV)
   18 import Service.Passwd (initPasswd)
   19 import Service.Log (initLogs, finiLogs)
   20 import Service.Mail (initMailer)
   21 import Service.Messages (loadMessages)
   22 import Web.Service (initWeb)
   23 import Static.Service (initStatic)
   24 import Ingest.Service (initIngest)
   25 import Model.Stats
   26 import Solr.Service (initSolr, finiSolr)
   27 import EZID.Service (initEZID)
   28 import Service.Notification
   29 import Service.Periodic (forkPeriodic)
   30 import Service.Types
   31 import Controller.Notification (forkNotifier)
   32 import Store.Transcoder (initTranscoder)
   33 import Store.Types
   34     (Transcoder, TranscoderConfig (..), Storage)
   35 
   36 -- | Initialize a Service from a Config
   37 initService
   38     :: Bool -- ^ Run in foreground?
   39     -> C.Config
   40     -> IO Service
   41 initService fg conf = do
   42   time <- getCurrentTime
   43   logs <- initLogs (conf C.! (if fg then "log" else "log.bg"))
   44   mailer <- pure initMailer
   45   entropy <- initEntropy
   46   passwd <- initPasswd
   47   messages <- loadMessages
   48   db <- initDB (conf C.! "db")
   49   storage <- initStorage_ (conf C.! "store")
   50   av <- initAV
   51   web <- initWeb
   52   httpc <- initHTTPClient
   53   static <- initStatic (conf C.! "static")
   54   solr <- initSolr fg (conf C.! "solr")
   55   ezid <- initEZID (conf C.! "ezid")
   56   ingest <- initIngest
   57   notify <- initNotifications (conf C.! "notification")
   58   stats <- if fg then runDBM db lookupSiteStats else return (error "siteStats")
   59   statsref <- newIORef stats
   60   let rc = Service
   61         { serviceStartTime = time
   62         , serviceSecret = Secret $ conf C.! "secret"
   63         , serviceEntropy = entropy
   64         , servicePasswd = passwd
   65         , serviceLogs = logs
   66         , serviceMailer = mailer
   67         , serviceMessages = messages
   68         , serviceDB = db
   69         , serviceStorage = storage
   70         , serviceAV = av
   71         , serviceWeb = web
   72         , serviceHTTPClient = httpc
   73         , serviceStatic = static
   74         , serviceStats = statsref
   75         , serviceIngest = ingest
   76         , serviceSolr = solr
   77         , serviceEZID = ezid
   78         , servicePeriodic = Nothing
   79         , serviceNotification = notify
   80         , serviceDown = conf C.! "store.DOWN"
   81         }
   82   periodic <- fg `thenReturn` forkPeriodic rc
   83   when fg $ void $ forkNotifier rc
   84   return $! rc
   85     { servicePeriodic = periodic
   86     }
   87   where
   88   initTranscoder_ :: C.Config -> IO (Maybe Transcoder)
   89   initTranscoder_ c = initTranscoder TranscoderConfig
   90       { transcoderHost = c C.! "host"
   91       , transcoderDir = c C.! "dir"
   92       , transcoderMount = c C.! "mount"
   93       }
   94   initStorage_ :: C.Config -> IO Storage
   95   initStorage_ = initStorage . mkLocConf <*> initTranscoder_ . (C.! "transcode")
   96   mkLocConf :: C.Config -> Either String StorageLocationConfig
   97   mkLocConf c
   98       | Just down <- c C.! "DOWN" = Left down
   99       | otherwise = Right StorageLocationConfig
  100           { storageLocTemp = c C.! "temp"
  101           , storageLocMaster = c C.! "master"
  102           , storageLocUpload = c C.! "upload"
  103           , storageLocCache = c C.! "cache"
  104           , storageLocStage = c C.! "stage"
  105           , storageLocFallback = c C.! "fallback"
  106           }
  107 
  108 -- | Close up Solr, database, and logs
  109 finiService :: Service -> IO ()
  110 finiService Service{..} = do
  111   finiSolr serviceSolr
  112   finiDB serviceDB
  113   finiLogs serviceLogs
  114 
  115 -- | Bracket an action that uses a Service, governed by a Config.
  116 withService
  117     :: Bool -- ^ Run in foreground?
  118     -> C.Config -- ^ Config for the Service
  119     -> (Service -> IO a) -- ^ Action to run
  120     -> IO a -- ^ Result of action
  121 withService fg c = bracket (initService fg c) finiService