[ngrams] fix for json/csv upload for older terms

Also, some test refactoring and add servant-client to tests.

.envrc

 use_nix
+#use_flake
 export LANG=C.UTF-8

cabal.project

@@ -121,7 +121,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
-    tag: cd179f6dda15d77a085c0176284c921b7bc50c46
+    tag: ceb8f2cebd4890b6d9d151ab01ee14e925bc0499
 
 source-repository-package
     type: git

gargantext.cabal

@@ -840,7 +840,9 @@ test-suite garg-test-tasty
   type: exitcode-stdio-1.0
   main-is: drivers/tasty/Main.hs
   other-modules:
+      Test.API.Routes
       Test.API.Setup
+      Test.Core.Similarity
       Test.Core.Text
       Test.Core.Text.Corpus.Query
       Test.Core.Text.Examples
@@ -868,6 +870,7 @@ test-suite garg-test-tasty
       Test.Parsers.Date
       Test.Parsers.Types
       Test.Parsers.WOS
+      Test.Types
       Test.Utils
       Test.Utils.Crypto
       Test.Utils.Jobs
@@ -920,6 +923,7 @@ test-suite garg-test-tasty
     , servant-auth
     , servant-auth-client
     , servant-client
+    , servant-client-core
     , servant-job
     , servant-server
     , shelly >= 1.9 && < 2
@@ -952,6 +956,7 @@ test-suite garg-test-hspec
       Test.API.Errors
       Test.API.GraphQL
       Test.API.Private
+      Test.API.Routes
       Test.API.Setup
       Test.API.UpdateList
       Test.Database.Operations
@@ -960,6 +965,7 @@ test-suite garg-test-hspec
       Test.Database.Setup
       Test.Database.Types
       Test.Utils
+      Test.Types
       Paths_gargantext
   hs-source-dirs:
       test
@@ -1007,6 +1013,7 @@ test-suite garg-test-hspec
     , servant-auth
     , servant-auth-client
     , servant-client
+    , servant-client-core
     , servant-job
     , servant-server
     , shelly >= 1.9 && < 2

src/Gargantext/API/Dev.hs

@@ -12,20 +12,23 @@ Portability : POSIX
 -- Use only for dev/repl
 module Gargantext.API.Dev where
 
+import Control.Lens (view)
 import Control.Monad (fail)
-import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Admin.Settings
-import Gargantext.API.Errors.Types
-import Gargantext.API.Prelude
+import Data.Pool (withResource)
+import Database.PostgreSQL.Simple qualified as PGS
+import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
+import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool )
+import Gargantext.API.Errors.Types ( BackendInternalError )
+import Gargantext.API.Prelude ( GargM )
 import Gargantext.Core.NLP (nlpServerMap)
-import Gargantext.Core.NodeStory
-import Gargantext.Database.Prelude (Cmd', Cmd'', databaseParameters, runCmd)
+import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
+import Gargantext.Database.Prelude (Cmd', Cmd'', connPool, databaseParameters, runCmd)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (readConfig)
 import Gargantext.Prelude.Mail qualified as Mail
 import Gargantext.Prelude.NLP qualified as NLP
-import Gargantext.System.Logging
-import Servant
+import Gargantext.System.Logging ( withLoggerHoisted )
+import Servant ( ServerError )
 
 type IniPath  = FilePath
 -------------------------------------------------------------------
@@ -67,7 +70,7 @@ runCmdReplServantErr = runCmdRepl
 -- using HasConnectionPool and HasRepoVar.
 runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
 runCmdDev env f =
-  (either (fail . show) pure =<< runCmd env f)
+  either (fail . show) pure =<< runCmd env f
 
 runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
 runCmdGargDev env cmd =
@@ -81,3 +84,9 @@ runCmdDevServantErr = runCmdDev
 
 runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a
 runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
+
+-- | Execute a function that takes PSQL.Connection from the DB pool as
+--   first parameter.
+--   e.g.: runCmdReplEasyDB $ \c -> getNodeStory' c
+runCmdReplEasyDB :: (PGS.Connection -> IO a) -> IO a
+runCmdReplEasyDB f = runCmdReplEasy $ view connPool >>= (\p -> liftBase $ withResource p f)

src/Gargantext/API/Ngrams.hs

@@ -25,13 +25,14 @@ add get
 
 {-# LANGUAGE IncoherentInstances #-}
 
+
 module Gargantext.API.Ngrams
   ( TableNgramsApi
   , TableNgramsApiGet
   , TableNgramsApiPut
 
   , commitStatePatch
-  
+
   , searchTableNgrams
   , getTableNgrams
   , getTableNgramsCorpus
@@ -86,38 +87,35 @@ module Gargantext.API.Ngrams
   )
   where
 
-import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, ifolded, to, withIndex, over)
-import Control.Monad.Reader
+import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex, over)
 import Data.Aeson.Text qualified as DAT
-import Data.Foldable
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
-import Data.Monoid
 import Data.Patch.Class (Action(act), Transformable(..), ours)
 import Data.Set qualified as Set
 import Data.Text (isInfixOf, toLower, unpack)
-import Data.Text.Lazy.IO as DTL
+import Data.Text.Lazy.IO as DTL ( writeFile )
 import Formatting (hprint, int, (%))
 import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
-import Gargantext.API.Errors.Types
+import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Metrics qualified as Metrics
 import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.API.Ngrams.Types
-import Gargantext.API.Prelude
+import Gargantext.API.Prelude ( GargM )
 import Gargantext.Core.NodeStory (ArchiveList, HasNodeStory, HasNodeArchiveStoryImmediateSaver(..), HasNodeStoryImmediateSaver(..), NgramsStatePatch', a_history, a_state, a_version, currentVersion)
 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, TODO, assertValid, HasValidationError, ContextId)
 import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
 import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Types.Node (NodeType(..))
-import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngramsType, ngrams_terms)
-import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
+import Gargantext.Database.Query.Table.Ngrams ( text2ngrams, Ngrams, insertNgrams, selectNgramsByDoc )
+import Gargantext.Database.Schema.Ngrams qualified as TableNgrams
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
-import Gargantext.Database.Query.Table.Node.Select
+import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
 import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
 import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
 import Gargantext.Prelude.Clock (hasTime, getTime)
@@ -321,7 +319,7 @@ commitStatePatch listId (Versioned _p_version p) = do
   --      )
 
   let newA = Versioned (a' ^. a_version) q'
-  
+
   -- NOTE Now is the only good time to save the archive history. We
   -- have the handle to the MVar and we need to save its exact
   -- snapshot. Node Story archive is a linear table, so it's only
@@ -370,7 +368,7 @@ tableNgramsPull listId ngramsType p_version = do
   let
     -- a = r ^. unNodeStory . at listId . non initArchive
     q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
-    q_table = q ^. _PatchMap . at ngramsType . _Just
+    q_table = q ^. _PatchMap . ix ngramsType
 
   pure (Versioned (a ^. a_version) q_table)
 
@@ -404,7 +402,7 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
       assertValid p_validity
 
       ret <- commitStatePatch listId (Versioned p_version p)
-        <&> v_data %~ (view (_PatchMap . at ngramsType . _Just))
+        <&> v_data %~ view (_PatchMap . ix ngramsType)
 
       pure ret
 
@@ -474,7 +472,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
 -}
               markComplete jobHandle
