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