WIP

src/Gargantext/API/Admin/EnvTypes.hs

@@ -80,7 +80,7 @@ modeToLoggingLevels = \case
 data Env = Env
   { _env_logger           :: ~(Logger (GargM Env BackendInternalError))
   , _env_pool             :: ~(Pool Connection)
-  , _env_nodeStory        :: ~NodeStoryEnv
+  , _env_nodeStory        :: ~(NodeStoryEnv BackendInternalError)
   , _env_manager          :: ~Manager
   , _env_config           :: ~GargConfig
   , _env_dispatcher       :: ~Dispatcher
@@ -96,15 +96,9 @@ instance HasConfig Env where
 instance HasConnectionPool Env where
   connPool = env_pool
 
-instance HasNodeStoryEnv Env where
+instance HasNodeStoryEnv Env BackendInternalError where
   hasNodeStory = env_nodeStory
 
-instance HasNodeStoryImmediateSaver Env where
-  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
-
-instance HasNodeArchiveStoryImmediateSaver Env where
-  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
-
 instance HasJWTSettings Env where
   jwtSettings = env_jwt_settings
 
@@ -152,7 +146,7 @@ data DevEnv = DevEnv
   , _dev_env_manager   :: ~Manager
   , _dev_env_logger    :: !(Logger (GargM DevEnv BackendInternalError))
   , _dev_env_pool      :: !(Pool Connection)
-  , _dev_env_nodeStory :: !NodeStoryEnv
+  , _dev_env_nodeStory :: !(NodeStoryEnv BackendInternalError)
   }
 
 makeLenses ''DevEnv
@@ -198,15 +192,9 @@ instance HasConnectionPool DevEnv where
   connPool = dev_env_pool
 
 
-instance HasNodeStoryEnv DevEnv where
+instance HasNodeStoryEnv DevEnv BackendInternalError where
   hasNodeStory = dev_env_nodeStory
 
-instance HasNodeStoryImmediateSaver DevEnv where
-  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
-
-instance HasNodeArchiveStoryImmediateSaver DevEnv where
-  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
-
 instance HasMail DevEnv where
   mailSettings = dev_env_config . gc_mail_config
 

src/Gargantext/API/GraphQL/Annuaire.hs

@@ -23,7 +23,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
   , cw_lastName
   , hc_who, ContactWhere, hc_where, cw_organization, cw_labTeamDepts, cw_role, cw_office, cw_country, cw_city, cw_touch, ct_mail, ct_phone, ct_url, hc_title, hc_source)
 import Gargantext.Database.Admin.Types.Node (ContextId (..))
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Context (getContextWith)
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
@@ -71,7 +71,7 @@ dbAnnuaireContacts contact_id = do
 
   -- FIXME(adinapoli) This function seems a bit iffy, unless a 'contact_id'
   -- is just a synonym for a 'ContextId'.
-  c <- lift $ getContextWith (UnsafeMkContextId contact_id) (Proxy :: Proxy HyperdataContact)
+  c <- lift $ runDBQuery $ getContextWith (UnsafeMkContextId contact_id) (Proxy :: Proxy HyperdataContact)
   pure [toAnnuaireContact (contact_id, c ^. node_hyperdata)]
 
 toAnnuaireContact :: (Int, HyperdataContact) -> AnnuaireContact

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

@@ -39,7 +39,7 @@ import Gargantext.API.Node.Types
 import Gargantext.Core (withDefaultLanguage, defaultLanguage)
 import Gargantext.Core.Config (gc_jobs, hasConfig)
 import Gargantext.Core.Config.Types (jc_max_docs_parsers)