-            _ -> do
+            _otherTabType -> do
               -- printDebug "[tableNgramsPostChartsAsync] no update for tabType = " tabType
               markStarted 1 jobHandle
               markFailed Nothing jobHandle
@@ -494,7 +492,7 @@ getNgramsTableMap :: HasNodeStory env err m
 getNgramsTableMap nodeId ngramsType = do
   a <- getNodeStory nodeId
   pure $ Versioned (a ^. a_version)
-                   (a ^. a_state . at ngramsType . _Just)
+                   (a ^. a_state . ix ngramsType)
 
 
 dumpJsonTableMap :: HasNodeStory env err m
@@ -551,8 +549,8 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
     matchingNode inputNode =
       let nodeSize        = inputNode ^. ne_size
           matchesListType = maybe (const True) (==) _nsq_listType
-          respectsMinSize = maybe (const True) (<=) (getMinSize <$> _nsq_minSize)
-          respectsMaxSize = maybe (const True) (>=) (getMaxSize <$> _nsq_maxSize)
+          respectsMinSize = maybe (const True) ((<=) . getMinSize) _nsq_minSize
+          respectsMaxSize = maybe (const True) ((>=) . getMaxSize) _nsq_maxSize
 
       in    respectsMinSize nodeSize
          && respectsMaxSize nodeSize
@@ -623,7 +621,7 @@ getNgramsTable' :: forall env err m.
                 -> m (Versioned (Map.Map NgramsTerm NgramsElement))
 getNgramsTable' nId listId ngramsType = do
   tableMap <- getNgramsTableMap listId ngramsType
-  tableMap & v_data %%~ (setNgramsTableScores nId listId ngramsType)
+  tableMap & v_data %%~ setNgramsTableScores nId listId ngramsType
                         . Map.mapWithKey ngramsElementFromRepo
 
 -- | Helper function to set scores on an `NgramsTable`.
@@ -648,7 +646,7 @@ setNgramsTableScores nId listId ngramsType table = do
       ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
       (length ngrams_terms) t1 t2
   let
-    setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (at (ne ^. ne_ngrams) . _Just) occurrences)
+    setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (ix (ne ^. ne_ngrams)) occurrences)
 
   --printDebug "[setNgramsTableScores] with occurences" $ table & each %~ setOcc
 
