src/Gargantext/Utils/Jobs/Monad.hs

   1 {-# LANGUAGE MultiWayIf, FunctionalDependencies, MultiParamTypeClasses, TypeFamilies #-}
   2 module Gargantext.Utils.Jobs.Monad (
   3   -- * Types and classes
   4     JobEnv(..)
   5   , NumRunners
   6   , JobError(..)
   7
   8   , MonadJob(..)
   9   , MonadJobStatus(..)
  10
  11   -- * Functions
  12   , newJobEnv
  13   , defaultJobSettings
  14   , genSecret
  15   , getJobsSettings
  16   , getJobsState
  17   , getJobsMap
  18   , getJobsQueue
  19   , queueJob
  20   , findJob
  21   , checkJID
  22   , withJob
  23   , handleIDError
  24   , removeJob
  25   ) where
  26
  27 import Gargantext.Utils.Jobs.Settings
  28 import Gargantext.Utils.Jobs.Map
  29 import Gargantext.Utils.Jobs.Queue
  30 import Gargantext.Utils.Jobs.State
  31
  32 import Control.Concurrent.STM
  33 import Control.Exception
  34 import Control.Monad.Except
  35 import Data.Kind (Type)
  36 import Data.Map.Strict (Map)
  37 import Data.Time.Clock
  38 import Network.HTTP.Client (Manager)
  39 import Prelude
  40
  41 import qualified Servant.Job.Core as SJ
  42 import qualified Servant.Job.Types as SJ
  43
  44 data JobEnv t w a = JobEnv
  45   { jeSettings :: JobSettings
  46   , jeState    :: JobsState t w a
  47   , jeManager  :: Manager
  48   }
  49
  50 newJobEnv
  51   :: (EnumBounded t, Monoid w)
  52   => JobSettings
  53   -> Map t Prio
  54   -> Manager
  55   -> IO (JobEnv t w a)
  56 newJobEnv js prios mgr = JobEnv js <$> newJobsState js prios <*> pure mgr
  57
  58 type NumRunners = Int
  59
  60 defaultJobSettings :: NumRunners -> SJ.SecretKey -> JobSettings
  61 defaultJobSettings numRunners k = JobSettings
  62   { jsNumRunners = numRunners
  63   , jsJobTimeout = 30 * 60 -- 30 minutes
  64   , jsIDTimeout  = 30 * 60 -- 30 minutes
  65   , jsGcPeriod   =  1 * 60 -- 1 minute
  66   , jsSecretKey  = k
  67   }
  68
  69 genSecret :: IO SJ.SecretKey
  70 genSecret = SJ.generateSecretKey
  71
  72 class MonadIO m => MonadJob m t w a | m -> t w a where
  73   getJobEnv :: m (JobEnv t w a)
  74
  75 getJobsSettings :: MonadJob m t w a => m JobSettings
  76 getJobsSettings = jeSettings <$> getJobEnv
  77
  78 getJobsState :: MonadJob m t w a => m (JobsState t w a)
  79 getJobsState = jeState <$> getJobEnv
  80
  81 getJobsMap :: MonadJob m t w a => m (JobMap (SJ.JobID 'SJ.Safe) w a)
  82 getJobsMap = jobsData <$> getJobsState
  83
  84 getJobsQueue :: MonadJob m t w a => m (Queue t (SJ.JobID 'SJ.Safe))
  85 getJobsQueue = jobsQ <$> getJobsState
  86
  87 queueJob
  88   :: (MonadJob m t w a, Ord t)
  89   => t
  90   -> i
  91   -> (SJ.JobID 'SJ.Safe -> i -> Logger w -> IO a)
  92   -> m (SJ.JobID 'SJ.Safe)
  93 queueJob jobkind input f = do
  94   js <- getJobsSettings
  95   st <- getJobsState
  96   liftIO (pushJob jobkind input f js st)
  97
  98 findJob
  99   :: MonadJob m t w a
 100   => SJ.JobID 'SJ.Safe
 101   -> m (Maybe (JobEntry (SJ.JobID 'SJ.Safe) w a))
 102 findJob jid = do
 103   jmap <- getJobsMap
 104   liftIO $ lookupJob jid jmap
 105
 106 data JobError
 107   = InvalidIDType
 108   | IDExpired
 109   | InvalidMacID
 110   | UnknownJob
 111   | JobException SomeException
 112   deriving Show
 113
 114 checkJID
 115   :: MonadJob m t w a
 116   => SJ.JobID 'SJ.Unsafe
 117   -> m (Either JobError (SJ.JobID 'SJ.Safe))
 118 checkJID (SJ.PrivateID tn n t d) = do
 119   now <- liftIO getCurrentTime
 120   js <- getJobsSettings
 121   if | tn /= "job" -> return (Left InvalidIDType)
 122      | now > addUTCTime (fromIntegral $ jsIDTimeout js) t -> return (Left IDExpired)
 123      | d /= SJ.macID tn (jsSecretKey js) t n -> return (Left InvalidMacID)
 124      | otherwise -> return $ Right (SJ.PrivateID tn n t d)
 125
 126 withJob
 127   :: MonadJob m t w a
 128   => SJ.JobID 'SJ.Unsafe
 129   -> (SJ.JobID 'SJ.Safe -> JobEntry (SJ.JobID 'SJ.Safe) w a -> m r)
 130   -> m (Either JobError (Maybe r))
 131 withJob jid f = do
 132   r <- checkJID jid
 133   case r of
 134     Left e -> return (Left e)
 135     Right jid' -> do
 136       mj <- findJob jid'
 137       case mj of
 138         Nothing -> return (Right Nothing)
 139         Just j  -> Right . Just <$> f jid' j
 140
 141 handleIDError
 142   :: MonadError e m
 143   => (JobError -> e)
 144   -> m (Either JobError a)
 145   -> m a
 146 handleIDError toE act = act >>= \r -> case r of
 147   Left err -> throwError (toE err)
 148   Right a  -> return a
 149
 150 removeJob
 151   :: (Ord t, MonadJob m t w a)
 152   => Bool -- is it queued (and we have to remove jid from queue)
 153   -> t
 154   -> SJ.JobID 'SJ.Safe
 155   -> m ()
 156 removeJob queued t jid = do
 157   q <- getJobsQueue
 158   m <- getJobsMap
 159   liftIO . atomically $ do
 160     when queued $
 161       deleteQueue t jid q
 162     deleteJob jid m
 163
 164 --
 165 -- Tracking jobs status
 166 --
 167
 168 -- | A monad to query for the status of a particular job /and/ submit updates for in-progress jobs.
 169 class MonadJob m (JobType m) (t [JobEventType m]) (JobOutputType m) => MonadJobStatus m t where
 170   type JobType        m :: Type
 171   type JobOutputType  m :: Type
 172   type JobEventType   m :: Type
 173   type JobErrorType   m :: Type