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   , MonadJobStatus(..)
   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    , JobEventType m ~ JobOutputType m
  39    )
  40   => JobType m
  41   -> (JobHandle m -> input -> m ())
  42   -> SJ.AsyncJobsServerT' ctI ctO callbacks (JobEventType m) input (JobOutputType m) m
  43 serveJobsAPI jobType f = Internal.serveJobsAPI mkJobHandle ask jobType jobErrorToGargError $ \env jHandle i -> do
  44   putStrLn ("Running job of type: " ++ show jobType)
  45   runExceptT $ runReaderT (f jHandle i >> getLatestJobStatus jHandle) env
  46
  47 parseGargJob :: String -> Maybe GargJob
  48 parseGargJob s = case s of
  49   "tablengrams" -> Just TableNgramsJob
  50   "forgotpassword" -> Just ForgotPasswordJob
  51   "updatengramslistjson" -> Just UpdateNgramsListJobJSON
  52   "updatengramslistcsv" -> Just UpdateNgramsListJobCSV
  53   "addcontact" -> Just AddContactJob
  54   "addfile" -> Just AddFileJob
  55   "documentfromwritenode" -> Just DocumentFromWriteNodeJob
  56   "updatenode" -> Just UpdateNodeJob
  57   "updateframecalc" -> Just UploadFrameCalcJob
  58   "updatedocument" -> Just UploadDocumentJob
  59   "newnode" -> Just NewNodeJob
  60   "addcorpusquery" -> Just AddCorpusQueryJob
  61   "addcorpusform" -> Just AddCorpusFormJob
  62   "addcorpusfile" -> Just AddCorpusFileJob
  63   "addannuaireform" -> Just AddAnnuaireFormJob
  64   "recomputegraph" -> Just RecomputeGraphJob
  65   _ -> Nothing
  66
  67 parsePrios :: [String] -> IO [(GargJob, Int)]
  68 parsePrios []       = return []
  69 parsePrios (x : xs) = (:) <$> go x <*> parsePrios xs
  70   where go s = case break (=='=') s of
  71           ([], _) -> error "parsePrios: empty jobname?"
  72           (prop, valS)
  73             | Just val <- readMaybe (tail valS)
  74             , Just j   <- parseGargJob prop -> return (j, val)
  75             | otherwise                  -> error $
  76               "parsePrios: invalid input. " ++ show (prop, valS)
  77
  78 readPrios :: FilePath -> IO [(GargJob, Int)]
  79 readPrios fp = do
  80   exists <- doesFileExist fp
  81   case exists of
  82     False -> do
  83       putStrLn $
  84         "Warning: " ++ fp ++ " doesn't exist, using default job priorities."
  85       return []
  86     True -> parsePrios . lines =<< readFile fp