@@ -734,7 +732,7 @@ getTableNgramsCorpus :: ( HasNodeStory env err m
 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
   getTableNgrams nId listId tabType searchQuery
     where
-      searchQueryFn (NgramsTerm nt) = maybe (const True) isInfixOf (toLower <$> mt) (toLower nt)
+      searchQueryFn (NgramsTerm nt) = maybe (const True) (isInfixOf . toLower) mt (toLower nt)
       searchQuery = NgramsSearchQuery {
                     _nsq_limit       = limit_
                   , _nsq_offset      = offset
@@ -778,7 +776,7 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
   ns <- selectNodesWithUsername NodeList userMaster
   let ngramsType = ngramsTypeFromTabType tabType
   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
-  let searchQueryFn (NgramsTerm nt) = flip Set.member (Set.fromList ngs) nt
+  let searchQueryFn (NgramsTerm nt) = Set.member nt (Set.fromList ngs)
       searchQuery = NgramsSearchQuery {
                     _nsq_limit       = limit_
                   , _nsq_offset      = offset
@@ -828,4 +826,4 @@ listNgramsChangedSince listId ngramsType version
   | version < 0 =
       Versioned <$> currentVersion listId <*> pure True
   | otherwise   =
-      tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
+      tableNgramsPull listId ngramsType version <&> v_data %~ (== mempty)

src/Gargantext/API/Ngrams/List.hs

@@ -152,7 +152,7 @@ postAsyncJSON l ngramsList jobHandle = do
     setList :: HasNodeStory env err m => m ()
     setList = do
       -- TODO check with Version for optim
-      mapM_ (\(nt, Versioned _v ns) -> (setListNgrams l nt ns)) $ toList ngramsList
+      mapM_ (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList ngramsList
       -- TODO reindex
 
 

src/Gargantext/API/Ngrams/Tools.hs

@@ -11,22 +11,23 @@ Portability : POSIX
 
 {-# LANGUAGE TypeFamilies  #-}
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use infix" #-}
 
 module Gargantext.API.Ngrams.Tools
   where
 
 -- import Gargantext.Core.NodeStoryFile qualified as NSF
-import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
-import Control.Monad.Reader
+import Control.Lens (_Just, (^.), at, ix, view, At, Index, IxValue)
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
-import Data.Validity
 -- import GHC.Conc (TVar, readTVar)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory
-import Gargantext.Core.Types (ListType(..), NodeId, ListId)
+import Gargantext.Core.Types.Main ( ListType(..) )
+import Gargantext.Database.Admin.Types.Node ( NodeId, ListId )
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
 
@@ -93,7 +94,7 @@ listNgramsFromRepo nodeIds ngramsType repo =
                ^. unNodeStory
                 . at nodeId . _Just
                 . a_state
-                . at ngramsType . _Just
+                . ix ngramsType
                 | nodeId <- nodeIds
                 ]
 
@@ -153,7 +154,7 @@ filterListWithRoot :: [ListType]
 filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
   where
     isMapTerm (l, maybeRoot) = case maybeRoot of
-      Nothing -> elem l lt
+      Nothing -> l `elem` lt
       Just  r -> case HM.lookup r m of
         Nothing -> panicTrace $ "[Garg.API.Ngrams.Tools] filterListWithRoot, unknown key: " <> unNgramsTerm r
         Just  (l',_) -> elem l' lt
@@ -175,7 +176,7 @@ groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
         Nothing  -> (t, ns)
         Just  r' -> (r',ns)
 
-data Diagonal = Diagonal Bool
+newtype Diagonal = Diagonal Bool
 
 getCoocByNgrams :: Diagonal
                 -> HashMap NgramsTerm (Set NodeId)

src/Gargantext/API/Ngrams/Types.hs

@@ -25,9 +25,10 @@ import Data.Aeson.TH (deriveJSON)
 import Data.Csv (defaultEncodeOptions, encodeByNameWith, header, namedRecord, EncodeOptions(..), NamedRecord, Quoting(QuoteNone))
 import Data.Csv qualified as Csv
 import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
+import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
-import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
+import Data.Patch.Class (Replace(Keep), replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
 import Data.Set qualified as Set
 import Data.String (IsString(..))
 import Data.Swagger ( NamedSchema(NamedSchema), declareSchemaRef, genericDeclareNamedSchema, SwaggerType(SwaggerObject), ToParamSchema, ToSchema(..), HasProperties(properties), HasRequired(required), HasType(type_) )
@@ -848,3 +849,13 @@ instance Arbitrary NgramsRepoElement where
   arbitrary = elements $ map ngramsElementToRepo ns
     where
       NgramsTable ns = mockTable
+
+
+toNgramsPatch :: [NgramsTerm] -> NgramsPatch
+toNgramsPatch children = NgramsPatch children' Keep
+  where
+    children' :: PatchMSet NgramsTerm
+    children' = PatchMSet
+              $ fst
+              $ PM.fromList
+              $ List.zip children (List.cycle [addPatch])

src/Gargantext/API/Node.hs

@@ -134,7 +134,7 @@ type NodeAPI a = PolicyChecked (NodeNodeAPI a)
 
              :<|> "category"   :> CatApi
              :<|> "score"      :> ScoreApi
-             :<|> "search"     :> (Search.API Search.SearchResult)
+             :<|> "search"     :> Search.API Search.SearchResult
              :<|> "share"      :> Share.API
 
              -- Pairing utilities

src/Gargantext/API/Node/Contact.hs

@@ -12,9 +12,7 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-# LANGUAGE ConstraintKinds      #-}
-{-# LANGUAGE KindSignatures       #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
-{-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 
@@ -22,35 +20,34 @@ Portability : POSIX
 module Gargantext.API.Node.Contact
       where
 
-import Conduit
+import Conduit ( yield )
 import Data.Aeson
 import Data.Either (Either(Right))
 import Data.Maybe (Maybe(..))
-import Data.Swagger
+import Data.Swagger ( ToSchema )
 import Data.Text (Text)
 import GHC.Generics (Generic)
-import Servant
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary
-
-import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(AuthenticatedUser) )
 import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
-import Gargantext.API.Errors.Types
-import Gargantext.API.Node
+import Gargantext.API.Errors.Types ( BackendInternalError )
+import Gargantext.API.Node ( nodeNodeAPI, NodeNodeAPI )
 import Gargantext.API.Prelude (GargM, simuLogs)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text.Terms (TermType(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Action.Flow (flow)
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
-import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAnnuaire(..), HyperdataContact)
-import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact)
-import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact, hyperdataContact )
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire(..) )
+import Gargantext.Database.Admin.Types.Node ( CorpusId, NodeId )
 import Gargantext.Prelude (($), {-printDebug,-})
+import Gargantext.Utils.Aeson qualified as GUA
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
-import qualified Gargantext.Utils.Aeson as GUA
+import Servant
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary) )
 
 ------------------------------------------------------------------------
 type API = "contact" :> Summary "Contact endpoint"

src/Gargantext/API/Node/FrameCalcUpload.hs

@@ -16,36 +16,36 @@ Portability : POSIX
 module Gargantext.API.Node.FrameCalcUpload where
 
 import Control.Lens ((^.))
-import Data.Aeson
+import Data.Aeson ( FromJSON, ToJSON )
 import Data.ByteString.Lazy qualified as BSL
 import Data.ByteString.UTF8 qualified as BSU8
-import Data.Swagger
+import Data.Swagger ( ToSchema )
 import Data.Text qualified as T
-import Network.HTTP.Client (newManager, httpLbs, parseRequest, responseBody)
-import Network.HTTP.Client.TLS (tlsManagerSettings)
-import Servant
-import Web.FormUrlEncoded (FromForm)
-
-import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Admin.Auth.Types ( auth_node_id, AuthenticatedUser )
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
-import Gargantext.API.Errors.Types
+import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Node.Corpus.New (addToCorpusWithForm)
 import Gargantext.API.Node.Corpus.New.Types (FileFormat(..), FileType(..))
 import Gargantext.API.Node.Types (NewWithForm(..))
-import Gargantext.API.Prelude
+import Gargantext.API.Prelude ( GargM )
 import Gargantext.Core (Lang)
-import Gargantext.Core.NodeStory (HasNodeArchiveStoryImmediateSaver)
+import Gargantext.Core.NodeStory.Types ( HasNodeArchiveStoryImmediateSaver )
 import Gargantext.Core.Text.List.Social (FlowSocialListWith(..))
 import Gargantext.Core.Types.Individu (User(..))
-import Gargantext.Database.Action.Flow.Types
-import Gargantext.Database.Admin.Types.Hyperdata.Frame
-import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Action.Flow.Types ( FlowCmdM )
+import Gargantext.Database.Admin.Types.Hyperdata.Frame ( HyperdataFrame(..) )
+import Gargantext.Database.Admin.Types.Node ( NodeId, NodeType(NodeCorpus) )
 import Gargantext.Database.Prelude (HasConfig)
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, getNodeWith)
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
+import Network.HTTP.Client (newManager, httpLbs, parseRequest, responseBody)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
+import Servant ( type (:>), JSON, Summary, HasServer(ServerT) )
+import Web.FormUrlEncoded (FromForm)
+
 
 data FrameCalcUpload = FrameCalcUpload {
   _wf_lang      :: !(Maybe Lang)

src/Gargantext/Core/NodeStory.hs

@@ -43,7 +43,6 @@ TODO:
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.Core.NodeStory
   ( module Gargantext.Core.NodeStory.Types
@@ -54,17 +53,18 @@ module Gargantext.Core.NodeStory
   , fromDBNodeStoryEnv
   , upsertNodeStories
   -- , getNodeStory
+  , getNodeStory'
   , nodeStoriesQuery
   , currentVersion
   , archiveStateFromList
   , archiveStateToList
-  , fixNodeStoryVersions )
+  , fixNodeStoryVersions
+  , fixChildrenDuplicatedAsParents
+  , getParentsChildren )
 where
 
-import Control.Lens ((^.), (.~), (%~), non, _Just, at, view)
-import Control.Monad.Except
+import Control.Lens ((^.), (.~), (%~), non, _Just, at, over, view)
 import Data.Map.Strict qualified as Map
-import Data.Monoid
 import Data.Pool (Pool, withResource)
 import Data.Set qualified as Set
 import Database.PostgreSQL.Simple qualified as PGS
@@ -73,12 +73,12 @@ import Database.PostgreSQL.Simple.ToField qualified as PGS
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory.DB
 import Gargantext.Core.NodeStory.Types
-import Gargantext.Core.Types (ListId, NodeId(..))
+import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Prelude (HasConnectionPool(..))
 import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
 import Gargantext.Prelude hiding (to)
-import Gargantext.Prelude.Database
+import Gargantext.Prelude.Database ( runPGSAdvisoryXactLock, runPGSExecute, runPGSQuery )
 
 
 getNodeStory' :: PGS.Connection -> NodeId -> IO ArchiveList
@@ -105,7 +105,7 @@ getNodeStory' c nId = do
     pure ()
 -}
 
-  pure $ foldl combine initArchive dbData
+  pure $ foldl' combine initArchive dbData
   where
     -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
     combine a1 a2 = a1 & a_state %~ combineState (a2 ^. a_state)
@@ -221,15 +221,12 @@ nodeStoryInc c ns@(NodeStory nls) nId = do
 -- `nre_parent` and `nre_children`. We want to make sure that all
 -- children entries (i.e. ones that have `nre_parent`) have the same
 -- `list` as their parent entry.
-fixChildrenInNgramsStatePatch :: NgramsState' -> NgramsState'
-fixChildrenInNgramsStatePatch ns = archiveStateFromList $ nsParents <> nsChildrenFixed
+fixChildrenInNgrams :: NgramsState' -> NgramsState'
+fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
   where
-    nls = archiveStateToList ns
-    
-    nsParents = filter (\(_nt, _t, nre) -> isNothing $ nre ^. nre_parent) nls
+    (nsParents, nsChildren) = getParentsChildren ns
     parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents
