[worker] some more WorkerMonad instances implementations

bin/gargantext-cli/CLI/Import.hs

@@ -33,7 +33,6 @@ import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusName))
 import Gargantext.Prelude
-import Gargantext.Utils.Jobs.Monad ( MonadJobStatus, JobHandle )
 import Options.Applicative
 import Prelude (String)
 import qualified Data.Text as T

src/Gargantext/API/Node/Corpus/New.hs

@@ -60,7 +60,6 @@ import Gargantext.Prelude
 import Gargantext.Core.Config (gc_max_docs_parsers)
 import Gargantext.System.Logging ( logLocM, LogLevel(..) )
 import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
-import Test.QuickCheck.Arbitrary (Arbitrary(..))
 
 ------------------------------------------------------------------------
 {-
@@ -120,8 +119,6 @@ api uid (Query q _ as) = do
 -- TODO use this route for Client implementation
 data ApiInfo = ApiInfo { api_info :: [API.ExternalAPIs]}
   deriving (Generic)
-instance Arbitrary ApiInfo where
-  arbitrary = ApiInfo <$> arbitrary
 
 deriveJSON (unPrefix "") 'ApiInfo
 

src/Gargantext/Core/Worker.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans      #-}  -- orphan HasNodeError IOException
 
@@ -24,6 +25,7 @@ import Async.Worker.Types (HasWorkerBroker)
 import Data.Text qualified as T
 import Gargantext.API.Admin.Auth (forgotUserPassword)
 import Gargantext.API.Admin.Auth.Types (ForgotPasswordAsyncParams(..))
+import Gargantext.API.Node.Corpus.New (addToCorpusWithForm)
 import Gargantext.API.Node.New (postNode')
 import Gargantext.Core.Worker.Env
 import Gargantext.Core.Worker.Jobs
@@ -31,6 +33,7 @@ import Gargantext.Core.Worker.Jobs.Types (Job(..))
 import Gargantext.Core.Worker.TOML (WorkerDefinition(..), wdToRedisConnectInfo)
 import Gargantext.Database.Query.Table.User (getUsersWithEmail)
 import Gargantext.Prelude
+import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(noJobHandle) )
 
   
 
@@ -72,8 +75,9 @@ performAction env _state bm = do
   let job' = toA $ getMessage bm
   case Worker.job job' of
     Ping -> putStrLn ("ping" :: Text)
-    AddCorpusFormAsync { } -> runWorkerMonad env $ do
+    AddCorpusFormAsync { .. } -> runWorkerMonad env $ do
       liftBase $ putStrLn ("add corpus form" :: Text)
+      addToCorpusWithForm _acf_user _acf_cid _acf_args (noJobHandle Proxy)
     ForgotPasswordAsync { _fpa_args = ForgotPasswordAsyncParams { email } } -> runWorkerMonad env $ do
       liftBase $ putStrLn ("forgot password: " <> email)
       us <- getUsersWithEmail (T.toLower email)

src/Gargantext/Core/Worker/Env.hs

@@ -22,7 +22,8 @@ import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Pool (Pool)
 import Data.Text qualified as T
 import Database.PostgreSQL.Simple (Connection)
-import Gargantext.API.Admin.EnvTypes (Mode(Dev), modeToLoggingLevels)
+import Gargantext.API.Admin.EnvTypes (ConcreteJobHandle, Env, GargJob, Mode(Dev), modeToLoggingLevels)
+import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
 import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool, SettingsFile (..), IniFile (..) )
 import Gargantext.API.Admin.Types (HasSettings(..), Settings(..))
 import Gargantext.API.Prelude (GargM)
@@ -31,11 +32,15 @@ import Gargantext.Core.Config.Mail qualified as Mail
 import Gargantext.Core.Config.NLP qualified as NLP
 import Gargantext.Core.Mail.Types (HasMail(..))
 import Gargantext.Core.NLP (HasNLPServer(..), NLPServerMap, nlpServerMap)
-import Gargantext.Core.NodeStory (NodeStoryEnv, fromDBNodeStoryEnv)
+import Gargantext.Core.NodeStory (HasNodeStoryEnv(..), HasNodeStoryImmediateSaver(..), HasNodeArchiveStoryImmediateSaver(..), NodeStoryEnv, fromDBNodeStoryEnv, nse_saver_immediate, nse_archive_saver_immediate)
+import Gargantext.Core.Types (HasValidationError(..))
 import Gargantext.Database.Prelude (HasConfig(..), HasConnectionPool(..), databaseParameters)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
