src/Gargantext/API/Admin/EnvTypes.hs

   1 -- |
   2
   3 {-# LANGUAGE TemplateHaskell     #-}
   4 {-# LANGUAGE TypeFamilies        #-}
   5
   6 module Gargantext.API.Admin.EnvTypes (
   7     GargJob(..)
   8   , Env(..)
   9   , mkJobHandle
  10   , env_logger
  11   , env_manager
  12   , env_self_url
  13   , menv_firewall
  14
  15   , MockEnv(..)
  16   , DevEnv(..)
  17   , DevJobHandle(..)
  18   , ConcreteJobHandle -- opaque
  19   ) where
  20
  21 import Control.Lens hiding ((:>))
  22 import Control.Monad.Except
  23 import Control.Monad.Reader
  24 import Data.Pool (Pool)
  25 import Data.Sequence (Seq, ViewR(..), viewr)
  26 import Database.PostgreSQL.Simple (Connection)
  27 import GHC.Generics (Generic)
  28 import Network.HTTP.Client (Manager)
  29 import Servant.Client (BaseUrl)
  30 import Servant.Job.Async (HasJobEnv(..), Job)
  31 import qualified Servant.Job.Async as SJ
  32 import System.Log.FastLogger
  33 import qualified Servant.Job.Core
  34
  35 import Gargantext.API.Admin.Types
  36 import Gargantext.API.Admin.Orchestrator.Types
  37 import Gargantext.API.Job
  38 import Gargantext.API.Prelude (GargM)
  39 import Gargantext.Core.NodeStory
  40 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
  41 import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
  42 import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
  43 import Gargantext.Prelude
  44 import Gargantext.Prelude.Config (GargConfig(..))
  45 import Gargantext.Prelude.Mail.Types (MailConfig)
  46
  47 import qualified Gargantext.Utils.Jobs.Monad as Jobs
  48 import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
  49
  50 data GargJob
  51   = TableNgramsJob
  52   | ForgotPasswordJob
  53   | UpdateNgramsListJobJSON
  54   | UpdateNgramsListJobCSV
  55   | AddContactJob
  56   | AddFileJob
  57   | DocumentFromWriteNodeJob
  58   | UpdateNodeJob
  59   | UploadFrameCalcJob
  60   | UploadDocumentJob
  61   | NewNodeJob
  62   | AddCorpusQueryJob
  63   | AddCorpusFormJob
  64   | AddCorpusFileJob
  65   | AddAnnuaireFormJob
  66   | RecomputeGraphJob
  67   deriving (Show, Eq, Ord, Enum, Bounded)
  68
  69 -- Do /not/ treat the data types of this type as strict, because it's convenient
  70 -- to be able to partially initialise things like an 'Env' during tests, without
  71 -- having to specify /everything/. This means that when we /construct/ an 'Env',
  72 -- we need to remember to force the fields to WHNF at that point.
  73 data Env = Env
  74   { _env_settings  :: ~Settings
  75   , _env_logger    :: ~LoggerSet
  76   , _env_pool      :: ~(Pool Connection)
  77   , _env_nodeStory :: ~NodeStoryEnv
  78   , _env_manager   :: ~Manager
  79   , _env_self_url  :: ~BaseUrl
  80   , _env_scrapers  :: ~ScrapersEnv
  81   , _env_jobs      :: ~(Jobs.JobEnv GargJob (Seq JobLog) JobLog)
  82   , _env_config    :: ~GargConfig
  83   , _env_mail      :: ~MailConfig
  84   , _env_nlp       :: ~NLPServerMap
  85   }
  86   deriving (Generic)
  87
  88 makeLenses ''Env
  89
  90 instance HasConfig Env where
  91   hasConfig = env_config
  92
  93 instance HasConnectionPool Env where
  94   connPool = env_pool
  95
  96 instance HasNodeStoryEnv Env where
  97   hasNodeStory = env_nodeStory
  98
  99 instance HasNodeStoryVar Env where
 100   hasNodeStoryVar = hasNodeStory . nse_getter
 101
 102 instance HasNodeStorySaver Env where
 103   hasNodeStorySaver = hasNodeStory . nse_saver
 104
 105 instance HasNodeStoryImmediateSaver Env where
 106   hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
 107
 108 instance HasNodeArchiveStoryImmediateSaver Env where
 109   hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
 110
 111 instance HasSettings Env where
 112   settings = env_settings
 113
 114 instance HasMail Env where
 115   mailSettings = env_mail
 116
 117 instance HasNLPServer Env where
 118   nlpServer = env_nlp
 119
 120 instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
 121   _env = env_scrapers . Servant.Job.Core._env
 122
 123 instance HasJobEnv Env JobLog JobLog where
 124   job_env = env_scrapers
 125
 126 instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
 127   getJobEnv = asks (view env_jobs)
 128
 129 -- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
 130 -- constructor it's not exported, to not leak internal details of its implementation.
 131 data ConcreteJobHandle err = JobHandle {
 132       _jh_id     :: !(SJ.JobID 'SJ.Safe)
 133     , _jh_logger :: LoggerM (GargM Env err) JobLog
 134     }
 135
 136 -- | Creates a new /concrete/ 'JobHandle', given its underlying 'JobID' and the logging function to
 137 -- be used to report the status.
 138 mkJobHandle :: SJ.JobID 'SJ.Safe
 139             -> LoggerM (GargM Env err) JobLog
 140             -> ConcreteJobHandle err
 141 mkJobHandle jId = JobHandle jId
 142
 143 -- | Updates the status of a 'JobHandle' by using the input 'updateJobStatus' function.
 144 updateJobProgress :: ConcreteJobHandle err -> (JobLog -> JobLog) -> GargM Env err ()
 145 updateJobProgress hdl@(JobHandle _ logStatus) updateJobStatus =
 146   Jobs.getLatestJobStatus hdl >>= logStatus . updateJobStatus
 147
 148 instance Jobs.MonadJobStatus (GargM Env err) where
 149
 150   type JobHandle      (GargM Env err) = ConcreteJobHandle err
 151   type JobType        (GargM Env err) = GargJob
 152   type JobOutputType  (GargM Env err) = JobLog
 153   type JobEventType   (GargM Env err) = JobLog
 154
 155   getLatestJobStatus (JobHandle jId _) = do
 156     mb_jb <- Jobs.findJob jId
 157     case mb_jb of
 158       Nothing -> pure noJobLog
 159       Just j  -> case jTask j of
 160         QueuedJ _   -> pure noJobLog
 161         RunningJ rj -> liftIO (rjGetLog rj) <&>
 162                          \lgs -> case viewr lgs of
 163                                    EmptyR -> noJobLog
 164                                    _ :> l -> l
 165         DoneJ lgs _ -> pure $ case viewr lgs of
 166                                    EmptyR -> noJobLog
 167                                    _ :> l -> l
 168
 169   withTracer extraLogger (JobHandle jId logger) n = n (JobHandle jId (\w -> logger w >> liftIO (extraLogger w)))
 170
 171   markStarted n jh = updateJobProgress jh (const $ jobLogStart (RemainingSteps n))
 172
 173   markProgress steps jh = updateJobProgress jh (jobLogProgress steps)
 174
 175   markFailure steps mb_msg jh =
 176     updateJobProgress jh (\latest -> case mb_msg of
 177                                        Nothing  -> jobLogFailures steps latest
 178                                        Just msg -> addErrorEvent msg (jobLogFailures steps latest)
 179                          )
 180
 181   markComplete jh = updateJobProgress jh jobLogComplete
 182
 183   markFailed mb_msg jh =
 184     updateJobProgress jh (\latest -> case mb_msg of
 185                                        Nothing  -> jobLogFailTotal latest
 186                                        Just msg -> jobLogFailTotalWithMessage msg latest
 187                          )
 188
 189 data MockEnv = MockEnv
 190   { _menv_firewall :: !FireWall
 191   }
 192   deriving (Generic)
 193
 194 makeLenses ''MockEnv
 195
 196 data DevEnv = DevEnv
 197   { _dev_env_settings  :: !Settings
 198   , _dev_env_config    :: !GargConfig
 199   , _dev_env_pool      :: !(Pool Connection)
 200   , _dev_env_nodeStory :: !NodeStoryEnv
 201   , _dev_env_mail      :: !MailConfig
 202   , _dev_env_nlp       :: !NLPServerMap
 203   }
 204
 205 makeLenses ''DevEnv
 206
 207 -- | Our /mock/ job handle.
 208 data DevJobHandle = DevJobHandle
 209
 210 instance Jobs.MonadJobStatus (GargM DevEnv err) where
 211
 212   type JobHandle (GargM DevEnv err) = DevJobHandle
 213
 214   type JobType        (GargM DevEnv err) = GargJob
 215   type JobOutputType  (GargM DevEnv err) = JobLog
 216   type JobEventType   (GargM DevEnv err) = JobLog
 217
 218   getLatestJobStatus DevJobHandle = pure noJobLog
 219
 220   withTracer _ DevJobHandle n = n DevJobHandle
 221
 222   markStarted _ _ = pure ()
 223
 224   markProgress _ _ = pure ()
 225
 226   markFailure _ _ _ = pure ()
 227
 228   markComplete _ = pure ()
 229
 230   markFailed _ _ = pure ()
 231
 232 instance HasConfig DevEnv where
 233   hasConfig = dev_env_config
 234
 235 instance HasConnectionPool DevEnv where
 236   connPool = dev_env_pool
 237
 238 instance HasSettings DevEnv where
 239   settings = dev_env_settings
 240
 241
 242 instance HasNodeStoryEnv DevEnv where
 243   hasNodeStory = dev_env_nodeStory
 244
 245 instance HasNodeStoryVar DevEnv where
 246   hasNodeStoryVar = hasNodeStory . nse_getter
 247
 248 instance HasNodeStorySaver DevEnv where
 249   hasNodeStorySaver = hasNodeStory . nse_saver
 250
 251 instance HasNodeStoryImmediateSaver DevEnv where
 252   hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
 253
 254 instance HasNodeArchiveStoryImmediateSaver DevEnv where
 255   hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
 256
 257 instance HasMail DevEnv where
 258   mailSettings = dev_env_mail
 259
 260 instance HasNLPServer DevEnv where
 261   nlpServer = dev_env_nlp