-    
-    nsChildren = filter (\(_nt, _t, nre) -> isJust $ nre ^. nre_parent) nls
+
     nsChildrenFixed = (\(nt, t, nre) ->
                          ( nt
                          , t
@@ -241,15 +238,12 @@ fixChildrenInNgramsStatePatch ns = archiveStateFromList $ nsParents <> nsChildre
 -- | Sometimes, when we upload a new list, a child can be left without
 -- a parent. Find such ngrams and set their 'root' and 'parent' to
 -- 'Nothing'.
-fixChildrenWithNoParentStatePatch :: NgramsState' -> NgramsState'
-fixChildrenWithNoParentStatePatch ns = archiveStateFromList $ nsParents <> nsChildrenFixed
+fixChildrenWithNoParent :: NgramsState' -> NgramsState'
+fixChildrenWithNoParent ns = archiveStateFromList $ nsParents <> nsChildrenFixed
   where
-    nls = archiveStateToList ns
-    
-    nsParents = filter (\(_nt, _t, nre) -> isNothing $ nre ^. nre_parent) nls
+    (nsParents, nsChildren) = getParentsChildren ns
     parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
-    
-    nsChildren = filter (\(_nt, _t, nre) -> isJust $ nre ^. nre_parent) nls
+
     nsChildrenFixFunc (nt, t, nre) =
       ( nt
       , t
@@ -263,6 +257,30 @@ fixChildrenWithNoParentStatePatch ns = archiveStateFromList $ nsParents <> nsChi
 
     nsChildrenFixed = nsChildrenFixFunc <$> nsChildren
 
+-- | Sometimes children can also become parents (e.g. #313). Find such
+-- | children and remove them from the list.
+fixChildrenDuplicatedAsParents :: NgramsState' -> NgramsState'
+fixChildrenDuplicatedAsParents ns = archiveStateFromList $ nsChildren <> nsParentsFixed
+  where
+    (nsParents, nsChildren) = getParentsChildren ns
+    parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
+    parentsSet = Set.fromList $ Map.keys parentNtMap
+
+    nsParentsFixed = (\(nt, t, nre) ->
+                       ( nt
+                       , t
+                       , over nre_children
+                             (\c -> mSetFromSet $ Set.difference (mSetToSet c) parentsSet)
+                             nre ) ) <$> nsParents
+
+getParentsChildren :: NgramsState' -> (ArchiveStateList, ArchiveStateList)
+getParentsChildren ns = (nsParents, nsChildren)
+  where
+    nls = archiveStateToList ns
+
+    nsParents = filter (\(_nt, _t, nre) -> isNothing $ nre ^. nre_parent) nls
+    nsChildren = filter (\(_nt, _t, nre) -> isJust $ nre ^. nre_parent) nls
+
 ------------------------------------
 
 fromDBNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
@@ -280,8 +298,15 @@ fromDBNodeStoryEnv pool = do
         withResource pool $ \c -> do
           --printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
           -- writeNodeStories c $ fixChildrenWithNoParent $ fixChildrenTermTypes ns
+
+          -- |NOTE Fixing a_state is kinda a hack. We shouldn't land
+          -- |with bad state in the first place.
           upsertNodeStories c nId $
-            a & a_state %~ (fixChildrenInNgramsStatePatch . fixChildrenWithNoParentStatePatch)
+            a & a_state %~ (
+                       fixChildrenDuplicatedAsParents
+                    .  fixChildrenInNgrams
+                    . fixChildrenWithNoParent
+                    )
   let archive_saver_immediate nId a = withResource pool $ \c -> do
         insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
         pure $ a & a_history .~ []
@@ -289,13 +314,13 @@ fromDBNodeStoryEnv pool = do
         --           insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
         --       ) $ Map.toList nls
         -- pure $ clearHistory ns
-        
+
   pure $ NodeStoryEnv { _nse_saver_immediate = saver_immediate
                       , _nse_archive_saver_immediate = archive_saver_immediate
                       , _nse_getter = \nId -> withResource pool $ \c ->
                           getNodeStory' c nId
                       , _nse_getter_multi = \nIds -> withResource pool $ \c ->
-                          foldM (\m nId -> nodeStoryInc c m nId) (NodeStory Map.empty) nIds
+                          foldM (nodeStoryInc c) (NodeStory Map.empty) nIds
                       }
 
 currentVersion :: (HasNodeStory env err m) => ListId -> m Version

src/Gargantext/Core/NodeStory/Types.hs

@@ -47,23 +47,19 @@ module Gargantext.Core.NodeStory.Types
   , ArchiveStateList )
 where
 
-import Codec.Serialise.Class
+import Codec.Serialise.Class ( Serialise )
 import Control.Lens (makeLenses, Getter, (^.))
-import Control.Monad.Except
-import Control.Monad.Reader
 import Data.Aeson hiding ((.=), decode)
 import Data.Map.Strict qualified as Map
-import Data.Monoid
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Data.Semigroup
 import Data.Set qualified as Set
 import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types (NodeId(..))
+import Gargantext.Database.Admin.Types.Node ( NodeId(..) )
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Prelude (DbCmd')
-import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
+import Gargantext.Database.Schema.Ngrams qualified as TableNgrams
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Prelude hiding (to)
 import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)

src/Gargantext/Core/Text/List/Group/WithStem.hs

@@ -24,8 +24,6 @@ import Data.HashSet (HashSet)
 import Data.HashSet qualified as Set
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
-import Data.Map.Strict.Patch qualified as PatchMap
-import Data.Patch.Class qualified as Patch (Replace(..))
 import Data.Text qualified as Text
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core (Lang(..), Form, Lem, NLPServerConfig)
@@ -120,14 +118,5 @@ patch s = case Set.size s > 1 of
     let children = List.tail ngrams
     pure (parent, toNgramsPatch children)
 
-toNgramsPatch :: [NgramsTerm] -> NgramsPatch
-toNgramsPatch children = NgramsPatch children' Patch.Keep
-  where
-    children' :: PatchMSet NgramsTerm
-    children' = PatchMSet
-              $ fst
-              $ PatchMap.fromList
-              $ List.zip children (List.cycle [addPatch])
-
 -- | Instances
 makeLenses ''GroupParams

src/Gargantext/Utils/Jobs.hs

@@ -20,19 +20,19 @@ module Gargantext.Utils.Jobs (
   , MonadJobStatus(..)
   ) where
 
-import Control.Monad.Except
-import Control.Monad.Reader
+import Control.Monad.Except ( runExceptT )
+import Control.Monad.Reader ( MonadReader(ask), ReaderT(runReaderT) )
 import Data.Aeson (ToJSON)
 import Prelude
 import System.Directory (doesFileExist)
 import Text.Read (readMaybe)
 import qualified Data.Text as T
 
-import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Errors.Types
-import Gargantext.API.Prelude
+import Gargantext.API.Admin.EnvTypes ( mkJobHandle, Env, GargJob(..) )
+import Gargantext.API.Errors.Types ( BackendInternalError(InternalJobError) )
+import Gargantext.API.Prelude ( GargM )
 import qualified Gargantext.Utils.Jobs.Internal as Internal
-import Gargantext.Utils.Jobs.Monad
+import Gargantext.Utils.Jobs.Monad ( JobError, MonadJobStatus(..) )
 import Gargantext.System.Logging
 
 import qualified Servant.Job.Async as SJ
@@ -49,7 +49,7 @@ serveJobsAPI
    , ToJSON (JobEventType m)
    , ToJSON (JobOutputType m)
    , MonadJobStatus m
-   , m ~ (GargM Env BackendInternalError)
+   , m ~ GargM Env BackendInternalError
    , JobEventType m ~ JobOutputType m
    , MonadLogger m
    )

test/Test/API/Authentication.hs

+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE BangPatterns #-}
 
 module Test.API.Authentication (
     tests
@@ -21,13 +21,11 @@ import Network.HTTP.Client hiding (Proxy)
 import Prelude qualified
 import Servant.Auth.Client ()
 import Servant.Client
+import Test.API.Routes (auth_api)
 import Test.API.Setup (withTestDBAndPort, setupEnvironment)
 import Test.Database.Types
 import Test.Hspec
 
-auth_api :: AuthRequest -> ClientM AuthResponse
-auth_api = client (Proxy :: Proxy (MkGargAPI (GargAPIVersion AuthAPI)))
-
 cannedToken :: T.Text
 cannedToken = "eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsiaWQiOjF9fQ.t49zZSqkPAulEkYEh4pW17H2uwrkyPTdZKwHyG3KUJ0hzU2UUoPBNj8vdv087RCVBJ4tXgxNbP4j0RBv3gxdqg"
 
@@ -66,7 +64,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
               , _authRes_user_id = fromMaybe (UnsafeMkUserId 1) $ listToMaybe $ result0 ^.. _Right . authRes_user_id
               }
 
-        result `shouldBe` (Right expected)
+        result `shouldBe` Right expected
 
       it "denies login for user 'alice' if password is invalid" $ \((_testEnv, port), _) -> do
         let authPayload = AuthRequest "alice" (GargPassword "wrong")

test/Test/API/Errors.hs

@@ -9,13 +9,14 @@ import Network.HTTP.Types
 import Network.Wai.Test
 import Servant
 import Servant.Auth.Client ()
+import Servant.Auth.Client qualified as SA
 import Servant.Client
-import Test.API.Private (protected, withValidLogin, protectedNewError)
-import Test.API.Setup (withTestDBAndPort, setupEnvironment, mkUrl, createAliceAndBob)
+import Test.API.Routes (mkUrl)
+import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
 import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication)