+import Gargantext.Database.Query.Tree.Error (HasTreeError(..))
 import Gargantext.Prelude hiding (to)
-import Gargantext.System.Logging (HasLogger(..), Logger, withLoggerHoisted)
+import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..), withLoggerHoisted)
+import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
+import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
 import Prelude qualified
 import System.Log.FastLogger qualified as FL
 
@@ -109,6 +114,43 @@ instance HasMail WorkerEnv where
 instance HasNLPServer WorkerEnv where
   nlpServer = to _w_env_nlp
 
+instance HasNodeStoryEnv WorkerEnv where
+  hasNodeStory = to _w_env_nodeStory
+
+instance HasNodeStoryImmediateSaver WorkerEnv where
+  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
+
+instance HasNodeArchiveStoryImmediateSaver WorkerEnv where
+  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
+
+instance MonadLogger (GargM WorkerEnv IOException) where
+  getLogger = asks _w_env_logger
+
+
+---------
+instance HasValidationError IOException where
+  _ValidationError = prism' mkIOException (const Nothing)
+    where
+      mkIOException v = IOError { ioe_handle = Nothing
+                                , ioe_type = OtherError
+                                , ioe_location = "Worker job (validation)"
+                                , ioe_description = show v
+                                , ioe_errno = Nothing
+                                , ioe_filename = Nothing }
+
+instance HasTreeError IOException where
+  _TreeError = prism' mkIOException (const Nothing)
+    where
+      mkIOException v = IOError { ioe_handle = Nothing
+                                , ioe_type = OtherError
+                                , ioe_location = "Worker job (tree)"
+                                , ioe_description = show v
+                                , ioe_errno = Nothing
+                                , ioe_filename = Nothing }
+
+instance HasNodeError IOException where
+  _NodeError = prism' (Prelude.userError . show) (const Nothing)
+
 ---------------
 
 newtype WorkerMonad a =
@@ -122,8 +164,6 @@ newtype WorkerMonad a =
            , MonadBaseControl IO
            , MonadError IOException
            , MonadFail )
-instance HasNodeError IOException where
-  _NodeError = prism' (Prelude.userError . show) (const Nothing)
 
 runWorkerMonad :: WorkerEnv -> WorkerMonad a -> IO a
 runWorkerMonad env m = do
@@ -131,3 +171,25 @@ runWorkerMonad env m = do
   case res of
     Left e -> throwIO e
     Right x -> pure x
+
+
+
+data WorkerJobHandle = WorkerNoJobHandle
+
+instance MonadJobStatus WorkerMonad where
+  -- type JobHandle      WorkerMonad = WorkerJobHandle
+  type JobHandle      WorkerMonad = ConcreteJobHandle IOException
+  type JobType        WorkerMonad = GargJob
+  type JobOutputType  WorkerMonad = JobLog
+  type JobEventType   WorkerMonad = JobLog
+
+  -- noJobHandle _         = WorkerNoJobHandle
+  noJobHandle _         = noJobHandle (Proxy :: Proxy (GargM Env IOException))  -- ConcreteNullHandle
+  getLatestJobStatus _  = WorkerMonad (pure noJobLog)
+  withTracer _ jh n     = n jh
+  markStarted _ _       = WorkerMonad $ pure ()
+  markProgress _ _      = WorkerMonad $ pure ()
+  markFailure _ _ _     = WorkerMonad $ pure ()
+  markComplete _        = WorkerMonad $ pure ()
+  markFailed _ _        = WorkerMonad $ pure ()
+  addMoreSteps _ _      = WorkerMonad $ pure ()

test/Test/Instances.hs

@@ -2,6 +2,7 @@ module Test.Instances where
 
 import Gargantext.API.Admin.EnvTypes as EnvTypes
 import Gargantext.API.Admin.Auth.Types (ForgotPasswordAsyncParams(..))
+import Gargantext.API.Node.Corpus.New qualified as New
 import Gargantext.Core.Worker.Jobs.Types (Job(..))
 import Gargantext.Prelude
 import Text.Parsec.Error (ParseError, Message(..), newErrorMessage)
@@ -78,3 +79,7 @@ instance Arbitrary ParseError where
     sp <- arbitrary
     msg <- arbitrary
     return $ newErrorMessage msg sp
+
+
+instance Arbitrary New.ApiInfo where
+  arbitrary = New.ApiInfo <$> arbitrary