-import Gargantext.Core.NodeStory (currentVersion, NgramsStatePatch', HasNodeStoryEnv)
+import Gargantext.Core.NodeStory (currentVersion, NgramsStatePatch', HasNodeStoryEnv (..))
 import Gargantext.Core.Text.Corpus.Parsers qualified as Parser (FileType(..), parseFormatC, _ParseFormatError)
 import Gargantext.Core.Text.Corpus.Parsers.Types
 import Gargantext.Core.Text.Corpus.Query qualified as API
@@ -54,9 +54,8 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(
 import Gargantext.Database.Admin.Types.Hyperdata.File ( HyperdataFile(..) )
 import Gargantext.Database.Admin.Types.Node (CorpusId, NodeType(..), ParentId)
 import Gargantext.Database.GargDB qualified as GargDB
-import Gargantext.Database.Prelude (readLargeObject, IsDBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNodeWith, getOrMkList)
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusIds))
 import Gargantext.Database.Schema.Node (node_hyperdata)
@@ -64,6 +63,7 @@ import Gargantext.Prelude
 import Gargantext.System.Logging ( logLocM, LogLevel(..) )
 import Gargantext.Utils.Jobs.Error (HumanFriendlyErrorText(..))
 import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 
 ------------------------------------------------------------------------
 {-
@@ -327,6 +327,7 @@ addToCorpusWithFile cid input filetype logStatus = do
                           }
 -}
 
+-- NOTE(adn) Not DB-transactional!!
 addToCorpusWithFile :: (FlowCmdM env err m, MonadJobStatus m)
                     => User
                     -> CorpusId
@@ -335,7 +336,7 @@ addToCorpusWithFile :: (FlowCmdM env err m, MonadJobStatus m)
                     -> m ()
 addToCorpusWithFile user cid nwf@(NewWithFile _d (withDefaultLanguage -> l) fName) jobHandle = do
 
-  addLanguageToCorpus cid l
+  runDBTx $ addLanguageToCorpus cid l
 
   $(logLocM) DEBUG $ "[addToCorpusWithFile] Uploading file to corpus: " <> show cid
   markStarted 1 jobHandle