+import Test.Utils (protected, withValidLogin, protectedNewError)
 import Text.RawString.QQ (r)
-import qualified Servant.Auth.Client as SA
 
 tests :: Spec
 tests = sequential $ aroundAll withTestDBAndPort $ do

test/Test/API/GraphQL.hs

@@ -10,12 +10,11 @@ module Test.API.GraphQL (
 import Gargantext.Core.Types.Individu
 import Prelude
 import Servant.Auth.Client ()
-import Test.API.Private (withValidLogin, protected, protectedNewError)
 import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
 import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Hspec.Wai.JSON (json)
-import Test.Utils
+import Test.Utils (protected, protectedNewError, shouldRespondWithFragment, shouldRespondWithFragmentCustomStatus, withValidLogin)
 import Text.RawString.QQ (r)
 
 tests :: Spec

test/Test/API/Private.hs

@@ -5,117 +5,24 @@
 
 module Test.API.Private (
     tests
-
-  -- * Utility functions
-  , withValidLogin
-  , getJSON
-  , protected
-  , protectedJSON
-  , postJSONUrlEncoded
-  , protectedNewError
-  , protectedWith
   ) where
 
-import Data.Aeson qualified as JSON
-import Data.ByteString.Lazy qualified as L
-import Data.ByteString.Lazy.Char8 qualified as C8L
-import Data.CaseInsensitive qualified as CI
-import Data.Map.Strict qualified as Map
 import Data.Text.Encoding qualified as TE
-import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Routes
 import Gargantext.Core.Types.Individu
 import Gargantext.Prelude hiding (get)
 import Network.HTTP.Client hiding (Proxy)
-import Network.HTTP.Types
-import Network.Wai.Handler.Warp qualified as Wai
-import Network.Wai.Test (SResponse (..))
-import Prelude qualified
 import Servant
 import Servant.Auth.Client ()
 import Servant.Auth.Client qualified as SA
 import Servant.Client
-import Test.API.Authentication (auth_api)
-import Test.API.Setup (withTestDBAndPort, setupEnvironment, mkUrl, createAliceAndBob)
+import Test.API.Routes (mkUrl)
+import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
 import Test.Hspec
 import Test.Hspec.Wai hiding (pendingWith)
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Hspec.Wai.JSON (json)
-import Test.Utils (shouldRespondWithFragment)
-
--- | Issue a request with a valid 'Authorization: Bearer' inside.
-protected :: HasCallStack
-          => Token
-          -> Method
-          -> ByteString
-          -> L.ByteString
-          -> WaiSession () SResponse
-protected tkn mth url = protectedWith mempty tkn mth url
-
-protectedJSON :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
-              => Token
-              -> Method
-              -> ByteString
-              -> JSON.Value
-              -> WaiSession () a
-protectedJSON tkn mth url = protectedJSONWith mempty tkn mth url
-
-protectedJSONWith :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
-                  => [Network.HTTP.Types.Header]
-                  -> Token
-                  -> Method
-                  -> ByteString
-                  -> JSON.Value
-                  -> WaiSession () a
-protectedJSONWith hdrs tkn mth url jsonV = do
-  SResponse{..} <- protectedWith hdrs tkn mth url (JSON.encode jsonV)
-  case JSON.eitherDecode simpleBody of
-    Left err -> Prelude.fail $ "protectedJSON failed when parsing " <> show (typeRep $ Proxy @a) <> ": " <> err
-    Right x  -> pure x
-
-protectedWith :: HasCallStack
-              => [Network.HTTP.Types.Header]
-              -> Token
-              -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
-protectedWith extraHeaders tkn mth url payload =
-  -- Using a map means that if any of the extra headers contains a clashing header name,
-  -- the extra headers will take precedence.
-  let defaultHeaders = [ (hAccept, "application/json;charset=utf-8")
-                       , (hContentType, "application/json")
-                       , (hAuthorization, "Bearer " <> TE.encodeUtf8 tkn)
-                       ]
-      hdrs = Map.toList $ Map.fromList $ defaultHeaders <> extraHeaders
-  in request mth url hdrs payload
-
-protectedNewError :: HasCallStack => Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
-protectedNewError tkn mth url = protectedWith newErrorFormat tkn mth url
-  where
-    newErrorFormat = [(CI.mk "X-Garg-Error-Scheme", "new")]
-
-getJSON :: Token -> ByteString -> WaiSession () SResponse
-getJSON tkn url = protectedWith mempty tkn "GET" url ""
-
-postJSONUrlEncoded :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
-                   => Token
-                   -> ByteString
-                   -> L.ByteString
-                   -> WaiSession () a
-postJSONUrlEncoded tkn url queryPaths = do
-  SResponse{..} <- protectedWith [(hContentType, "application/x-www-form-urlencoded")] tkn "POST" url queryPaths
-  case JSON.eitherDecode simpleBody of
-    Left err -> Prelude.fail $ "postJSONUrlEncoded failed when parsing " <> show (typeRep $ Proxy @a) <> ": " <> err <> "\nPayload was: " <> (C8L.unpack simpleBody)
-    Right x  -> pure x
-
-withValidLogin :: (MonadFail m, MonadIO m) => Wai.Port -> Username -> GargPassword -> (Token -> m a) -> m a
-withValidLogin port ur pwd act = do
-  baseUrl <- liftIO $ parseBaseUrl "http://localhost"
-  manager <- liftIO $ newManager defaultManagerSettings
-  let clientEnv = mkClientEnv manager (baseUrl { baseUrlPort = port })
-  let authPayload = AuthRequest ur pwd
-  result <- liftIO $ runClientM (auth_api authPayload) clientEnv
-  case result of
-    Left err  -> liftIO $ throwIO $ Prelude.userError (show err)
-    Right res -> act $ _authRes_token res
+import Test.Utils (protected, shouldRespondWithFragment, withValidLogin)
 
 
 tests :: Spec

test/Test/API/Routes.hs

+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TypeOperators #-}
+
+
+module Test.API.Routes where
+
+import Fmt (Builder, (+|), (|+))
+import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse)
+import Gargantext.API.Ngrams (TableNgramsApiGet, TableNgramsApiPut)
+import Gargantext.API.Ngrams.Types ( NgramsTable, NgramsTablePatch, OrderBy, TabType, Versioned, VersionedWithCount )
+import Gargantext.API.Routes (AuthAPI, GargAPIVersion, MkGargAPI)
+import Gargantext.Database.Admin.Types.Node (NodeId)
+import Gargantext.Core.Types.Main (ListType)
+import Gargantext.Core.Types.Query (Limit, MaxSize, MinSize, Offset)
+import Gargantext.Prelude
+import Network.Wai.Handler.Warp (Port)
+import Servant ((:>), Capture)
+import Servant.Client (ClientM, client)
+
+
+-- This is for requests made by http.client directly to hand-crafted URLs    
+curApi :: Builder
+curApi = "v1.0"
+
+mkUrl :: Port -> Builder -> ByteString
+mkUrl _port urlPiece =
+  "/api/" +| curApi |+ urlPiece
+
+
+
+-- This is for Servant.Client requests
+    
+auth_api :: AuthRequest -> ClientM AuthResponse
+auth_api = client (Proxy :: Proxy (MkGargAPI (GargAPIVersion AuthAPI)))
+
+-- | Shortcut for TableNgramsApiGet full path
+type APITableNgramsGet = MkGargAPI (GargAPIVersion ( "node"
+                                                   :> Capture "node_id" NodeId
+                                                   :> "ngrams"
+                                                   :> TableNgramsApiGet ) )
+table_ngrams_get_api :: NodeId
+                     -> TabType
+                     -> NodeId
+                     -> Limit
+                     -> Maybe Offset
+                     -> Maybe ListType
+                     -> Maybe MinSize
+                     -> Maybe MaxSize
+                     -> Maybe OrderBy
+                     -> Maybe Text
+                     -> ClientM (VersionedWithCount NgramsTable)
+table_ngrams_get_api = client (Proxy :: Proxy APITableNgramsGet)
+type APITableNgramsPut = MkGargAPI (GargAPIVersion ( "node"
+                                                   :> Capture "node_id" NodeId
+                                                   :> "ngrams"
+                                                   :> TableNgramsApiPut ) )
+table_ngrams_put_api :: NodeId
+                     -> TabType
+                     -> NodeId
+                     -> Versioned NgramsTablePatch
+                     -> ClientM (Versioned NgramsTablePatch)
+table_ngrams_put_api = client (Proxy :: Proxy APITableNgramsPut)

