src/Gargantext/Utils/Jobs.hs

   1 {-# LANGUAGE TypeFamilies #-}
   2 module Gargantext.Utils.Jobs (
   3   -- * Serving the JOBS API
   4     serveJobsAPI
   5   -- * Parsing and reading @GargJob@s from disk
   6   , readPrios
   7   -- * Handy re-exports
   8   , jobHandleLogger
   9   ) where
  10
  11 import Control.Monad.Except
  12 import Control.Monad.Reader
  13 import Data.Aeson (ToJSON)
  14 import Prelude
  15 import System.Directory (doesFileExist)
  16 import Text.Read (readMaybe)
  17
  18 import Gargantext.API.Admin.EnvTypes
  19 import Gargantext.API.Prelude
  20 import qualified Gargantext.Utils.Jobs.Internal as Internal
  21 import Gargantext.Utils.Jobs.Monad
  22
  23 import qualified Servant.Job.Async as SJ
  24
  25 jobErrorToGargError
  26   :: JobError -> GargError
  27 jobErrorToGargError = GargJobError
  28
  29 serveJobsAPI
  30   :: (
  31      Foldable callbacks
  32    , Ord (JobType m)
  33    , Show (JobType m)
  34    , ToJSON (JobEventType m)
  35    , ToJSON (JobOutputType m)
  36    , MonadJobStatus m
  37    , m ~ (GargM env GargError)
  38    )
  39   => JobType m
  40   -> (JobHandle m (JobEventType m) -> input -> m (JobOutputType m))
  41   -> SJ.AsyncJobsServerT' ctI ctO callbacks (JobEventType m) input (JobOutputType m) m
  42 serveJobsAPI jobType f = Internal.serveJobsAPI ask jobType jobErrorToGargError $ \env jHandle i -> do
  43   putStrLn ("Running job of type: " ++ show jobType)
  44   runExceptT $ runReaderT (f jHandle i) env
  45
  46 parseGargJob :: String -> Maybe GargJob
  47 parseGargJob s = case s of
  48   "tablengrams" -> Just TableNgramsJob
  49   "forgotpassword" -> Just ForgotPasswordJob
  50   "updatengramslistjson" -> Just UpdateNgramsListJobJSON
  51   "updatengramslistcsv" -> Just UpdateNgramsListJobCSV
  52   "addcontact" -> Just AddContactJob
  53   "addfile" -> Just AddFileJob
  54   "documentfromwritenode" -> Just DocumentFromWriteNodeJob
  55   "updatenode" -> Just UpdateNodeJob
  56   "updateframecalc" -> Just UploadFrameCalcJob
  57   "updatedocument" -> Just UploadDocumentJob
  58   "newnode" -> Just NewNodeJob
  59   "addcorpusquery" -> Just AddCorpusQueryJob
  60   "addcorpusform" -> Just AddCorpusFormJob
  61   "addcorpusfile" -> Just AddCorpusFileJob
  62   "addannuaireform" -> Just AddAnnuaireFormJob
  63   "recomputegraph" -> Just RecomputeGraphJob
  64   _ -> Nothing
  65
  66 parsePrios :: [String] -> IO [(GargJob, Int)]
  67 parsePrios []       = return []
  68 parsePrios (x : xs) = (:) <$> go x <*> parsePrios xs
  69   where go s = case break (=='=') s of
  70           ([], _) -> error "parsePrios: empty jobname?"
  71           (prop, valS)
  72             | Just val <- readMaybe (tail valS)
  73             , Just j   <- parseGargJob prop -> return (j, val)
  74             | otherwise                  -> error $
  75               "parsePrios: invalid input. " ++ show (prop, valS)
  76
  77 readPrios :: FilePath -> IO [(GargJob, Int)]
  78 readPrios fp = do
  79   exists <- doesFileExist fp
  80   case exists of
  81     False -> do
  82       putStrLn $
  83         "Warning: " ++ fp ++ " doesn't exist, using default job priorities."
  84       return []
  85     True -> parsePrios . lines =<< readFile fp