src/Gargantext/Utils/Jobs/Monad.hs

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