test/Test/API/Setup.hs

@@ -5,8 +5,6 @@ module Test.API.Setup where
 
 import Control.Lens
 import Control.Monad.Reader
-import Data.ByteString (ByteString)
-import Fmt (Builder, (+|), (|+))
 import Gargantext.API (makeApp)
 import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
 import Gargantext.API.Admin.Settings
@@ -40,7 +38,6 @@ import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import qualified Gargantext.Utils.Jobs.Queue as Jobs
 import qualified Gargantext.Utils.Jobs.Settings as Jobs
 import qualified Network.Wai.Handler.Warp         as Warp
-import qualified Network.Wai.Handler.Warp as Wai
 import qualified Servant.Job.Async as ServantAsync
 
 
@@ -117,10 +114,3 @@ createAliceAndBob testEnv = do
 
     void $ new_user nur1
     void $ new_user nur2
-
-curApi :: Builder
-curApi = "v1.0"
-
-mkUrl :: Wai.Port -> Builder -> ByteString
-mkUrl _port urlPiece =
-  "/api/" +| curApi |+ urlPiece

test/Test/Database/Operations/NodeStory.hs

@@ -13,7 +13,7 @@ Portability : POSIX
 
 module Test.Database.Operations.NodeStory where
 
-import Control.Lens ((^.), (.~), _2)
+import Control.Lens ((^.), (.~), (?~), _2)
 import Control.Monad.Reader
 import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
