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 (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 defaultJobSettings :: SJ.SecretKey -> JobSettings
  35 defaultJobSettings k = JobSettings
  36   { jsNumRunners = 2
  37   , jsJobTimeout = 30 * 60 -- 30 minutes
  38   , jsIDTimeout  = 30 * 60 -- 30 minutes
  39   , jsGcPeriod   =  1 * 60 -- 1 minute
  40   , jsSecretKey  = k
  41   }
  42
  43 genSecret :: IO SJ.SecretKey
  44 genSecret = SJ.generateSecretKey
  45
  46 class MonadIO m => MonadJob m t w a | m -> t w a where
  47   getJobEnv :: m (JobEnv t w a)
  48
  49 getJobsSettings :: MonadJob m t w a => m JobSettings
  50 getJobsSettings = jeSettings <$> getJobEnv
  51
  52 getJobsState :: MonadJob m t w a => m (JobsState t w a)
  53 getJobsState = jeState <$> getJobEnv
  54
  55 getJobsMap :: MonadJob m t w a => m (JobMap (SJ.JobID 'SJ.Safe) w a)
  56 getJobsMap = jobsData <$> getJobsState
  57
  58 getJobsQueue :: MonadJob m t w a => m (Queue t (SJ.JobID 'SJ.Safe))
  59 getJobsQueue = jobsQ <$> getJobsState
  60
  61 queueJob
  62   :: (MonadJob m t w a, Ord t)
  63   => t
  64   -> i
  65   -> (i -> Logger w -> IO a)
  66   -> m (SJ.JobID 'SJ.Safe)
  67 queueJob jobkind input f = do
  68   js <- getJobsSettings
  69   st <- getJobsState
  70   liftIO (pushJob jobkind input f js st)
  71
  72 findJob
  73   :: MonadJob m t w a
  74   => SJ.JobID 'SJ.Safe
  75   -> m (Maybe (JobEntry (SJ.JobID 'SJ.Safe) w a))
  76 findJob jid = do
  77   jmap <- getJobsMap
  78   liftIO $ lookupJob jid jmap
  79
  80 data JobError
  81   = InvalidIDType
  82   | IDExpired
  83   | InvalidMacID
  84   | UnknownJob
  85   | JobException SomeException
  86   deriving Show
  87
  88 checkJID
  89   :: MonadJob m t w a
  90   => SJ.JobID 'SJ.Unsafe
  91   -> m (Either JobError (SJ.JobID 'SJ.Safe))
  92 checkJID (SJ.PrivateID tn n t d) = do
  93   now <- liftIO getCurrentTime
  94   js <- getJobsSettings
  95   if | tn /= "job" -> return (Left InvalidIDType)
  96      | now > addUTCTime (fromIntegral $ jsIDTimeout js) t -> return (Left IDExpired)
  97      | d /= SJ.macID tn (jsSecretKey js) t n -> return (Left InvalidMacID)
  98      | otherwise -> return $ Right (SJ.PrivateID tn n t d)
  99
 100 withJob
 101   :: MonadJob m t w a
 102   => SJ.JobID 'SJ.Unsafe
 103   -> (SJ.JobID 'SJ.Safe -> JobEntry (SJ.JobID 'SJ.Safe) w a -> m r)
 104   -> m (Either JobError (Maybe r))
 105 withJob jid f = do
 106   r <- checkJID jid
 107   case r of
 108     Left e -> return (Left e)
 109     Right jid' -> do
 110       mj <- findJob jid'
 111       case mj of
 112         Nothing -> return (Right Nothing)
 113         Just j  -> Right . Just <$> f jid' j
 114
 115 handleIDError
 116   :: MonadError e m
 117   => (JobError -> e)
 118   -> m (Either JobError a)
 119   -> m a
 120 handleIDError toE act = act >>= \r -> case r of
 121   Left err -> throwError (toE err)
 122   Right a  -> return a
 123
 124 removeJob
 125   :: (Ord t, MonadJob m t w a)
 126   => Bool -- is it queued (and we have to remove jid from queue)
 127   -> t
 128   -> SJ.JobID 'SJ.Safe
 129   -> m ()
 130 removeJob queued t jid = do
 131   q <- getJobsQueue
 132   m <- getJobsMap
 133   liftIO . atomically $ do
 134     when queued $
 135       deleteQueue t jid q
 136     deleteJob jid m