@@ -343,14 +344,18 @@ addToCorpusWithFile user cid nwf@(NewWithFile _d (withDefaultLanguage -> l) fNam
   fPath <- GargDB.writeFile nwf
   $(logLocM) DEBUG $ "[addToCorpusWithFile] File saved as: " <> show fPath
 
+  cfg <- view hasConfig
+
+  nIds <- runDBTx $ do
     uId <- getUserId user
-  nIds <- mkNodeWithParent NodeFile (Just cid) uId fName
+    mkNodeWithParent cfg NodeFile (Just cid) uId fName
 
   _ <- case nIds of
     [nId] -> do
+        runDBTx $ do
           node <- getNodeWith nId (Proxy :: Proxy HyperdataFile)
           let hl = node ^. node_hyperdata
-        _ <- updateHyperdata nId $ hl { _hff_name = fName
+          void $ updateHyperdata nId $ hl { _hff_name = fName
                                           , _hff_path = T.pack fPath }
 
         $(logLocM) DEBUG $ "[addToCorpusWithFile] Created node with id: " <> show nId
@@ -367,13 +372,15 @@ addToCorpusWithFile user cid nwf@(NewWithFile _d (withDefaultLanguage -> l) fNam
 
 --- UTILITIES
 
-commitCorpus :: ( IsDBCmd env err m
+commitCorpus :: ( IsDBCmd env err m, HasNodeStoryEnv env err, HasNodeError err
                 )
              => ParentId
              -> User
              -> m (Versioned NgramsStatePatch')
 commitCorpus cid user = do
+  env <- view hasNodeStory
+  runDBTx $ do
     userId <- getUserId user
     listId <- getOrMkList cid userId
     v <- currentVersion listId
-  commitStatePatch listId (Versioned v mempty)
+    commitStatePatch env listId (Versioned v mempty)

src/Gargantext/API/Node/Share.hs

@@ -19,17 +19,20 @@ import Data.Text qualified as Text
 import Gargantext.API.Node.Share.Types (ShareNodeParams(..))
 import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.API.Routes.Named.Share qualified as Named
+import Gargantext.Core.Notifications.CentralExchange.Types (CEMessage)
 import Gargantext.Core.Types.Individu (User(..), arbitraryUsername)
 import Gargantext.Database.Action.Share (ShareNodeWith(..))
 import Gargantext.Database.Action.Share as DB (shareNodeWith, unshare)
 import Gargantext.Database.Action.User (getUserId', getUsername)
 import Gargantext.Database.Action.User.New (guessUserName, newUser)
 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType(..), UserId(..))
+import Gargantext.Database.Prelude
 import Gargantext.Database.Prelude (IsDBCmdExtra)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Tree (findNodesWithType)
 import Gargantext.Prelude
 import Servant.Server.Generic (AsServerT)
+import qualified Gargantext.Core.Notifications.CentralExchange.Types as CE
 
 ------------------------------------------------------------------------
 -- TODO permission
@@ -72,19 +75,19 @@ api userInviting nId (ShareTeamParams user') = do
             pure ()
           pure u
 
-  fromIntegral <$> shareNodeAndNotify (ShareNodeWith_User NodeFolderShared (UserName user)) nId
+  fromIntegral <$> shareNodeAndNotify (shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId)
 api _uId nId2 (SharePublicParams nId1) =
 
-  fromIntegral <$> shareNodeAndNotify (ShareNodeWith_Node NodeFolderPublic nId1) nId2
+  fromIntegral <$> shareNodeAndNotify (shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId1) nId2)
 
 shareNodeAndNotify :: ( HasNodeError     err
                       , IsDBCmdExtra env err m
                       , MonadRandom          m
                       )
-                      -> DBUpdate err (Int, [CEMessage])
+                   => DBUpdate err (Int, [CEMessage])
                    -> m Int
 shareNodeAndNotify dbTx = do
-  (res, msgs) <- runDbTx dbTx
+  (res, msgs) <- runDBTx dbTx
   forM_ msgs CE.ce_notify
   pure res
 

src/Gargantext/Core/NodeStory.hs

@@ -50,7 +50,7 @@ module Gargantext.Core.NodeStory
   , Archive(..)
   , nodeExists
   , getNodesIdWithType
-  , fromDBNodeStoryEnv
+  , mkNodeStoryEnv
   , upsertNodeStories
   -- , getNodeStory
   , getNodeStory'
@@ -278,8 +278,8 @@ getParentsChildren ns = (nsParents, nsChildren)
 
 ------------------------------------
 
-fromDBNodeStoryEnv :: IO (NodeStoryEnv err)
-fromDBNodeStoryEnv = do
+mkNodeStoryEnv :: NodeStoryEnv err
+mkNodeStoryEnv = do
   -- tvar <- nodeStoryVar pool Nothing []
   let saver_immediate nId a = do
         -- ns <- atomically $
@@ -309,11 +309,10 @@ fromDBNodeStoryEnv = do
         --       ) $ Map.toList nls
         -- pure $ clearHistory ns
 
-  pure $ NodeStoryEnv { _nse_saver = saver_immediate
+  NodeStoryEnv { _nse_saver = saver_immediate
                , _nse_archive_saver = archive_saver_immediate
                , _nse_getter = getNodeStory'
-                      , _nse_getter_multi = \nIds ->
-                          foldM nodeStoryInc (NodeStory Map.empty) nIds
+               , _nse_getter_multi = \nIds -> foldM nodeStoryInc (NodeStory Map.empty) nIds
                }
 
 currentVersion :: ListId -> DBQuery err x Version

src/Gargantext/Core/Worker/Env.hs

@@ -37,7 +37,7 @@ import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Core.Mail.Types (HasMail(..))
 import Gargantext.Core.NLP (HasNLPServer(..), NLPServerMap, nlpServerMap)
-import Gargantext.Core.NodeStory (HasNodeStoryEnv(..), HasNodeStoryImmediateSaver(..), HasNodeArchiveStoryImmediateSaver(..), NodeStoryEnv, fromDBNodeStoryEnv, nse_saver_immediate, nse_archive_saver_immediate)
+import Gargantext.Core.NodeStory (HasNodeStoryEnv(..), NodeStoryEnv, mkNodeStoryEnv)
 import Gargantext.Core.Types (HasValidationError(..))
 import Gargantext.Core.Worker.Types (JobInfo(..))
 import Gargantext.Database.Prelude (HasConnectionPool(..))
@@ -52,12 +52,12 @@ import System.Log.FastLogger qualified as FL
 import Gargantext.System.Logging.Loggers
 
 
-data WorkerEnv = WorkerEnv
+data WorkerEnv err = WorkerEnv
   { _w_env_config    :: ~GargConfig
-  , _w_env_logger    :: ~(Logger (GargM WorkerEnv IOException))
+  , _w_env_logger    :: ~(Logger (GargM (WorkerEnv err) IOException))
   -- the pool is a pool for gargantext db, not pgmq db!
   , _w_env_pool      :: ~(Pool.Pool PSQL.Connection)
-  , _w_env_nodeStory :: ~NodeStoryEnv
+  , _w_env_nodeStory :: ~(NodeStoryEnv err)
   , _w_env_mail      :: ~Mail.MailConfig
   , _w_env_nlp       :: ~NLPServerMap
   , _w_env_job_state :: ~(TVar (Maybe WorkerJobState))
@@ -69,7 +69,7 @@ data WorkerJobState = WorkerJobState
   deriving (Show, Eq)
 
 
-withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
+withWorkerEnv :: SettingsFile -> (WorkerEnv err -> IO a) -> IO a
 withWorkerEnv settingsFile k = do
   cfg <- readConfig settingsFile
   withLoggerIO (cfg ^. gc_logging) $ \logger -> do
@@ -82,53 +82,47 @@ withWorkerEnv settingsFile k = do
       -- pool    <- newPool            $ _gc_database_config cfg
       let dbConfig = _gc_database_config cfg
       pool <- Pool.newPool $ Pool.setNumStripes (Just 1) $ Pool.defaultPoolConfig (PSQL.connect dbConfig) PSQL.close 60 4
-      nodeStory_env <- fromDBNodeStoryEnv pool
       _w_env_job_state <- newTVarIO Nothing
       pure $ WorkerEnv
-        { _w_env_pool      = pool
+        { -- NOTE(adn) I think with the DbTX now we don't need a pool in the env. Remove?
+          _w_env_pool      = pool
         , _w_env_logger    = logger
-        , _w_env_nodeStory = nodeStory_env
+        , _w_env_nodeStory = mkNodeStoryEnv
         , _w_env_config    = cfg
         , _w_env_mail      = _gc_mail_config cfg
         , _w_env_nlp       = nlpServerMap $ _gc_nlp_config cfg
         , _w_env_job_state
         }
 
-instance HasConfig WorkerEnv where
+instance HasConfig (WorkerEnv err) where
   hasConfig = to _w_env_config
 
-instance HasLogger (GargM WorkerEnv IOException) where
-  newtype instance Logger (GargM WorkerEnv IOException)  =
+instance HasLogger (GargM (WorkerEnv err) IOException) where
+  newtype instance Logger (GargM (WorkerEnv err) IOException)  =
     GargWorkerLogger { _GargWorkerLogger :: MonadicStdLogger FL.LogStr IO }
-  type instance LogInitParams (GargM WorkerEnv IOException) = LogConfig
-  type instance LogPayload (GargM WorkerEnv IOException)    = FL.LogStr
+  type instance LogInitParams (GargM (WorkerEnv err) IOException) = LogConfig
+  type instance LogPayload (GargM (WorkerEnv err) IOException)    = FL.LogStr
   initLogger cfg = fmap GargWorkerLogger $ (liftIO $ monadicStdLogger cfg)
   destroyLogger = liftIO . _msl_destroy . _GargWorkerLogger
   logMsg (GargWorkerLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
   logTxt (GargWorkerLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
 
-instance HasConnectionPool WorkerEnv where
+instance HasConnectionPool (WorkerEnv err) where
   connPool = to _w_env_pool
 
-instance HasMail WorkerEnv where
+instance HasMail (WorkerEnv err) where
   mailSettings = to _w_env_mail
 
-instance HasNLPServer WorkerEnv where
+instance HasNLPServer (WorkerEnv err) where
   nlpServer = to _w_env_nlp
 
-instance HasNodeStoryEnv WorkerEnv where
+instance HasNodeStoryEnv (WorkerEnv err) err 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
+instance MonadLogger (GargM (WorkerEnv err) IOException) where
   getLogger = asks _w_env_logger
 
-instance CET.HasCentralExchangeNotification WorkerEnv where
+instance CET.HasCentralExchangeNotification (WorkerEnv err) where
   ce_notify m = do
     c <- asks (view $ to _w_env_config)
     liftBase $ do
@@ -162,13 +156,13 @@ instance HasNodeError IOException where
 
 ---------------
 
-newtype WorkerMonad a =
-  WorkerMonad { _WorkerMonad :: GargM WorkerEnv IOException a }
+newtype WorkerMonad err a =
+  WorkerMonad { _WorkerMonad :: GargM (WorkerEnv err) IOException a }
   deriving ( Functor
            , Applicative
            , Monad
            , MonadIO
-           , MonadReader WorkerEnv
+           , MonadReader (WorkerEnv err)
            , MonadBase IO
            , MonadBaseControl IO
            , MonadError IOException
@@ -177,23 +171,23 @@ newtype WorkerMonad a =
            , CES.MonadCatch
            , CES.MonadMask )
 
-instance HasLogger WorkerMonad where
-  newtype instance Logger WorkerMonad =
+instance HasLogger (WorkerMonad err) where
+  newtype instance Logger (WorkerMonad err) =
     WorkerMonadLogger { _WorkerMonadLogger :: MonadicStdLogger FL.LogStr IO }
-  type instance LogInitParams WorkerMonad = LogConfig
-  type instance LogPayload WorkerMonad    = FL.LogStr
+  type instance LogInitParams (WorkerMonad err) = LogConfig
+  type instance LogPayload (WorkerMonad err)  = FL.LogStr
   initLogger cfg = fmap WorkerMonadLogger $ (liftIO $ monadicStdLogger cfg)
   destroyLogger = liftIO . _msl_destroy . _WorkerMonadLogger
   logMsg (WorkerMonadLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
   logTxt (WorkerMonadLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
 
-instance MonadLogger WorkerMonad where
+instance MonadLogger (WorkerMonad err) where
   getLogger = do
     env <- ask
     let (GargWorkerLogger lgr) = _w_env_logger env
     pure $ WorkerMonadLogger lgr
 
-runWorkerMonad :: WorkerEnv -> WorkerMonad a -> IO a
+runWorkerMonad :: WorkerEnv err -> WorkerMonad err a -> IO a
 runWorkerMonad env m = do
   res <- runExceptT . flip runReaderT env $ _WorkerMonad m
   case res of
@@ -210,10 +204,10 @@ data WorkerJobHandle =
 
 -- | Worker handles 1 job at a time, hence it's enough to provide
 -- simple progress tracking
-instance MonadJobStatus WorkerMonad where
-  type JobHandle      WorkerMonad = WorkerJobHandle
-  type JobOutputType  WorkerMonad = JobLog
-  type JobEventType   WorkerMonad = JobLog
+instance MonadJobStatus (WorkerMonad err) where
+  type JobHandle      (WorkerMonad err) = WorkerJobHandle
+  type JobOutputType  (WorkerMonad err) = JobLog
+  type JobEventType   (WorkerMonad err) = JobLog
 
   noJobHandle Proxy     = WorkerNoJobHandle
   getLatestJobStatus _  = WorkerMonad (pure noJobLog)
@@ -233,7 +227,7 @@ instance MonadJobStatus WorkerMonad where
   addMoreSteps steps jh  = updateJobProgress jh (jobLogAddMore steps)
 
 
-updateJobProgress :: WorkerJobHandle -> (JobLog -> JobLog) -> WorkerMonad ()
+updateJobProgress :: WorkerJobHandle -> (JobLog -> JobLog) -> WorkerMonad err ()
 updateJobProgress WorkerNoJobHandle _ = pure ()
 updateJobProgress (WorkerJobHandle (ji@JobInfo { _ji_message_id })) f = do
   stateTVar <- asks _w_env_job_state