@@ -23,7 +23,7 @@ import Database.PostgreSQL.Simple.SqlQQ
 import Gargantext.API.Ngrams (commitStatePatch, mSetFromList, setListNgrams, saveNodeStory)
 import Gargantext.API.Ngrams.Types (MSet(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTerm(..), Versioned(..), mkNgramsTablePatch, nre_children, nre_list, nre_parent, nre_root)
 import Gargantext.API.Ngrams.Tools (getNodeStory)
-import Gargantext.Core.NodeStory hiding (runPGSQuery)
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Types.Individu
 import Gargantext.Core.Types (ListType(..), ListId, NodeId, UserId)
 import Gargantext.Database.Action.User (getUserId)
@@ -73,15 +73,15 @@ simpleParentTerm' = fst simpleTerm
 simpleParentTerm :: (NgramsTerm, NgramsRepoElement)
 simpleParentTerm = ( simpleParentTerm'
                    , simpleTerm ^. _2
-                     & nre_children .~ (mSetFromList [simpleChildTerm']) )
+                     & nre_children .~ mSetFromList [simpleChildTerm'] )
 
 simpleChildTerm' :: NgramsTerm
 simpleChildTerm' = NgramsTerm "world"
 simpleChildTerm :: (NgramsTerm, NgramsRepoElement)
 simpleChildTerm = ( simpleChildTerm'
-                  , simpleTerm ^. _2 
-                    & nre_parent .~ Just simpleParentTerm'
-                    & nre_root .~ Just simpleParentTerm' )
+                  , simpleTerm ^. _2
+                    & nre_parent ?~ simpleParentTerm'
+                    & nre_root ?~ simpleParentTerm' )
 
 
 -- tests start here
@@ -92,7 +92,7 @@ createListTest env = do
     (userId, corpusId, listId, _a) <- commonInitialization
 
     listId' <- getOrMkList corpusId userId
-    
+
     liftIO $ listId `shouldBe` listId'
 
 
@@ -110,7 +110,7 @@ queryNodeStoryTest env = do
 
     liftIO $ do
       a' `shouldBe` a
-  
+
 
 insertNewTermsToNodeStoryTest :: TestEnv -> Assertion
 insertNewTermsToNodeStoryTest env = do
@@ -128,7 +128,7 @@ insertNewTermsToNodeStoryTest env = do
     -- check that the ngrams are in the DB as well
     ngramsMap <- selectNgramsId [unNgramsTerm terms]
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` [unNgramsTerm terms]
-    
+
     -- Finally, check that node stories are inserted correctly
     dbTerms <- runPGSQuery [sql|
                                SELECT terms
@@ -137,7 +137,7 @@ insertNewTermsToNodeStoryTest env = do
                                WHERE node_id = ?
                                |] (PSQL.Only listId)
     liftIO $ dbTerms `shouldBe` [PSQL.Only $ unNgramsTerm terms]
-                           
+
 
 insertNewTermsWithChildrenToNodeStoryTest :: TestEnv -> Assertion
 insertNewTermsWithChildrenToNodeStoryTest env = do
@@ -147,7 +147,7 @@ insertNewTermsWithChildrenToNodeStoryTest env = do
     let (tParent, nreParent) = simpleParentTerm
     let (tChild, nreChild) = simpleChildTerm
     let terms = unNgramsTerm <$> [tParent, tChild]
-    
+
     let nls = Map.fromList [(tParent, nreParent), (tChild, nreChild)]
     setListNgrams listId NgramsTerms nls
 
@@ -160,7 +160,7 @@ insertNewTermsWithChildrenToNodeStoryTest env = do
     -- the terms in the DB by now
     ngramsMap <- selectNgramsId terms
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` terms
-    
+
     dbTerms <- runPGSQuery [sql|
                                SELECT terms
                                FROM ngrams
@@ -171,13 +171,13 @@ insertNewTermsWithChildrenToNodeStoryTest env = do
 
     -- let (Just (tParentId, _)) = head $ filter ((==) (unNgramsTerm tParent) . snd) $ Map.toList ngramsMap2
     -- let (Just (tChildId, _)) = head $ filter ((==) (unNgramsTerm tChild) . snd) $ Map.toList ngramsMap2
-                           
+
     -- [PSQL.Only tParentId'] <-
     --   runPGSQuery [sql|SELECT parent_id FROM ngrams WHERE terms = ?|] (PSQL.Only tChild)
 
     -- liftIO $ tParentId `shouldBe` tParentId'
 
-      
+
 insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest :: TestEnv -> Assertion
 insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
   flip runReaderT env $ runTestMonad $ do
@@ -187,10 +187,10 @@ insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
     let (tChild, nreChildGoodType) = simpleChildTerm
     let nreChildBrokenType = nreChildGoodType & nre_list .~ MapTerm
     let terms = unNgramsTerm <$> [tParent, tChild]
-    
+
     let nls = Map.fromList [(tParent, nreParent), (tChild, nreChildBrokenType)]
     let nlsWithChildFixed = Map.fromList [(tParent, nreParent), (tChild, nreChildGoodType)]
-    
+
     setListNgrams listId NgramsTerms nls
 
     a <- getNodeStory listId
@@ -200,7 +200,7 @@ insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
 
     ngramsMap <- selectNgramsId terms
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` terms
-    
+
     dbTerms <- runPGSQuery [sql|
                                SELECT terms
                                FROM ngrams
@@ -210,12 +210,12 @@ insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
     liftIO $ (Set.fromList $ (\(PSQL.Only t) -> t) <$> dbTerms) `shouldBe` (Set.fromList terms)
 
     let (Just (tChildId, _)) = head $ filter ((==) (unNgramsTerm tChild) . snd) $ Map.toList ngramsMap
-                           
+
     [PSQL.Only childType] <- runPGSQuery [sql|SELECT ngrams_repo_element->>'list'
                                              FROM node_stories
                                              WHERE ngrams_id = ?|] (PSQL.Only tChildId)
     liftIO $ childType `shouldBe` ("MapTerm" :: Text)
- 
+
 setListNgramsUpdatesNodeStoryTest :: TestEnv -> Assertion
 setListNgramsUpdatesNodeStoryTest env = do
   flip runReaderT env $ runTestMonad $ do
@@ -232,7 +232,7 @@ setListNgramsUpdatesNodeStoryTest env = do
     -- check that the ngrams are in the DB as well
     ngramsMap <- selectNgramsId [unNgramsTerm terms]
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` [unNgramsTerm terms]
-    
+
     let nre2 = NgramsRepoElement { _nre_size = 1
                                  , _nre_list = MapTerm
                                  , _nre_root = Nothing

test/Test/Types.hs

+module Test.Types where
+
+import Data.Aeson ((.:), (.:?), (.=), FromJSON(..), ToJSON(..), object, withObject)
+import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
+import Gargantext.Prelude
+
+
+data JobPollHandle = JobPollHandle {
+    _jph_id     :: !Text
+  , _jph_log    :: [JobLog]
+  , _jph_status :: !Text
+  , _jph_error  :: !(Maybe Text)
+    } deriving Show
+
+instance FromJSON JobPollHandle where
+  parseJSON = withObject "JobPollHandle" $ \o -> do
+    _jph_id     <- o .: "id"
+    _jph_log    <- o .: "log"
+    _jph_status <- o .: "status"
+    _jph_error  <- o .:? "error"
+    pure JobPollHandle{..}
+
+instance ToJSON JobPollHandle where
+  toJSON JobPollHandle{..} = object [
+      "id"      .= toJSON _jph_id
+    , "log"     .= toJSON _jph_log
+    , "status"  .= toJSON _jph_status
+    , "error"   .= toJSON _jph_error
+    ]

test/Test/Utils.hs

+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+
 module Test.Utils where
 
-import Control.Exception
-import Control.Monad
-import Data.Aeson
+import Control.Exception ()
+import Control.Lens ((^.))
+import Control.Monad ()
 import Data.Aeson qualified as JSON
 import Data.Aeson.KeyMap qualified as KM
 import Data.ByteString.Char8 qualified as B
-import Data.Char (isSpace)
-import Network.HTTP.Types
-import Network.Wai.Test
-import Prelude
+import Data.ByteString.Lazy qualified as L
+import Data.CaseInsensitive qualified as CI
+import Data.Map.Strict qualified as Map
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
+import Data.Text.Lazy qualified as TL
+import Data.Text.Lazy.Encoding qualified as TLE
+import Fmt (Builder)
+import Gargantext.API.Admin.Auth.Types (AuthRequest(..), Token, authRes_token)
+import Gargantext.Core.Types.Individu (Username, GargPassword)
+import Gargantext.Prelude
+import Network.HTTP.Client (defaultManagerSettings, newManager)
+import Network.HTTP.Types (Header, Method, status200)
+import Network.HTTP.Types.Header (hAccept, hAuthorization, hContentType)
+import Network.Wai.Handler.Warp (Port)
+import Network.Wai.Test (SResponse(..))
+import Prelude qualified
+import Servant.Client (ClientEnv, baseUrlPort, defaultMakeClientRequest, makeClientRequest, mkClientEnv, parseBaseUrl, runClientM)
+import Servant.Client.Core.Request (addHeader)
+import Test.API.Routes (auth_api, mkUrl)
 import Test.Hspec.Expectations
-import Test.Hspec.Wai
+import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
 import Test.Hspec.Wai.JSON (FromValue(..))
-import Test.Hspec.Wai.Matcher
-import Test.Tasty.HUnit
+import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match)
+import Test.Tasty.HUnit (Assertion)
+import Test.Types
+
 
 -- | Marks the input 'Assertion' as pending, by ignoring any exception
 -- thrown by it.
-pending :: String -> Assertion -> Assertion
+pending :: Prelude.String -> Assertion -> Assertion
 pending reason act = act `catch` (\(e :: SomeException) -> do
   putStrLn $ "PENDING: " <> reason
   putStrLn (displayException e))
@@ -56,9 +77,9 @@ instance FromValue JsonFragmentResponseMatcher where
   fromValue = JsonFragmentResponseMatcher . ResponseMatcher 200 [matchHeader] . containsJSON
     where
       matchHeader = MatchHeader $ \headers _body ->
-        case lookup "Content-Type" headers of
+        case Prelude.lookup "Content-Type" headers of
           Just h | isJSON h -> Nothing
-          _ -> Just $ unlines [
+          _ -> Just $ Prelude.unlines [
               "missing header:"
             , formatHeader ("Content-Type", "application/json")
             ]
@@ -70,7 +91,7 @@ instance FromValue JsonFragmentResponseMatcher where
       breakAt c = fmap (B.drop 1) . B.break (== c)
       strip = B.reverse . B.dropWhile isSpace . B.reverse . B.dropWhile isSpace
 
-shouldRespondWithJSON :: (FromJSON a, ToJSON a, HasCallStack)
+shouldRespondWithJSON :: (JSON.FromJSON a, JSON.ToJSON a, HasCallStack)
                       => WaiSession st a
                       -> JsonFragmentResponseMatcher
                       -> WaiExpectation st
@@ -78,14 +99,127 @@ shouldRespondWithJSON action matcher = do
   r <- action
   forM_ (match (SResponse status200 mempty (JSON.encode r)) (getJsonMatcher matcher)) (liftIO . expectationFailure)
 
-containsJSON :: Value -> MatchBody
+containsJSON :: JSON.Value -> MatchBody
 containsJSON expected = MatchBody matcher
   where
-    matcher headers actualBody = case decode actualBody of
+    matcher headers actualBody = case JSON.decode actualBody of
       Just actual | expected `isSubsetOf` actual -> Nothing
-      _ -> let MatchBody m = bodyEquals (encode expected) in m headers actualBody
+      _ -> let MatchBody m = bodyEquals (JSON.encode expected) in m headers actualBody
 
-    isSubsetOf :: Value -> Value -> Bool
-    isSubsetOf (Object sub) (Object sup) =
+    isSubsetOf :: JSON.Value -> JSON.Value -> Bool
+    isSubsetOf (JSON.Object sub) (JSON.Object sup) =
       all (\(key, value) -> KM.lookup key sup == Just value) (KM.toList sub)
     isSubsetOf x y = x == y
+
+
+authenticatedServantClient :: Int -> T.Text -> IO ClientEnv
+authenticatedServantClient port token = do
+  baseUrl <- parseBaseUrl "http://localhost"
+  manager <- newManager defaultManagerSettings
+  let requestAddToken url req =
+          defaultMakeClientRequest url $ addHeader hAuthorization ("Bearer " <> token)
+                                       $ addHeader hContentType (T.pack "application/json") req
+
+  pure $ (mkClientEnv manager (baseUrl { baseUrlPort = port })) { makeClientRequest = requestAddToken }
+
+
+
+
+-- | Issue a request with a valid 'Authorization: Bearer' inside.
+protected :: HasCallStack
+          => Token
+          -> Method
+          -> ByteString
+          -> L.ByteString
+          -> WaiSession () SResponse
+protected tkn mth url = protectedWith mempty tkn mth url
+
+protectedJSON :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
+              => Token
+              -> Method
+              -> ByteString
+              -> JSON.Value
+              -> WaiSession () a
+protectedJSON tkn mth url = protectedJSONWith mempty tkn mth url
+
+protectedJSONWith :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
+                  => [Header]
+                  -> Token
+                  -> Method
+                  -> ByteString
+                  -> JSON.Value
+                  -> WaiSession () a
+protectedJSONWith hdrs tkn mth url jsonV = do
+  SResponse{..} <- protectedWith hdrs tkn mth url (JSON.encode jsonV)
+  case JSON.eitherDecode simpleBody of
+    Left err -> Prelude.fail $ "protectedJSON failed when parsing " <> show (typeRep $ Proxy @a) <> ": " <> err
+    Right x  -> pure x
+
+protectedWith :: HasCallStack
+              => [Header]
+              -> Token
+              -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
+protectedWith extraHeaders tkn mth url payload =
+  -- Using a map means that if any of the extra headers contains a clashing header name,
+  -- the extra headers will take precedence.
+  let defaultHeaders = [ (hAccept, "application/json;charset=utf-8")
+                       , (hContentType, "application/json")
+                       , (hAuthorization, "Bearer " <> TE.encodeUtf8 tkn)
+                       ]
+      hdrs = Map.toList $ Map.fromList $ defaultHeaders <> extraHeaders
+  in request mth url hdrs payload
+
+protectedNewError :: HasCallStack => Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
+protectedNewError tkn mth url = protectedWith newErrorFormat tkn mth url
+  where
+    newErrorFormat = [(CI.mk "X-Garg-Error-Scheme", "new")]
+
+getJSON :: Token -> ByteString -> WaiSession () SResponse
+getJSON tkn url = protectedWith mempty tkn "GET" url ""
+
+postJSONUrlEncoded :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
+                   => Token
+                   -> ByteString
+                   -> L.ByteString
+                   -> WaiSession () a
+postJSONUrlEncoded tkn url queryPaths = do
+  SResponse{..} <- protectedWith [(hContentType, "application/x-www-form-urlencoded")] tkn "POST" url queryPaths
+  case JSON.eitherDecode simpleBody of
+    Left err -> Prelude.fail $ "postJSONUrlEncoded failed when parsing " <> show (typeRep $ Proxy @a) <> ": " <> err <> "\nPayload was: " <> (T.unpack . TL.toStrict . TLE.decodeUtf8 $ simpleBody)
+    Right x  -> pure x
+
+withValidLogin :: (MonadFail m, MonadIO m) => Port -> Username -> GargPassword -> (Token -> m a) -> m a
+withValidLogin port ur pwd act = do
+  baseUrl <- liftIO $ parseBaseUrl "http://localhost"
+  manager <- liftIO $ newManager defaultManagerSettings
+  let clientEnv = mkClientEnv manager (baseUrl { baseUrlPort = port })
+  let authPayload = AuthRequest ur pwd
+  result <- liftIO $ runClientM (auth_api authPayload) clientEnv
+  case result of
+    Left err  -> liftIO $ throwIO $ Prelude.userError (show err)
+    Right res -> act $ res ^. authRes_token
+
+
+-- | Poll the given job URL every second until it finishes.
+-- Retries up to 60 times (i.e. for 1 minute, before giving up)
+pollUntilFinished :: HasCallStack
+                  => Token
+                  -> Port
+                  -> (JobPollHandle -> Builder)
+                  -> JobPollHandle
+                  -> WaiSession () JobPollHandle
+pollUntilFinished tkn port mkUrlPiece = go 60
+  where
+   go :: Int -> JobPollHandle -> WaiSession () JobPollHandle
+   go 0 h  = panicTrace $ "pollUntilFinished exhausted attempts. Last found JobPollHandle: " <> TE.decodeUtf8 (L.toStrict $ JSON.encode h)
+   go n h = case _jph_status h == "IsPending" || _jph_status h == "IsRunning" of
+    True -> do
+      liftIO $ threadDelay 1_000_000
+      h' <- protectedJSON tkn "GET" (mkUrl port $ mkUrlPiece h) ""
+      go (n-1) h'
+    False
+     | _jph_status h == "IsFailure"
+     -> panicTrace $ "JobPollHandle contains a failure: " <> TE.decodeUtf8 (L.toStrict $ JSON.encode h)
+     | otherwise
+     -> pure h
+