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