Merge branch 'dev' into 471-dev-node-multiterms

CHANGELOG.md

+## Version 0.0.7.4.8
+
+* [BACK][UPGRADE][Upgrade GHC to 9.6.x (#436)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/436) and [Try to drop dependency on `accelerate-llvm` and the entire `llvm` stack (#291)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/291)
+* [BACK][FEAT][Implement temporary file storage (#444)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/444)
+* [BACK/FRONT][FEAT][Import/export in SQLite format (#362)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/362)
+* [DOC][README][README: add info about system postgresql configuration](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/403)
+* [FRONT][FIX][`./install` doesn't work on Darwin (#671)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/671)
+* [BACK][FIX][Fix `start-all` so that it throws exception when a subprocess fails (#463)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/463)
+* [FRONT][FIX][[corpus] create list if it doesn't exist](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/506)
+* [FRONT][FIX][Upload file sends 'Nothing' as language which results in 400 error from backend (#736)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/736)
+* [BACK][FIX][Convert non-transactional GGTX DB queries into transactions (#411)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/466) and [ACID properties of DB operations](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/411)
+* [BACK][FIX][Proper (and thread-safe) implementation for `withSeed`](https://gitlab.iscpif.fr/gargantext/haskell-igraph/merge_requests/6)
+* [FRONT][FEAT][Share link copy to clipboard](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/719)
+* [BACK][FIX][Relax dependency bounds](https://gitlab.iscpif.fr/gargantext/haskell-igraph/merge_requests/8)
+* [BACK][UPGRADE][Upgrade IGraph](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/411)
+* [FRONT][FEAT][Feature flags hide](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/511)
+* [BACK][FIX][Fix a bug in `buildPatterns` and friends](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/413)
+* [BACK/FRONT][OPTIM][Resolve "Display graph parameters in legend"](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/510)
+* [BACK][FIX][Separate ngram extraction from document insertion](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/415)
+* [BACK][REFACT][API refactorings (#467)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/467)
+* [BACK/FRONT][FIX][[graphql] simplify and_logic for get contexts for ngrams](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/515)
+* [FRONT][OPTIM][[Node Graph] CSS improvements on the legend tab (#743)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/743)
+* [BACK][FIX][ Have `extractNgramsFromDocument` catch the right exception in case extraction fails](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/419)
+* [FRONT][FIX][[Node terms] Show related docs for children terms as well](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/516)
+* [BACK][FIX][Fix bug in DB transaction rollbacks in the presence of domain-specific errors](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/420)
+* [BACK][FIX][Resolve "Error uploading zip file on dev"](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/417)
+* [BACK][OPTIM][Port all the tasty specs to hspec](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/423)
+* [BACK][UPGRADE][[openalex] make search act similar to the one on openalex web](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/425)
+* [BACK][FIX][Proper incremental TSV parser](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/402)
+* [BACK][OPTIM][Remove useless ghc dependency from tree](https://gitlab.iscpif.fr/gargantext/crawlers/pubmed/merge_requests/14)
+
 ## Version 0.0.7.4.7
 
 * [BACK][FIX][Adjust the output of the UpdateList tests (#460)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/460)

bin/gargantext-cli/CLI/Ini.hs

@@ -11,10 +11,7 @@ Import a corpus binary.
 
  -}
 
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE Strict            #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeApplications #-}
 
 module CLI.Ini where
 
@@ -104,12 +101,12 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
 
 mkFrontendConfig :: Ini.GargConfig -> CTypes.FrontendConfig
 mkFrontendConfig (Ini.GargConfig { .. }) =
-  CTypes.FrontendConfig { _fc_url = _gc_url
+  CTypes.FrontendConfig { _fc_external_url = _fc_url
+                        , _fc_internal_url = _fc_url
+                        , _fc_directory = "./purescript-gargantext/dist"
                         , _fc_backend_name = _gc_backend_name
-                        , _fc_url_backend_api = _gc_url_backend_api
                         , _fc_cors
                         , _fc_microservices
-                        , _fc_appPort = 3000
                         , _fc_cookie_settings = CTypes.defaultCookieSettings }
   where
     _fc_cors = CTypes.CORSSettings { _corsAllowedOrigins = [
@@ -138,6 +135,10 @@ mkFrontendConfig (Ini.GargConfig { .. }) =
       case parseBaseUrl (T.unpack url) of
         Nothing -> panicTrace $ "Cannot parse base url for: " <> url
         Just b -> CTypes.CORSOrigin b
+    _fc_url =
+      case parseBaseUrl (T.unpack _gc_url) of
+        Nothing -> panicTrace $ "Cannot parse base url for: " <> _gc_url
+        Just b -> b
 
 defaultNotificationsConfig :: CTypes.NotificationsConfig
 defaultNotificationsConfig =

bin/gargantext-cli/CLI/Server.hs

@@ -77,13 +77,11 @@ serverParser = hsubparser (
 start_p :: Parser CLIServer
 start_p = fmap CLIS_start $ ServerArgs
   <$> mode_p
-  <*> port_p
   <*> settings_p
 
 start_all_p :: Parser CLIServer
 start_all_p = fmap CLIS_startAll $ ServerArgs
   <$> mode_p
-  <*> port_p
   <*> settings_p
 
 mode_p :: Parser Mode
@@ -92,21 +90,13 @@ mode_p = option auto ( long "mode"
                     <> metavar "M"
                     <> help "Possible modes: Dev | Mock | Prod" )
 
-port_p :: Parser Int
-port_p = option auto ( long "port"
-                    <> short 'p'
-                    <> metavar "P"
-                    <> showDefault
-                    <> value 8008
-                    <> help "Port" )
-
 version_p :: Parser CLIServer
 version_p = pure CLIS_version
 
 
 startServerCLI :: Logger IO -> ServerArgs -> IO ()
 startServerCLI ioLogger (ServerArgs { .. }) = do
-  logMsg ioLogger INFO $ "starting server, mode: " <> show server_mode <> ", port: " <> show server_port <> ", config: " <> _SettingsFile server_toml
+  logMsg ioLogger INFO $ "starting server, mode: " <> show server_mode <> ", config: " <> _SettingsFile server_toml
   -- Sets the locale to avoid encoding issues like in #284.
   setLocaleEncoding utf8
 
@@ -114,4 +104,4 @@ startServerCLI ioLogger (ServerArgs { .. }) = do
     logMsg ioLogger ERROR "Mock mode not supported!"
     exitFailure
 
-  startGargantext server_mode server_port server_toml
+  startGargantext server_mode server_toml

bin/gargantext-cli/CLI/Types.hs

@@ -100,7 +100,6 @@ data CLIServer
 
 data ServerArgs = ServerArgs
   { server_mode :: !Mode
-  , server_port :: !Int
   , server_toml :: !SettingsFile }
   deriving (Show, Eq)
 

devops/docker/docker-compose.yaml

@@ -40,7 +40,8 @@ services:
       POSTGRES_PASSWORD: C8kdcUrAQy66U
       POSTGRES_DB: gargandbV5
     volumes:
-      - garg-pgdata14:/var/lib/postgresql/data
+      # - garg-pgdata14:/var/lib/postgresql/data
+      - docker_garg-pgdata14:/var/lib/postgresql/data
       - ../:/gargantext
       - ../dbs:/dbs
       - ../postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro
@@ -71,6 +72,8 @@ services:
 
 volumes:
   #garg-pgdata:
-  garg-pgdata14:
+  # garg-pgdata14:
+  docker_garg-pgdata14:
+    external: true
   js-cache:
   pgadmin:

gargantext-settings.toml_toModify

 [frontend]
+# Main url serving the FrontEnd (public URL)
+external_url = "http://localhost:8008"
 
-# Main url serving the FrontEnd
-url = "http://localhost"
+# host/port where the GarganText server will bind to
+internal_url = "http://localhost:8008"
 
-backend_name = "localhost"
+# Location of the frontend code. This will be served at the root of
+# the path (e.g. index.html)
+directory = "./purescript-gargantext/dist"
 
-# Main API url serving the BackEnd
-url_backend_api = "http://localhost:8008/api/v1.0"
+backend_name = "localhost"
 
 jwt_settings = "TODO"
 

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.4.7
+version: 0.0.7.4.8
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -570,6 +570,7 @@ library
     , json-stream ^>= 0.4.2.4
     , lens >= 5.2.2 && < 5.3
     , lens-aeson < 1.3
+    , list-zipper
     , massiv < 1.1
     , matrix ^>= 0.3.6.1
     , mime-mail >= 0.5.1

nix/pkgs.nix

+# https://nix.dev/tutorials/first-steps/towards-reproducibility-pinning-nixpkgs.html
 { pkgs ? import
     (if builtins.elem builtins.currentSystem [ "x86_64-darwin" "aarch64-darwin" ]
     then ./pinned-25.05.darwin.nix
@@ -7,19 +8,20 @@
 
 rec {
   inherit pkgs;
-  ghc966 = pkgs.haskell.compiler.ghc966;
-  cabal_install = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.ghc966.cabal-install;
+  ghcVersion = "ghc966";
+  gargGhc = pkgs.haskell.compiler.${ghcVersion};
+  cabal_install = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.${ghcVersion}.cabal-install;
 
   graphviz = pkgs.callPackage ./graphviz.nix { };
   igraph_0_10_4 = pkgs.callPackage ./igraph.nix { };
-  corenlp = pkgs.callPackage ./corenlp.nix { }; # 4.5.8
-  cabal2stack = pkgs.callPackage ./cabal2stack.nix { ghc = ghc966; };
+  corenlp = pkgs.callPackage ./corenlp.nix { }; # 4.5.9
+  cabal2stack = pkgs.callPackage ./cabal2stack.nix { ghc = gargGhc; };
   nng_notls = pkgs.nng.overrideAttrs (old: {
     cmakeFlags = (old.cmakeFlags or [ ]) ++ [ "-DNNG_ENABLE_TLS=OFF" ];
   });
 
   hsBuildInputs = [
-    ghc966
+    gargGhc
     cabal_install
     pkgs.haskellPackages.alex
     pkgs.haskellPackages.happy

src/Gargantext/API.hs

@@ -49,7 +49,7 @@ import Gargantext.API.Routes.Named (API)
 import Gargantext.API.Routes.Named.EKG (EkgAPI)
 import Gargantext.API.Server.Named (server)
 import Gargantext.Core.Config
-import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, MicroServicesProxyStatus(..), NotificationsConfig(..), PortNumber, SettingsFile(..), corsAllowedOrigins, fc_appPort, fc_cors, fc_cookie_settings, microServicesProxyStatus)
+import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, MicroServicesProxyStatus(..), NotificationsConfig(..), PortNumber, SettingsFile(..), corsAllowedOrigins, fc_cors, fc_cookie_settings, fc_internal_url, microServicesProxyStatus)
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Notifications (withNotifications)
 import Gargantext.Database.Prelude qualified as DB
@@ -62,21 +62,20 @@ import Network.Wai.Handler.Warp hiding (defaultSettings)
 import Network.Wai.Middleware.Cors
 import Network.Wai.Middleware.RequestLogger (logStdout)
 import Servant hiding (Header)
-import Servant.Client.Core.BaseUrl (showBaseUrl)
+import Servant.Client.Core.BaseUrl (showBaseUrl, baseUrlPort)
 import System.Clock qualified as Clock
 import System.Cron.Schedule qualified as Cron
 
 -- | startGargantext takes as parameters port number and Toml file.
-startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
-startGargantext mode port sf@(SettingsFile settingsFile) = do
-  config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port
+startGargantext :: Mode -> SettingsFile -> IO ()
+startGargantext mode sf@(SettingsFile settingsFile) = do
+  config <- readConfig sf
   withLoggerIO (config ^. gc_logging) $ \logger -> do
-    when (port /= config ^. gc_frontend_config . fc_appPort) $
-      panicTrace "TODO: conflicting settings of port"
     withNotifications config $ \dispatcher -> do
       env <- newEnv logger config dispatcher
       let fc = env ^. env_config . gc_frontend_config
       let proxyStatus = microServicesProxyStatus fc
+      let port = baseUrlPort (fc ^. fc_internal_url)
       runDbCheck env
       startupInfo config port proxyStatus
       app <- makeApp env

src/Gargantext/API/Admin/FrontEnd.hs

@@ -16,9 +16,10 @@ Loads all static file for the front-end.
 ---------------------------------------------------------------------
 module Gargantext.API.Admin.FrontEnd where
 
+import GHC.IO (FilePath)
 import Servant
 
 type FrontEndAPI = Raw
 
-frontEndServer :: Server FrontEndAPI
-frontEndServer = serveDirectoryFileServer "./purescript-gargantext/dist"
+frontEndServer :: FilePath -> Server FrontEndAPI
+frontEndServer path = serveDirectoryFileServer path

src/Gargantext/API/Ngrams.hs

@@ -18,6 +18,7 @@ add get
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
+{-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE ConstraintKinds     #-}
 {-# LANGUAGE IncoherentInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -82,10 +83,21 @@ module Gargantext.API.Ngrams
 
   -- * Handlers to be used when serving top-level API requests
   , getTableNgramsCorpusHandler
+
+  -- * Internals for testing
+  , compute_new_state_patches
+  , PatchHistory(..)
+  , newNgramsFromNgramsStatePatch
+  , filterNgramsNodes
+
+  -- * Operations on a forest
+  , buildForest
+  , destroyForest
+  , pruneForest
   )
   where
 
-import Control.Lens (view, (^..), (+~), (%~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex, over)
+import Control.Lens (view, (^..), (+~), (%~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex)
 import Data.Aeson.Text qualified as DAT
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
@@ -94,9 +106,11 @@ 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 ( writeFile )
+import Data.Tree
 import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core.NodeStory (ArchiveList, HasNodeStory, NgramsStatePatch', a_history, a_state, a_version, currentVersion, NodeStoryEnv, hasNodeArchiveStoryImmediateSaver, hasNodeStoryImmediateSaver, HasNodeStoryEnv (..))
+import Gargantext.Core.NodeStory hiding (buildForest)
+import Gargantext.Core.NodeStory qualified as NodeStory
 import Gargantext.Core.Text.Ngrams (Ngrams, NgramsType)
 import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, ContextId, HasValidationError)
 import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
@@ -107,7 +121,6 @@ import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
 import Text.Collate qualified as Unicode
 
 
-
 {-
 -- TODO sequences of modifications (Patchs)
 type NgramsIdPatch = Patch NgramsId NgramsPatch
@@ -261,25 +274,11 @@ commitStatePatch :: NodeStoryEnv err
                  -> Versioned NgramsStatePatch'
                  -> DBUpdate err (Versioned NgramsStatePatch')
 commitStatePatch env listId (Versioned _p_version p) = do
-  -- printDebug "[commitStatePatch]" listId
   a <- getNodeStory env listId
   let archiveSaver = view hasNodeArchiveStoryImmediateSaver env
-  -- ns <- liftBase $ atomically $ readTVar var
-  let
-    -- a = ns ^. unNodeStory . at listId . non initArchive
-    -- apply patches from version p_version to a ^. a_version
-    -- TODO Check this
-    --q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
-    q = mconcat $ a ^. a_history
-
-  --printDebug "[commitStatePatch] transformWith" (p,q)
-  -- let tws s = case s of
-  --       (Mod p) -> "Mod"
-  --       _ -> "Rpl"
-  -- printDebug "[commitStatePatch] transformWith" (tws $ p ^. _NgramsPatch, tws $ q ^. _NgramsPatch)
 
   let
-    (p', q') = transformWith ngramsStatePatchConflictResolution p q
+    (p', q') = compute_new_state_patches p (PatchHistory $ a ^. a_history)
     a' = a & a_version +~ 1
            & a_state   %~ act p'
            & a_history %~ (p' :)
@@ -335,6 +334,27 @@ commitStatePatch env listId (Versioned _p_version p) = do
   pure newA
 
 
+newtype PatchHistory =
+  PatchHistory { _PatchHistory :: [ NgramsStatePatch' ] }
+  deriving (Show, Eq)
+
+-- | Computes the new state patch from the new patch and
+-- the history of patches applied up to this point.
+-- Returns a pair of patches (p,q) following the semantic of
+-- the 'Transformable' class, that says:
+--
+-- Given two diverging patches @p@ and @q@, @transformWith m p q@ returns
+-- a pair of updated patches @(p',q')@ such that @p' <> q@ and
+-- @q' <> p@ are equivalent patches that incorporate the changes
+-- of /both/ @p@ and @q@, up to merge conflicts, which are handled by
+-- the provided function @m@.
+compute_new_state_patches :: NgramsStatePatch'
+                          -> PatchHistory
+                          -> (NgramsStatePatch', NgramsStatePatch')
+compute_new_state_patches latest_patch (PatchHistory history) =
+  let squashed_history = mconcat history
+  in transformWith ngramsStatePatchConflictResolution latest_patch squashed_history
+
 
 -- This is a special case of tableNgramsPut where the input patch is empty.
 tableNgramsPull :: NodeStoryEnv err
@@ -410,6 +430,60 @@ dumpJsonTableMap fpath nodeId ngramsType = do
   liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
   pure ()
 
+-- | Filters the given `tableMap` with the search criteria. It returns
+-- the input map, where each bucket indexed by a 'NgramsTerm' has been
+-- filtered via the given predicate. Removes the key from the map if
+-- the filtering would result in the empty set.
+filterNgramsNodes :: Maybe ListType
+                  -> Maybe MinSize
+                  -> Maybe MaxSize
+                  -> (NgramsTerm -> Bool)
+                  -> Map NgramsTerm NgramsElement
+                  -> Map NgramsTerm NgramsElement
+filterNgramsNodes listTy minSize maxSize searchFn tblMap =
+  flip Map.mapMaybe tblMap $ \e ->
+    case matchingNode listTy minSize maxSize searchFn e of
+      False -> Nothing
+      True  -> Just e
+
+-- | Returns 'True' if the input 'NgramsElement' satisfies the search criteria
+-- mandated by 'NgramsSearchQuery'.
+matchingNode :: Maybe ListType
+             -> Maybe MinSize
+             -> Maybe MaxSize
+             -> (NgramsTerm -> Bool)
+             -> NgramsElement
+             -> Bool
+matchingNode listType minSize maxSize searchQuery inputNode =
+  let nodeSize        = inputNode ^. ne_size
+      matchesListType = maybe (const True) (==) listType
+      respectsMinSize = maybe (const True) ((<=) . getMinSize) minSize
+      respectsMaxSize = maybe (const True) ((>=) . getMaxSize) maxSize
+
+  in    respectsMinSize nodeSize
+     && respectsMaxSize nodeSize
+     && searchQuery (inputNode ^. ne_ngrams)
+     && matchesListType (inputNode ^. ne_list)
+
+-- | Version of 'buildForest' specialised over the 'NgramsElement' as the values of the tree.
+-- We can't use a single function to \"rule them all\" because the 'NgramsRepoElement', that
+-- the 'NodeStory' uses does not have an 'ngrams' we can use as the key when building and
+-- destroying a forest.
+buildForest :: Map NgramsTerm NgramsElement -> Forest NgramsElement
+buildForest = map (fmap snd) . NodeStory.buildForest
+
+-- | Folds an Ngrams forest back to a table map.
+-- This function doesn't aggregate information, but merely just recostructs the original
+-- map without loss of information. To perform operations on the forest, use the appropriate
+-- functions.
+destroyForest :: Forest NgramsElement -> Map NgramsTerm NgramsElement
+destroyForest f = Map.fromList . map (foldTree destroyTree) $ f
+  where
+    destroyTree :: NgramsElement -> [(NgramsTerm, NgramsElement)] -> (NgramsTerm, NgramsElement)
+    destroyTree rootEl childrenEl = (_ne_ngrams rootEl, squashElements rootEl childrenEl)
+
+    squashElements :: NgramsElement -> [(NgramsTerm, NgramsElement)] -> NgramsElement
+    squashElements r _ = r
 
 -- | TODO Errors management
 --  TODO: polymorphic for Annuaire or Corpus or ...
@@ -426,42 +500,14 @@ searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement)
                   -> VersionedWithCount NgramsTable
 searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
   let tableMap     = versionedTableMap ^. v_data
-      filteredData = filterNodes tableMap
+      filteredData = filterNgramsNodes _nsq_listType _nsq_minSize _nsq_maxSize _nsq_searchQuery tableMap
+      forestRoots  = Set.fromList . Map.elems . destroyForest . buildForest $ filteredData
       tableMapSorted = versionedTableMap
-                     & v_data .~ (NgramsTable . sortAndPaginate . withInners tableMap $ filteredData)
+                     & v_data .~ (NgramsTable . sortAndPaginate . withInners tableMap $ forestRoots)
 
-  in toVersionedWithCount (Set.size filteredData) tableMapSorted
+  in toVersionedWithCount (Set.size forestRoots) tableMapSorted
   where
 
-    -- | Returns the \"root\" of the 'NgramsElement', or it falls back to the input
-    -- 'NgramsElement' itself, if no root can be found.
-    -- /CAREFUL/: The root we select might /not/ have the same 'listType' we are
-    -- filtering for, in which case we have to change its type to match, if needed.
-    rootOf :: Map NgramsTerm NgramsElement -> NgramsElement -> NgramsElement
-    rootOf tblMap ne = case ne ^. ne_root of
-      Nothing -> ne
-      Just rootKey
-        | Just r <- tblMap ^. at rootKey
-        -- NOTE(adinapoli) It's unclear what is the correct behaviour here: should
-        -- we override the type or we filter out the node altogether?
-        -> over ne_list (\oldList -> fromMaybe oldList _nsq_listType) r
-        | otherwise
-        -> ne
-
-    -- | Returns 'True' if the input 'NgramsElement' satisfies the search criteria
-    -- mandated by 'NgramsSearchQuery'.
-    matchingNode :: NgramsElement -> Bool
-    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
-
-      in    respectsMinSize nodeSize
-         && respectsMaxSize nodeSize
-         && _nsq_searchQuery (inputNode ^. ne_ngrams)
-         && matchesListType (inputNode ^. ne_list)
-
     -- Sorts the input 'NgramsElement' list.
     -- /IMPORTANT/: As we might be sorting ngrams in all sorts of language,
     -- some of them might include letters with accents and other unicode symbols,
@@ -477,14 +523,6 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
     ngramTermsAscSorter  = on unicodeDUCETSorter (unNgramsTerm . view ne_ngrams)
     ngramTermsDescSorter = on (\n1 n2 -> unicodeDUCETSorter n2 n1) (unNgramsTerm . view ne_ngrams)
 
-    -- | Filters the given `tableMap` with the search criteria. It returns
-    -- a set of 'NgramsElement' all matching the input 'NGramsSearchQuery'.
-    filterNodes :: Map NgramsTerm NgramsElement -> Set NgramsElement
-    filterNodes tblMap = Set.map (rootOf tblMap) selectedNodes
-      where
-        allNodes      = Set.fromList $ Map.elems tblMap
-        selectedNodes = Set.filter matchingNode allNodes
-
     -- | For each input root, extends its occurrence count with
     -- the information found in the subitems.
     withInners :: Map NgramsTerm NgramsElement -> Set NgramsElement -> Set NgramsElement

src/Gargantext/API/Ngrams/NgramsTree.hs

@@ -10,10 +10,17 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE TemplateHaskell   #-}
-
 module Gargantext.API.Ngrams.NgramsTree
-  where
+  ( -- * Types
+    NgramsForest(..)
+  , NgramsTree
+  , GeneralisedNgramsTree(..)
+    -- * Construction
+  , toNgramsTree
+  , toNgramsForest
+  ) where
 
+import Data.Aeson
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
 import Data.List qualified as List
@@ -23,41 +30,80 @@ import Data.Tree ( Tree(Node), unfoldForest )
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types.Main ( ListType(..) )
 import Gargantext.Database.Admin.Types.Node ( NodeId )
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
 import Gargantext.Prelude
 import Test.QuickCheck ( Arbitrary(arbitrary) )
 
-type Children = Text
-type Root = Text
+-- | Ngrams forms a forest, i.e. a set of trees, each tree represents a strong grouping
+-- between terms. Each tree has a root and some children, of arbitrary depth. We use
+-- this data structure internally to represent ngrams tables in a principled way, and later
+-- we \"render\" them back into an 'NgramsTable' and/or a set of ngrams elements, where
+-- each 'NgramElement' is a standalone tree.
+--
+-- Properties:
+--
+-- * Aciclic: each tree is a DAG, and therefore there must be no cycles within the tree,
+--   and no cycles between trees in the forest.
+--
+-- /NOTE/: An 'NgramsForest' and a 'GeneralisedNgramsTree' are essentially isomorphic to the \"Tree\"
+-- and \"Forest\" types from the \"containers\" library, but our version allows storing both a label and
+-- a value for each node.
+newtype NgramsForest =
+  NgramsForest { getNgramsForest :: [NgramsTree] }
+  deriving (Show, Eq, Ord)
+
+type NgramsTree = GeneralisedNgramsTree Text Int
 
-data NgramsTree = NgramsTree { mt_label :: Text
-                             , mt_value :: Double
-                             , mt_children :: [NgramsTree]
+-- | Models a general ngram tree polymorphic over a label 'l' and a measure 'm'.
+data GeneralisedNgramsTree l m =
+  GeneralisedNgramsTree { mt_label    :: l
+                        , mt_value    :: m
+                        , mt_children :: [GeneralisedNgramsTree l m]
                         }
-    deriving (Generic, Show, Eq)
+    deriving (Generic, Show, Eq, Ord)
 
-toNgramsTree :: Tree (NgramsTerm,Double) -> NgramsTree
-toNgramsTree (Node (NgramsTerm l,v) xs) = NgramsTree l v (map toNgramsTree xs)
+instance (ToJSON l, ToJSON m) => ToJSON (GeneralisedNgramsTree l m) where
+  toJSON (GeneralisedNgramsTree l m children) =
+    object [ "label"    .= toJSON l
+           , "value"    .= toJSON m
+           , "children" .= toJSON children
+           ]
 
-deriveJSON (unPrefix "mt_") ''NgramsTree
+instance (FromJSON l, FromJSON m) => FromJSON (GeneralisedNgramsTree l m) where
+  parseJSON = withObject "NgramsTree" $ \o -> do
+    mt_label    <- o .: "label"
+    mt_value    <- o .: "value"
+    mt_children <- o .: "children"
+    pure $ GeneralisedNgramsTree{..}
 
 instance ToSchema NgramsTree where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
 instance Arbitrary NgramsTree
   where
-    arbitrary = NgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
+    arbitrary = GeneralisedNgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
+
+--
+-- Constructing trees and forests
+--
+
+-- | Given a 'Tree' from the \"containers\" library that has an 'NgramsTerm' and a score at the leaves,
+-- converts it into a gargantext 'NgramsTree' tree.
+toNgramsTree :: Tree (NgramsTerm,Int) -> NgramsTree
+toNgramsTree (Node (NgramsTerm l,v) xs) = GeneralisedNgramsTree l v (map toNgramsTree xs)
 
-toTree :: ListType
+-- | Given a 'ListType', which informs which category of terms we want to focus on (stop, map, candidate)
+-- and two hashmaps mapping an 'NgramsTerm' to their values, builds an 'NgramsForest'.
+toNgramsForest :: ListType
                -> HashMap NgramsTerm (Set NodeId)
                -> HashMap NgramsTerm NgramsRepoElement
-       -> [NgramsTree]
-toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots
+               -> NgramsForest
+toNgramsForest lt vs m = NgramsForest $ map toNgramsTree $ unfoldForest buildNode roots
   where
     buildNode r = maybe ((r, value r),[])
                         (\x -> ((r, value r), mSetToList $ _nre_children x))
                         (HashMap.lookup r m)
 
-    value l = maybe 0 (fromIntegral . Set.size) $ HashMap.lookup l vs
+    value l = maybe 0 Set.size $ HashMap.lookup l vs
 
     rootsCandidates :: [NgramsTerm]
     rootsCandidates = catMaybes

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

@@ -28,11 +28,12 @@ import Gargantext.API.Node.Corpus.Export.Types ( Corpus(..), CorpusSQLite(..) )
 import Gargantext.API.Node.Corpus.Export.Utils (getContextNgrams, mkCorpusSQLite, mkCorpusSQLiteData)
 import Gargantext.API.Node.Document.Export.Types qualified as DocumentExport
 import Gargantext.API.Prelude (IsGargServer)
+import Gargantext.API.Routes.Named.Corpus qualified as Named
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Core.Types.Main ( ListType(MapTerm) )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) )
-import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Admin.Types.Node (Context, CorpusId, ListId, context2node, nodeId2ContextId)
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node ( defaultList )
 import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
@@ -41,7 +42,6 @@ import Gargantext.Prelude hiding (hash)
 import Gargantext.Prelude.Crypto.Hash (hash)
 import Servant (Headers, Header, addHeader)
 import Servant.Server.Generic (AsServerT)
-import qualified Gargantext.API.Routes.Named.Corpus as Named
 
 --------------------------------------------------
 -- | Hashes are ordered by Set

src/Gargantext/API/Node/Corpus/Export/Types.hs

@@ -87,3 +87,4 @@ data CorpusSQLiteData =
                    , _csd_stop_context_ngrams      :: Map ContextId (Set NgramsTerm)
                    , _csd_candidate_context_ngrams :: Map ContextId (Set NgramsTerm)
                    } deriving (Show, Eq, Generic)
+

src/Gargantext/API/Node/Corpus/Export/Utils.hs

@@ -141,7 +141,9 @@ mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpa
     S.withConnection fpath $ \conn -> do
       -- better performance
       -- https://kerkour.com/sqlite-for-servers
-      S.execute_ conn "PRAGMA journal_mode = WAL"
+      S.execute_ conn "PRAGMA journal_mode = WAL"    -- overall, a good idea for sqlite
+      S.execute_ conn "PRAGMA synchronous = NORMAL"  -- faster writes
+      S.execute_ conn "PRAGMA cache_size = 1000000"  -- better memory usage
 
       S.execute_ conn "CREATE TABLE info (key, value);"
       S.execute conn "INSERT INTO info (key, value) VALUES ('gargVersion', ?)" (S.Only $ showVersion _csd_version)
@@ -179,6 +181,10 @@ mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpa
                                                       , iso8601Show ctxDate
                                                       , Aeson.encode ctxHyperdata )) <$> _csd_contexts)
 
+      -- Force WAL checkpoint so we don't leave any data in the WAL log
+      -- (we only send the sqlite file, while WAL creates additional index files which would not be sent)
+      S.execute_ conn "PRAGMA wal_checkpoint(FULL)"
+
     bsl <- BSL.readFile fpath
 
     pure $ CorpusSQLite { _cs_bs = bsl }

src/Gargantext/API/Node/ShareURL.hs

@@ -10,7 +10,7 @@ import Data.Validity qualified as V
 import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.API.Routes.Named.Share qualified as Named
 import Gargantext.Core.Config (GargConfig, gc_frontend_config, HasConfig(hasConfig))
-import Gargantext.Core.Config.Types (fc_appPort, fc_url)
+import Gargantext.Core.Config.Types (getPublicUrl)
 import Gargantext.Core.Types (NodeType, NodeId, unNodeId, _ValidationError)
 import Gargantext.Database.Prelude (IsDBEnvExtra)
 import Gargantext.Prelude
@@ -37,18 +37,21 @@ get_url :: Maybe NodeType
         -> GargConfig
         -> Either String Named.ShareLink
 get_url nt id gc = do
-  let urlHost = T.unpack $ gc ^. gc_frontend_config . fc_url
-  let urlPort = gc ^. gc_frontend_config . fc_appPort
+  let fc = gc ^. gc_frontend_config
+  -- let urlHost = T.unpack $ gc ^. gc_frontend_config . fc_url
+  -- let urlPort = gc ^. gc_frontend_config . fc_appPort
   t <- maybe (Left "Invalid node Type") Right nt
   i <- maybe (Left "Invalid node ID")   Right id
 
+  let sharePart = "/#/share/" <> show t <> "/" <> show (unNodeId i)
+
   -- Include the port the server is running on if this is
   -- localhost, so that share URLs would work out of the box.
-  let !rawURL
-        | "localhost" `isInfixOf` urlHost
-        = urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
-        | otherwise
-        = urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
+  let !rawURL = T.unpack $ (getPublicUrl fc) <> sharePart
+        -- | "localhost" `isInfixOf` urlHost
+        -- = urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
+        -- | otherwise
+        -- = urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
   maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'")
         (Right . Named.ShareLink)
         (parseURI rawURL)

src/Gargantext/API/Server/Named.hs

@@ -16,7 +16,7 @@ import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Admin.FrontEnd (frontEndServer)
 import Gargantext.API.Auth.PolicyCheck ()
 import Gargantext.API.Errors
-import Gargantext.API.GraphQL as GraphQL
+import Gargantext.API.GraphQL as GraphQL ( GraphQLAPI, api )
 import Gargantext.API.Prelude (GargM)
 import Gargantext.API.Routes.Named
 import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
@@ -24,7 +24,7 @@ import Gargantext.API.Swagger (openApiDoc)
 import Gargantext.API.ThrowAll (serverPrivateGargAPI)
 import Gargantext.Core.Notifications.Dispatcher.WebSocket qualified as Dispatcher
 import Gargantext.Core.Config (gc_frontend_config, hasConfig)
-import Gargantext.Core.Config.Types (fc_url_backend_api)
+import Gargantext.Core.Config.Types (fc_directory, fc_external_url)
 import Gargantext.Prelude hiding (Handler, catch)
 import Gargantext.System.Logging (logLocM, LogLevel(..))
 import Paths_gargantext qualified as PG -- cabal magic build module
@@ -40,7 +40,7 @@ serverGargAPI env
             , gargForgotPasswordAsyncAPI = forgotPasswordAsync
             , gargVersionAPI             = gargVersion
             , gargPrivateAPI             = serverPrivateGargAPI
-            , gargPublicAPI              = serverPublicGargAPI (env ^. hasConfig . gc_frontend_config . fc_url_backend_api)
+            , gargPublicAPI              = serverPublicGargAPI (env ^. hasConfig . gc_frontend_config . fc_external_url)
             }
   where
     gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError))
@@ -66,7 +66,7 @@ server env =
                        -- (Proxy :: Proxy AuthContext)
                        (transformJSON errScheme)
                        Dispatcher.wsServer
-     , frontendAPI = frontEndServer
+     , frontendAPI = frontEndServer (env ^. hasConfig . gc_frontend_config . fc_directory)
      }
   where
     transformJSON :: forall a. GargErrorScheme -> GargM Env BackendInternalError a -> Handler a

src/Gargantext/API/Server/Named/Private.hs

@@ -9,7 +9,7 @@ import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Members (members)
 import Gargantext.API.Ngrams.List qualified as List
 import Gargantext.API.Node (annuaireNodeAPI, corpusNodeAPI, nodeAPI, nodeNodeAPI, nodesAPI, roots)
-import Gargantext.API.Node.Contact as Contact
+import Gargantext.API.Node.Contact as Contact ( contactAPI )
 import Gargantext.API.Node.Corpus.Export qualified as CorpusExport
 import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus
 import Gargantext.API.Node.Document.Export (documentExportAPI)
@@ -19,7 +19,7 @@ import Gargantext.API.Node.ShareURL ( shareURL )
 import Gargantext.API.Prelude (GargM)
 import Gargantext.API.Routes (addWithTempFileApi, addCorpusWithQuery)
 import Gargantext.API.Routes.Named.Private qualified as Named
-import Gargantext.API.Server.Named.Ngrams
+import Gargantext.API.Server.Named.Ngrams ( apiNgramsTableDoc )
 import Gargantext.API.Server.Named.Viz qualified as Viz
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny)

src/Gargantext/API/Server/Named/Public.hs

@@ -4,9 +4,9 @@ module Gargantext.API.Server.Named.Public (
   ) where
 
 import Control.Lens ((^?), _Just)
-import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
+import Data.Text qualified as T
 import Gargantext.API.Node.File (fileApi)
 import Gargantext.API.Prelude (serverError, IsGargServer)
 import Gargantext.API.Public.Types (PublicData(..))
@@ -22,29 +22,30 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Table.NodeNode (selectPublicNodes)
 import Gargantext.Database.Schema.Node ( NodePoly(..), node_date, node_hyperdata ) -- (NodePoly(..))
 import Gargantext.Prelude
-import Servant
+import Servant ( ServerError(errBody), err405 )
+import Servant.Client.Core.BaseUrl (BaseUrl(..), showBaseUrl)
 import Servant.Server.Generic (AsServerT)
 
-serverPublicGargAPI :: IsGargServer env err m => Text -> Named.GargPublicAPI (AsServerT m)
+serverPublicGargAPI :: IsGargServer env err m => BaseUrl -> Named.GargPublicAPI (AsServerT m)
 serverPublicGargAPI baseUrl = Named.GargPublicAPI $
   Named.GargPublicAPI'
-    { publicHomeAPI = api_home baseUrl
-    , publicNodeAPI = Named.NodeAPI api_node
+    { publicHomeAPI = apiHome baseUrl
+    , publicNodeAPI = Named.NodeAPI apiNode
     }
 
-api_home :: IsGargServer env err m => Text -> Named.HomeAPI (AsServerT m)
-api_home baseUrl = Named.HomeAPI $ runDBQuery $ catMaybes
+apiHome :: IsGargServer env err m => BaseUrl -> Named.HomeAPI (AsServerT m)
+apiHome baseUrl = Named.HomeAPI $ runDBQuery $ catMaybes
    <$> map (toPublicData baseUrl)
    <$> filterPublicDatas
    <$> selectPublic
 
-api_node :: IsGargServer env err m => NodeId -> Named.FileAPI (AsServerT m)
-api_node nId = Named.FileAPI $ do
+apiNode :: IsGargServer env err m => NodeId -> Named.FileAPI (AsServerT m)
+apiNode nId = Named.FileAPI $ do
   pubNodes <- runDBQuery publicNodes
   -- TODO optimize with SQL
-  case Set.member nId pubNodes of
-    False -> serverError $ err405 { errBody = "Not allowed" }
-    True  -> fileApi nId
+  (if Set.member nId pubNodes
+   then fileApi nId
+   else serverError $ err405 { errBody = "Not allowed" })
 
 -------------------------------------------------------------------------
 
@@ -61,7 +62,7 @@ filterPublicDatas :: [(Node HyperdataFolder, Maybe Int)]
 filterPublicDatas datas =
   map (\(n,mi) ->
           let mi' = UnsafeMkNodeId <$> mi in
-                  ( _node_id n, (n, maybe [] (:[]) mi' ))
+                  ( _node_id n, (n, maybeToList mi' ))
       ) datas
       & Map.fromListWith (\(n1,i1) (_n2,i2) -> (n1, i1 <> i2))
       & Map.filter (not . null . snd)
@@ -72,28 +73,29 @@ publicNodes :: HasNodeError err
 publicNodes = do
   candidates <- filterPublicDatas <$> selectPublicNodes
   pure $ Set.fromList
-       $ List.concat
-       $ map (\(n, ns) -> (_node_id n) : ns) candidates
+       $ concatMap (\(n, ns) -> _node_id n : ns) candidates
 
 
 -- http://localhost:8008/api/v1.0/node/23543/file/download<Paste>
 -- http://localhost:8000/images/Gargantextuel-212x300.jpg
-toPublicData :: Text -> (Node HyperdataFolder, [NodeId]) -> Maybe PublicData
-toPublicData base (n , mn) = do
-  title <- (hd ^? (_Just . hf_data . cf_title))
-  abstract <- (hd ^? (_Just . hf_data . cf_desc ))
-  img <- (Just $ url' mn) -- "images/Gargantextuel-212x300.jpg"
-  url <- (Just $ url' mn)
+toPublicData :: BaseUrl -> (Node HyperdataFolder, [NodeId]) -> Maybe PublicData
+toPublicData baseUrl (n , mn) = do
+  title <- hd ^? (_Just . hf_data . cf_title)
+  abstract <- hd ^? (_Just . hf_data . cf_desc )
+  img <- Just $ url' mn -- "images/Gargantextuel-212x300.jpg"
+  url <- Just $ url' mn
   date <- Just (show $ utc2year (n^.node_date))
-  database <- (hd ^? (_Just . hf_data . cf_query))
-  author <- (hd ^? (_Just . hf_data . cf_authors))
+  database <- hd ^? (_Just . hf_data . cf_query)
+  author <- hd ^? (_Just . hf_data . cf_authors)
   pure $ PublicData { .. }
   where
     hd = head
        $ filter (\(HyperdataField cd _ _) -> cd == JSON)
        $ n^. (node_hyperdata . hc_fields)
-    url' :: [NodeId] -> Text
-    url' mn' = base
+    path :: [NodeId] -> Text
+    path mn' = "/api/v1.0"
            <>   "/public/"
-           <> (show $ (maybe 0 unNodeId $ head mn'))
+           <> show (maybe 0 unNodeId (head mn'))
            <> "/file/download"
+    url' :: [NodeId] -> Text
+    url' mn' = T.pack $ showBaseUrl $ baseUrl { baseUrlPath = T.unpack $ path mn' }

src/Gargantext/API/Server/Named/Remote.hs

@@ -38,7 +38,7 @@ import Gargantext.API.Errors.Types
 import Gargantext.API.Ngrams.Prelude (getNgramsList)
 import Gargantext.API.Ngrams.Types (NgramsList)
 import Gargantext.API.Node.Document.Export (get_document_json)
-import Gargantext.API.Node.Document.Export.Types
+import Gargantext.API.Node.Document.Export.Types ( DocumentExport(_de_documents) )
 import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.API.Routes.Client (remoteImportClient)
 import Gargantext.API.Routes.Named.Remote qualified as Named

src/Gargantext/Core/Config.hs

@@ -53,7 +53,7 @@ import Gargantext.Core.Config.Worker (WorkerSettings)
 import Gargantext.Prelude
 import Network.HTTP.Client qualified as HTTP
 import Servant.Auth.Server (JWTSettings)
-import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
+import Servant.Client (BaseUrl(..))
 import Toml.Schema
 import Toml.Schema.FromValue (typeError)
 
@@ -142,10 +142,8 @@ instance ToTable GargConfig where
 
 
 mkProxyUrl :: GargConfig -> BaseUrl
-mkProxyUrl GargConfig{..} =
-  case parseBaseUrl (T.unpack $ _fc_url _gc_frontend_config) of
-    Nothing -> BaseUrl Http "localhost" 80 ""
-    Just bh -> bh { baseUrlPort = _msProxyPort $ _fc_microservices _gc_frontend_config }
+mkProxyUrl GargConfig{ _gc_frontend_config = cfg } =
+  (_fc_external_url cfg) { baseUrlPort = _msProxyPort $ _fc_microservices cfg }
 
 
 class HasConfig env where

src/Gargantext/Core/Config/Types.hs

@@ -27,13 +27,14 @@ module Gargantext.Core.Config.Types
   , f_istex_url
   , PortNumber
   , FrontendConfig(..)
-  , fc_url
+  , fc_external_url
+  , fc_internal_url
   , fc_backend_name
-  , fc_url_backend_api
+  , fc_directory
   , fc_cors
   , fc_microservices
-  , fc_appPort
   , fc_cookie_settings
+  , getPublicUrl
   , defaultCookieSettings
   , MicroServicesProxyStatus(..)
   , microServicesProxyStatus
@@ -63,7 +64,7 @@ import Database.PostgreSQL.Simple qualified as PGS
 import Gargantext.Prelude
 import Servant.Auth.Server (CookieSettings(..), JWTSettings, XsrfCookieSettings(..), defaultJWTSettings, readKey, writeKey)
 import Servant.Auth.Server qualified as SAuth
-import Servant.Client.Core (BaseUrl, parseBaseUrl, showBaseUrl)
+import Servant.Client.Core (BaseUrl(..), parseBaseUrl, showBaseUrl)
 import System.Directory (doesFileExist)
 import Toml
 import Toml.Schema
@@ -199,35 +200,49 @@ defaultCookieSettings = SAuth.defaultCookieSettings { cookieXsrfSetting = Just x
 
 -- TODO jwtSettings = defaultJWTSettings
 data FrontendConfig =
-  FrontendConfig { _fc_url             :: !Text
+  FrontendConfig { _fc_external_url    :: !BaseUrl
+                 , _fc_internal_url    :: !BaseUrl
+                 , _fc_directory       :: !FilePath
                  , _fc_backend_name    :: !Text
-                 , _fc_url_backend_api :: !Text
                  , _fc_cors            :: !CORSSettings
                  , _fc_microservices   :: !MicroServicesSettings
-                 , _fc_appPort         :: !PortNumber
                  , _fc_cookie_settings :: !CookieSettings
                }
   deriving (Generic, Show)
 instance FromValue FrontendConfig where
   fromValue = parseTableFromValue $ do
-    _fc_url <- reqKey "url"
+    _fc_external_url_txt <- reqKey "external_url"
+    _fc_external_url <-
+      case parseBaseUrl (T.unpack _fc_external_url_txt) of
+        Nothing -> fail "cannot parse fc_external_url"
+        Just b -> pure b
+    _fc_internal_url_txt <- reqKey "internal_url"
+    _fc_internal_url <-
+      case parseBaseUrl (T.unpack _fc_internal_url_txt) of
+        Nothing -> fail "cannot parse fc_internal_url"
+        Just b -> pure b
+    _fc_directory <- reqKey "directory"
     _fc_backend_name <- reqKey "backend_name"
-    _fc_url_backend_api <- reqKey "url_backend_api"
     _fc_cors <- reqKey "cors"
     _fc_microservices <- reqKey "microservices"
-    let _fc_appPort = 3000
+    
     return $ FrontendConfig { _fc_cookie_settings = defaultCookieSettings, .. }
 instance ToValue FrontendConfig where
   toValue = defaultTableToValue
 instance ToTable FrontendConfig where
-  toTable (FrontendConfig { .. }) = table [ "url" .= _fc_url
+  toTable (FrontendConfig { .. }) = table
+      [ "external_url" .= (T.pack $ showBaseUrl _fc_external_url)
+      , "internal_url" .= (T.pack $ showBaseUrl _fc_internal_url)
+      , "directory"    .= _fc_directory
       , "backend_name" .= _fc_backend_name
-                                          , "url_backend_api" .= _fc_url_backend_api
       , "cors" .= _fc_cors
       , "microservices" .= _fc_microservices ]
 
 makeLenses ''FrontendConfig
 
+getPublicUrl :: FrontendConfig -> Text
+getPublicUrl (FrontendConfig { .. }) = T.pack $ showBaseUrl _fc_external_url
+
 data MicroServicesProxyStatus
   = PXY_enabled PortNumber
   | PXY_disabled

src/Gargantext/Core/Mail.hs

@@ -16,7 +16,7 @@ import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.List qualified as List
 import Data.Text (splitOn)
 import Gargantext.Core.Config (gc_frontend_config, HasConfig(..))
-import Gargantext.Core.Config.Types (fc_url, fc_backend_name)
+import Gargantext.Core.Config.Types (fc_backend_name, getPublicUrl)
 import Gargantext.Core.Config.Mail (gargMail, GargMail(..), MailConfig)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Schema.User (UserLight(..))
@@ -75,7 +75,7 @@ mail mailCfg model = do
     (m,u)   = email_to         model
     subject = email_subject    model
     body    = emailWith (ServerAddress (view (gc_frontend_config . fc_backend_name) cfg)
-                                       (view (gc_frontend_config . fc_url) cfg)) model
+                                       (getPublicUrl $ view gc_frontend_config cfg)) model
   liftBase $ gargMail mailCfg (GargMail { gm_to = m
                                         , gm_name = Just u
                                         , gm_subject = subject

src/Gargantext/Core/NodeStory.hs

@@ -43,27 +43,31 @@ TODO:
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Gargantext.Core.NodeStory
   ( module Gargantext.Core.NodeStory.Types
   , getNodesArchiveHistory
   , Archive(..)
+  , ArchiveStateForest
   , nodeExists
   , getNodesIdWithType
   , mkNodeStoryEnv
   , upsertNodeStories
-  -- , getNodeStory
   , getNodeStory'
   , nodeStoriesQuery
   , currentVersion
   , archiveStateFromList
   , archiveStateToList
   , fixNodeStoryVersions
-  , fixChildrenDuplicatedAsParents
-  , getParentsChildren )
-where
-
-import Control.Lens ((%~), non, _Just, at, over)
+  , getParentsChildren
+  -- * Operations on trees and forests
+  , buildForest
+  , pruneForest
+  ) where
+
+import Control.Lens ((%~), non, _Just, at, over, Lens')
+import Data.ListZipper
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Database.PostgreSQL.Simple qualified as PGS
@@ -77,6 +81,73 @@ import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Prelude
 import Gargantext.Prelude hiding (to)
+import Data.Tree
+
+class HasNgramChildren e where
+  ngramsElementChildren :: Lens' e (MSet NgramsTerm)
+
+instance HasNgramChildren NgramsRepoElement where
+  ngramsElementChildren = nre_children
+
+instance HasNgramChildren NgramsElement where
+  ngramsElementChildren = ne_children
+
+class HasNgramParent e where
+  ngramsElementParent :: Lens' e (Maybe NgramsTerm)
+
+instance HasNgramParent NgramsRepoElement where
+  ngramsElementParent = nre_parent
+
+instance HasNgramParent NgramsElement where
+  ngramsElementParent = ne_parent
+
+-- | A 'Forest' (i.e. a list of trees) that models a hierarchy of ngrams terms, possibly grouped in
+-- a nested fashion, all wrapped in a 'Zipper'. Why using a 'Zipper'? Because when traversing the
+-- forest (for example to fix the children in case of dangling imports) we need sometimes to search
+-- things into the forest, but crucially we do not want to search also inside the tree we are
+-- currently iterating on! A zipper gives exactly that, i.e. a way to \"focus\" only on a particular
+-- piece of a data structure.
+type ArchiveStateForest = ListZipper (Tree (NgramsTerm, NgramsRepoElement))
+
+buildForestsFromArchiveState :: NgramsState' -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
+buildForestsFromArchiveState = Map.map buildForest
+
+destroyArchiveStateForest :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement)) -> NgramsState'
+destroyArchiveStateForest = Map.map destroyForest
+
+-- | Builds an ngrams forest from the input ngrams table map.
+buildForest :: forall e. HasNgramChildren e => Map NgramsTerm e -> Forest (NgramsTerm, e)
+buildForest mp = unfoldForest mkTreeNode (Map.toList mp)
+  where
+    mkTreeNode :: (NgramsTerm, e) -> ((NgramsTerm, e), [(NgramsTerm, e)])
+    mkTreeNode (k, el) = ((k, el), mapMaybe findChildren $ mSetToList (el ^. ngramsElementChildren))
+
+    findChildren :: NgramsTerm -> Maybe (NgramsTerm, e)
+    findChildren t = Map.lookup t mp <&> \el -> (t, el)
+
+-- | Folds an Ngrams forest back to a table map.
+-- This function doesn't aggregate information, but merely just recostructs the original
+-- map without loss of information. To perform operations on the forest, use the appropriate
+-- functions.
+destroyForest :: Forest (NgramsTerm, NgramsRepoElement) -> Map NgramsTerm NgramsRepoElement
+destroyForest f = Map.fromList . map (foldTree destroyTree) $ f
+  where
+    destroyTree :: (NgramsTerm, NgramsRepoElement)
+                -> [(NgramsTerm, NgramsRepoElement)]
+                -> (NgramsTerm, NgramsRepoElement)
+    destroyTree (k, rootEl) childrenEl = (k, squashElements rootEl childrenEl)
+
+    squashElements :: e -> [(NgramsTerm, e)] -> e
+    squashElements r _ = r
+
+-- | Prunes the input 'Forest' of 'NgramsElement' by keeping only the roots, i.e. the
+-- nodes which has no children /AND/ they do not appear in any other 'children' relationship.
+-- /NOTE ON IMPLEMENTATION:/ The fast way to do this is to simply filter each tree, ensuring
+-- that we keep only trees which root has no parent or root (i.e. it's a root itself!) and this
+-- will work only under the assumption that the input 'Forest' has been built correctly, i.e.
+-- with the correct relationships specified, or this will break.
+pruneForest :: HasNgramParent e => Forest e -> Forest e
+pruneForest = filter (\(Node r _) -> isNothing (r ^. ngramsElementParent))
 
 
 getNodeStory' :: NodeId -> DBQuery err x ArchiveList
@@ -94,15 +165,6 @@ getNodeStory' nId = do
    -- `node_id`, `version` and there is a M2M table
    -- `node_stories_ngrams` without the `version` colum? Then we would
    -- have `version` in only one place.
-
-{-
-  let versionsS = Set.fromList $ map (\a -> a ^. a_version) dbData
-  if Set.size versionsS > 1 then
-    panic $ Text.pack $ "[getNodeStory] versions for " <> show nodeId <> " differ! " <> show versionsS
-  else
-    pure ()
--}
-
   pure $ foldl' combine initArchive dbData
   where
     -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
@@ -174,16 +236,7 @@ updateNodeStory nodeId currentArchive newArchive = do
   --printDebug "[updateNodeStory] delete applied" ()
   updateArchiveStateList nodeId (newArchive ^. a_version) updates
   --printDebug "[updateNodeStory] update applied" ()
-
   pure ()
-  -- where
-  --   update = Update { uTable      = nodeStoryTable
-  --                   , uUpdateWith = updateEasy (\(NodeStoryDB { node_id }) ->
-  --                                                 NodeStoryDB { archive = sqlValueJSONB $ Archive { _a_history = emptyHistory
-  --                                                                                                                               , ..}
-  --                                                                                           , .. })
-  --                   , uWhere      = (\row -> node_id row .== sqlInt4 nId)
-  --                   , uReturning  = rCount }
 
 upsertNodeStories :: NodeId -> ArchiveList -> DBUpdate err ()
 upsertNodeStories nodeId newArchive = do
@@ -191,12 +244,10 @@ upsertNodeStories nodeId newArchive = do
   -- printDebug "[upsertNodeStories] locking nId" nId
   (NodeStory m) <- getNodeStory nodeId
   case Map.lookup nodeId m of
-    Nothing -> do
-      _ <- insertNodeStory nodeId newArchive
-      pure ()
-    Just currentArchive  -> do
-      _ <- updateNodeStory nodeId currentArchive newArchive
-      pure ()
+    Nothing ->
+      void $ insertNodeStory nodeId newArchive
+    Just currentArchive ->
+      void $ updateNodeStory nodeId currentArchive newArchive
 
   -- 3. Now we need to set versions of all node state to be the same
   updateNodeStoryVersion nodeId newArchive
@@ -216,8 +267,9 @@ nodeStoryInc 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.
-fixChildrenInNgrams :: NgramsState' -> NgramsState'
-fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
+-- NOTE(adn) Currently unused, see !424 for context.
+_fixChildrenInNgrams :: NgramsState' -> NgramsState'
+_fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
   where
     (nsParents, nsChildren) = getParentsChildren ns
     parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents
@@ -233,29 +285,56 @@ fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
 -- | (#281) 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'.
-fixChildrenWithNoParent :: NgramsState' -> NgramsState'
-fixChildrenWithNoParent ns = archiveStateFromList $ nsParents <> nsChildrenFixed
-  where
-    (nsParents, nsChildren) = getParentsChildren ns
-    parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
-
-    nsChildrenFixFunc (nt, t, nre) =
-      ( nt
-      , t
-      , nre { _nre_root = root
-            , _nre_parent = parent }
-      )
+fixChildrenWithNoParent :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
+                        -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
+fixChildrenWithNoParent = Map.map go
   where
-        (root, parent) = case parentNtMap ^. at (nre ^. nre_parent . _Just) . _Just . at t of
-          Just _ -> (nre ^. nre_root, nre ^. nre_parent)
-          Nothing -> (Nothing, Nothing)
-
-    nsChildrenFixed = nsChildrenFixFunc <$> nsChildren
+    -- If the forest is somehow empty, do nothing. Otherwise, build a zipper and run
+    -- the algorithm.
+    go :: Forest (NgramsTerm, NgramsRepoElement)
+       -> Forest (NgramsTerm, NgramsRepoElement)
+    go fs = case zipper fs of
+      Nothing  -> fs
+      Just zfs -> maybe mempty toList $ execListZipperOp fixDanglingChildrenInForest zfs
+
+    fixDanglingChildrenInForest :: ListZipperOp (Tree (NgramsTerm, NgramsRepoElement)) ()
+    fixDanglingChildrenInForest = do
+      z@(ListZipper l a r) <- get
+      when (isOrphan (l <> r) a) $ void $ modifyFocus detachFromParent
+      unless (atEnd z) $ do
+        moveRight
+        fixDanglingChildrenInForest
+
+    detachFromParent :: Tree (NgramsTerm, NgramsRepoElement) -> Tree (NgramsTerm, NgramsRepoElement)
+    detachFromParent (Node (k,v) el) = Node (k, v & nre_root   .~ Nothing & nre_parent .~ Nothing) el
+
+    isOrphan :: Forest (NgramsTerm, NgramsRepoElement)
+             -- ^ The rest of the forest, i.e. the list of trees
+             -- except the input one.
+             -> Tree (NgramsTerm, NgramsRepoElement)
+             -- ^ The tree we are currently focusing.
+             -> Bool
+             -- ^ True if the root of the tree refers to
+             -- a node that is not listed as any children of
+             -- the subtrees, and yet it has a non-null parent
+             -- or root.
+    isOrphan restOfTheForest (Node (k,v) _) =
+      (isJust (_nre_parent v) || isJust (_nre_root v)) &&
+      not (isChildInForest (k,v) restOfTheForest)
+
+    -- | Returns 'True' if the input child can be found in the tree.
+    isChildInForest :: Eq e => e -> Forest e -> Bool
+    isChildInForest _ []     = False
+    isChildInForest e (x:xs) =
+      case e == rootLabel x of
+        True  -> True
+        False -> isChildInForest e (subForest x) || isChildInForest e xs
 
 -- | 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
+-- NOTE(adn) Currently unused, see !424 for context.
+_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
@@ -280,34 +359,18 @@ getParentsChildren ns = (nsParents, nsChildren)
 
 mkNodeStoryEnv :: NodeStoryEnv err
 mkNodeStoryEnv = do
-  -- tvar <- nodeStoryVar pool Nothing []
   let saver_immediate nId a = do
-        -- ns <- atomically $
-        --       readTVar tvar
-        --       -- fix children so their 'list' is the same as their parents'
-        --       >>= pure . fixChildrenTermTypes
-        --       -- fix children that don't have a parent anymore
-        --       >>= pure . fixChildrenWithNoParent
-        --       >>= writeTVar tvar
-        --       >> readTVar tvar
-        --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 nId $
           a & a_state %~ (
-                     fixChildrenDuplicatedAsParents
-                  .  fixChildrenInNgrams
+                    destroyArchiveStateForest
                   . fixChildrenWithNoParent
+                  . buildForestsFromArchiveState
                   )
   let archive_saver_immediate nId a = do
         insertNodeArchiveHistory nId (a ^. a_version) $ reverse $ a ^. a_history
         pure $ a & a_history .~ []
-        -- mapM_ (\(nId, a) -> do
-        --           insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
-        --       ) $ Map.toList nls
-        -- pure $ clearHistory ns
 
   NodeStoryEnv { _nse_saver = saver_immediate
                , _nse_archive_saver = archive_saver_immediate
@@ -355,72 +418,3 @@ fixNodeStoryVersions = runDBTx $ do
         [PGS.Only (Just maxVersion)] -> do
           void $ mkPGUpdate updateVerQuery (maxVersion, nId, ngramsType)
         _ -> panicTrace "Should get only 1 result!"
-
------------------------------------------
-
--- DEPRECATED
-
-
--- nodeStoryVar :: Pool PGS.Connection
---              -> Maybe (TVar NodeListStory)
---              -> [NodeId]
---              -> IO (TVar NodeListStory)
--- nodeStoryVar pool Nothing nIds = do
---   state' <- withResource pool $ \c -> nodeStoryIncrementalRead c Nothing nIds
---   atomically $ newTVar state'
--- nodeStoryVar pool (Just tv) nIds = do
---   nls <- atomically $ readTVar tv
---   nls' <- withResource pool
---       $ \c -> nodeStoryIncrementalRead c (Just nls) nIds
---   _ <- atomically $ writeTVar tv nls'
---   pure tv
-
--- clearHistory :: NodeListStory -> NodeListStory
--- clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHistory
---   where
---     emptyHistory = [] :: [NgramsStatePatch']
-
-
--- fixChildrenWithNoParent :: NodeListStory -> NodeListStory
--- fixChildrenWithNoParent (NodeStory nls) =
---   NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenWithNoParentStatePatch)
---                            | (nId, a) <- Map.toList nls ]
-
-
--- fixChildrenTermTypes :: NodeListStory -> NodeListStory
--- fixChildrenTermTypes (NodeStory nls) =
---   NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenInNgramsStatePatch)
---                            | (nId, a) <- Map.toList nls ]
-
-
--- nodeStoryIncrementalRead :: PGS.Connection -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
--- nodeStoryIncrementalRead _ Nothing [] = pure $ NodeStory Map.empty
--- nodeStoryIncrementalRead c Nothing (ni:ns) = do
---   m <- getNodeStory c ni
---   nodeStoryIncrementalRead c (Just m) ns
--- nodeStoryIncrementalRead c (Just nls) ns = foldM (\m n -> nodeStoryInc c m n) nls ns
-
--- nodeStoryDec :: Pool PGS.Connection -> NodeListStory -> NodeId -> IO NodeListStory
--- nodeStoryDec pool ns@(NodeStory nls) ni = do
---   case Map.lookup ni nls of
---     Nothing -> do
---       _ <- nodeStoryRemove pool ni
---       pure ns
---     Just _ -> do
---       let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
---       _ <- nodeStoryRemove pool ni
---       pure $ NodeStory ns'
-------------------------------------
-
-
--- writeNodeStories :: PGS.Connection -> NodeListStory -> IO ()
--- writeNodeStories c (NodeStory nls) = do
---   mapM_ (\(nId, a) -> upsertNodeStories c nId a) $ Map.toList nls
-
-
--- nodeStoryRemove :: Pool PGS.Connection -> NodeId -> IO Int64
--- nodeStoryRemove pool (NodeId nId) = withResource pool $ \c -> runDelete c delete
---   where
---     delete = Delete { dTable     = nodeStoryTable
---                     , dWhere     = (\row -> node_id row .== sqlInt4 nId)
---                     , dReturning = rCount }

src/Gargantext/Core/Text/Corpus/API/OpenAlex.hs

@@ -28,8 +28,14 @@ get :: Text
     -> IO (Either ClientError (Maybe Integer, ConduitT () HyperdataDocument IO ()))
 get _email q lang mLimit = do
   let limit = getLimit $ fromMaybe 1000 mLimit
-  let mFilter = (\l -> "language:" <> iso639ToText l) <$> lang
-  eRes <- OA.fetchWorksC Nothing mFilter $ Just $ Corpus.getRawQuery q
+  let filters =
+        [
+          -- see https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/490
+          -- see https://openalex.org/works?page=1&filter=title_and_abstract.search:brain:hawai
+          Just ("title_and_abstract.search:" <> Corpus.getRawQuery q)
+        , (\l -> "language:" <> iso639ToText l) <$> lang
+        ]
+  eRes <- OA.fetchWorksC Nothing (Just $ T.intercalate "," $ catMaybes filters) Nothing
   pure $ (\(len, docsC) -> (len, docsC .| takeC limit .| mapC toDoc)) <$> eRes
 
 toDoc :: OA.Work -> HyperdataDocument

src/Gargantext/Core/Viz/Chart.hs

@@ -17,7 +17,7 @@ import Data.List qualified as List
 import Data.Map.Strict (toList)
 import Data.Set qualified as Set
 import Data.Vector qualified as V
-import Gargantext.API.Ngrams.NgramsTree ( toTree, NgramsTree )
+import Gargantext.API.Ngrams.NgramsTree ( toNgramsForest, NgramsTree, getNgramsForest )
 import Gargantext.API.Ngrams.Tools ( filterListWithRoot, getListNgrams, getRepo, mapTermListRoot )
 import Gargantext.API.Ngrams.Types ( NgramsTerm(NgramsTerm) )
 import Gargantext.Core.NodeStory.Types ( NodeStoryEnv )
@@ -91,4 +91,4 @@ treeData env cId nt lt = do
   cs' <- HashMap.map (Set.map contextId2NodeId) <$> getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms
 
   m  <- getListNgrams env ls nt
-  pure $ V.fromList $ toTree lt cs' m
+  pure $ V.fromList $ getNgramsForest $ toNgramsForest lt cs' m

stack.yaml

@@ -18,6 +18,7 @@
 - "data-default-0.8.0.0"
 - "data-default-class-0.2.0.0"
 - "deferred-folds-0.9.18.7"
+- "deriving-compat-0.6.7"
 - "entropy-0.4.1.11"
 - "file-embed-lzma-0.1"
 - "foldl-1.4.18"
@@ -38,6 +39,7 @@
 - "jose-0.10.0.1"
 - "language-c-0.10.0"
 - "linear-1.23"
+- "list-zipper-0.0.12"
 - "massiv-1.0.4.1"
 - "megaparsec-9.7.0"
 - "microlens-th-0.4.3.16"
@@ -367,7 +369,7 @@ flags:
   gargantext:
     "enable-benchmarks": false
     "no-phylo-debug-logs": true
-    "test-crypto": false
+    "test-crypto": true
   graphviz:
     "test-parsing": false
   hashable:
@@ -540,8 +542,6 @@ flags:
     transformers: true
   tasty:
     unix: true
-  "tasty-golden":
-    "build-example": false
   "text-format":
     developer: false
   "text-metrics":

test-data/test_config.toml

 [frontend]
-url = "http://localhost"
+external_url = "http://localhost"
+internal_url = "http://localhost"
+directory = "./purescript-gargantext/dist"
 backend_name = "localhost"
-url_backend_api = "http://localhost:8008/api/v1.0"
 jwt_settings = "TODO"
 
 [frontend.cors]

test/Test/API/Setup.hs

@@ -24,7 +24,7 @@ import Gargantext.API.Admin.EnvTypes (Env (..), env_dispatcher)
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.Config hiding (jwtSettings)
-import Gargantext.Core.Config.Types (fc_appPort, jwtSettings)
+import Gargantext.Core.Config.Types (jwtSettings, fc_external_url, fc_internal_url)
 import Gargantext.Core.Notifications (withNotifications)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.Flow
@@ -37,7 +37,7 @@ import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
 import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
-import Gargantext.Prelude hiding (catches, Handler)
+import Gargantext.Prelude hiding (catches, to, Handler)
 import Gargantext.System.Logging
 import Network.HTTP.Client.TLS (newTlsManager)
 import Network.HTTP.Types
@@ -48,6 +48,7 @@ import Network.Wai.Handler.Warp.Internal
 import Network.WebSockets qualified as WS
 import Prelude hiding (show)
 import Servant.Auth.Client ()
+import Servant.Client.Core (baseUrlPort)
 import Test.Database.Setup (withTestDB)
 import Test.Database.Types
 import UnliftIO qualified
@@ -72,7 +73,9 @@ newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port ->
 newTestEnv testEnv logger port = do
   !manager_env  <- newTlsManager
 
-  let config_env    = test_config testEnv & (gc_frontend_config . fc_appPort) .~ port
+  let config_env    = test_config testEnv
+                        & (gc_frontend_config . fc_external_url) %~ (\b -> b { baseUrlPort = port })
+                        & (gc_frontend_config . fc_internal_url) %~ (\b -> b { baseUrlPort = port })
   -- dbParam        <- pure $ testEnvToPgConnectionInfo testEnv
   -- !pool          <- newPool dbParam
 

test/Test/API/UpdateList.hs

@@ -27,23 +27,23 @@ module Test.API.UpdateList (
   , mkNewWithForm
   ) where
 
-import Control.Lens (mapped, over)
 import Control.Monad.Fail (fail)
 import Data.Aeson qualified as JSON
 import Data.Aeson.QQ
-import Data.Map.Strict.Patch qualified as PM
+import Data.ByteString.Lazy qualified as BL
 import Data.Map.Strict qualified as Map
-import Data.Set qualified as Set
-import Data.Text.IO qualified as TIO
+import Data.Map.Strict.Patch qualified as PM
+import Data.Patch.Class
 import Data.Text qualified as T
+import Data.Text.IO qualified as TIO
 import Fmt
 import Gargantext.API.Admin.Auth.Types (Token)
 import Gargantext.API.Errors
 import Gargantext.API.HashedResponse
+import Gargantext.API.Ngrams qualified as APINgrams
 import Gargantext.API.Ngrams.List ( ngramsListFromTSVData )
 import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..))
-import Gargantext.API.Ngrams qualified as APINgrams
-import Gargantext.API.Ngrams.Types
+import Gargantext.API.Ngrams.Types as NT
 import Gargantext.API.Node.Corpus.New.Types qualified as FType
 import Gargantext.API.Node.Types
 import Gargantext.API.Routes.Named
@@ -51,8 +51,8 @@ import Gargantext.API.Routes.Named.Corpus (addWithTempFileEp)
 import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.Private
 import Gargantext.API.Worker (workerAPIPost)
-import Gargantext.Core.Config
 import Gargantext.Core qualified as Lang
+import Gargantext.Core.Config
 import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
 import Gargantext.Core.Text.List.Social
 import Gargantext.Core.Text.Ngrams
@@ -64,7 +64,7 @@ import Gargantext.Database.Query.Facet qualified as Facet
 import Gargantext.Prelude hiding (get)
 import Network.Wai.Handler.Warp qualified as Wai
 import Paths_gargantext (getDataFileName)
-import qualified Prelude
+import Prelude qualified
 import Servant.Client.Streaming
 import System.FilePath
 import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser, alice)
@@ -108,6 +108,17 @@ uploadJSONList log_cfg port token cId pathToNgrams clientEnv = do
   
   pure listId
 
+-- | Compares the ngrams returned via the input IO action with the ones provided as
+-- the 'ByteString'. Use this function with the 'json' quasi quoter to pass directly
+-- a nicely-formatted JSON.
+checkNgrams :: IO (Either ClientError (VersionedWithCount NgramsTable))
+            -> BL.ByteString
+            -> WaiSession () ()
+checkNgrams rq expected = liftIO $ do
+  eng <- rq
+  case eng of
+    Left err -> fail (show err)
+    Right r -> Just r `shouldBe` JSON.decode expected
 
 
 tests :: Spec
@@ -141,53 +152,180 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
                                                        ]
                                                    } |]
 
+      it "does allow creating hierarchical grouping at least for level-2" $ \(SpecContext testEnv port app _) -> do
+        cId <- newCorpusForUser testEnv "alice"
+        withApplication app $ do
+          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
+            ([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
+            let newMapTerm = NgramsRepoElement {
+                             _nre_size = 1
+                           , _nre_list        = MapTerm
+                           , _nre_root        = Nothing
+                           , _nre_parent      = Nothing
+                           , _nre_children    = mempty
+                           }
+            let add_guitar_pedals =
+                  PM.fromList [
+                    ( "guitar pedals"
+                    , NgramsReplace { _patch_old = Nothing
+                                    , _patch_new = Just newMapTerm })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_guitar_pedals)) clientEnv
+            let add_tube_screamers =
+                  PM.fromList [
+                    ( "tube screamers"
+                    , NgramsReplace { _patch_old = Nothing
+                                    , _patch_new = Just newMapTerm })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_tube_screamers)) clientEnv
+            let group_nodes =
+                  PM.fromList [
+                    ( "guitar pedals"
+                    , NgramsPatch { _patch_children = NT.PatchMSet (fst $ PM.fromList [("tube screamers", addPatch)])
+                                  , _patch_list = Keep })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst group_nodes)) clientEnv
+            -- Creates the grouping:
+            {- overdrives
+               |
+               \ guitar pedals
+                 |
+                 \ tube screamers
+            -}
+            let add_overdrives =
+                  PM.fromList [
+                    ( "overdrives"
+                    , NgramsReplace { _patch_old = Nothing
+                                    , _patch_new = Just newMapTerm })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_overdrives)) clientEnv
+            let group_nodes_2 =
+                  PM.fromList [
+                    ( "overdrives"
+                    , NgramsPatch { _patch_children = NT.PatchMSet (fst $ PM.fromList [("guitar pedals", addPatch)])
+                                  , _patch_list = Keep })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst group_nodes_2)) clientEnv
+            liftIO $ do
+              eRes <- runClientM (get_table_ngrams token cId APINgrams.Terms listId 50 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
+              eRes `shouldSatisfy` isRight
+              let (Right res) = eRes
+              Just res `shouldBe` JSON.decode [json| {"version":5
+                                                     ,"count":3
+                                                     ,"data":[
+                                                       {"ngrams":"guitar pedals"
+                                                       ,"size":1
+                                                       ,"list":"MapTerm"
+                                                       ,"root":"overdrives"
+                                                       ,"parent":"overdrives"
+                                                       ,"occurrences":[]
+                                                       ,"children":["tube screamers"]
+                                                       },
+                                                       {"ngrams":"overdrives"
+                                                       ,"size":1
+                                                       ,"list":"MapTerm"
+                                                       ,"occurrences":[]
+                                                       ,"children":["guitar pedals"]
+                                                       },
+                                                       {"ngrams":"tube screamers"
+                                                       ,"size":1
+                                                       ,"list":"MapTerm"
+                                                       ,"root":"overdrives"
+                                                       ,"parent":"guitar pedals"
+                                                       ,"occurrences":[]
+                                                       ,"children":[]}
+                                                       ]
+                                                     } |]
+
       it "does not create duplicates when uploading JSON (#313)" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
         let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
-            -- this term is imported from the .json file
-            let importedTerm = NgramsTerm "abelian group"
-            -- this is the new term, under which importedTerm will be grouped
-            let newTerm = NgramsTerm "new abelian group"
-
+            -- The test data has a single term called "abelian group". In this test
+            -- we will try grouping together "abelian group" and "new abelian group".
             listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
 
-            let checkNgrams expected = do
-                  eng <- liftIO $ runClientM (get_table_ngrams token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
-                  case eng of
-                    Left err -> fail (show err)
-                    Right r ->
-                      let real = over mapped (\nt -> ( nt ^. ne_ngrams
-                                                     , mSetToList $ nt ^. ne_children ))
-                                             (r ^. vc_data . _NgramsTable) in
-                      liftIO $ Set.fromList real `shouldBe` Set.fromList expected
-
             -- The #313 error is about importedTerm being duplicated
             -- in a specific case
+            let getNgrams = runClientM (get_table_ngrams token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
 
-            checkNgrams [ (importedTerm, []) ]
+            checkNgrams getNgrams [json| {"version":0
+                                         ,"count":1
+                                         ,"data":[
+                                           {"ngrams":"abelian group"
+                                           ,"size":2
+                                           ,"list":"MapTerm"
+                                           ,"root":null
+                                           ,"parent":null
+                                           ,"occurrences":[]
+                                           ,"children":[]
+                                           }
+                                           ]
+                                         }
+                                  |]
             let nre = NgramsRepoElement 1 MapTerm Nothing Nothing (MSet mempty)
             let patch = PM.fromList [
-                           ( newTerm
+                           ( "new abelian group"
                            , NgramsReplace { _patch_old = Nothing
                                            , _patch_new = Just nre } )
                       ]
             _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst patch)) clientEnv
 
             -- check that new term is added (with no parent)
-            checkNgrams [ (newTerm, [])
-                        , (importedTerm, []) ]
+            checkNgrams getNgrams [json| { "version": 1
+                                         ,"count":2
+                                         ,"data":[
+                                           {"ngrams":"abelian group"
+                                           ,"size":2
+                                           ,"list":"MapTerm"
+                                           ,"root":null
+                                           ,"parent":null
+                                           ,"occurrences":[]
+                                           ,"children":[]
+                                           },
+                                           {"ngrams":"new abelian group"
+                                           ,"size":1
+                                           ,"list":"MapTerm"
+                                           ,"root":null
+                                           ,"parent":null
+                                           ,"occurrences":[]
+                                           ,"children":[]
+                                           }
+                                           ]
+                                         }
+                                  |]
 
             -- now patch it so that we have a group
             let patchChildren = PM.fromList [
-                                 ( newTerm
-                                 , toNgramsPatch [importedTerm] )
+                                 ( "new abelian group"
+                                 , toNgramsPatch ["abelian group"] )
                                ]
             _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 32 $ NgramsTablePatch $ fst patchChildren)) clientEnv
 
             -- check that new term is parent of old one
-            checkNgrams [ (newTerm, [importedTerm]) ]
+            checkNgrams getNgrams [json| {"version": 2
+                                         ,"count":2
+                                         ,"data":[
+                                           {"ngrams":"abelian group"
+                                           ,"size":2
+                                           ,"list":"MapTerm"
+                                           ,"root": "new abelian group"
+                                           ,"parent": "new abelian group"
+                                           ,"occurrences":[]
+                                           ,"children":[]
+                                           },
+                                           {"ngrams":"new abelian group"
+                                           ,"size":1
+                                           ,"list":"MapTerm"
+                                           ,"root":null
+                                           ,"parent":null
+                                           ,"occurrences":[]
+                                           ,"children":["abelian group"]
+                                           }
+                                           ]
+                                         }
+                                  |]
 
             -- finally, upload the list again, the group should be as
             -- it was before (the bug in #313 was that "abelian group"
@@ -195,14 +333,31 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
             _ <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
 
             -- old (imported) term shouldn't become parentless
-            -- (#313 error was that we had [newTerm, importedTerm] instead)
-
-            -- NOTE: Unfortunately, I'm not able to reproduce this
-            -- error here, though I tried. Something is missing, maybe
-            -- some nodestory integration with tests?
-            checkNgrams [ (newTerm, [importedTerm]) ]
-
-            pure ()
+            -- (#313 error was that we had ["new abelian group", "abelian group"] instead)
+            -- In essence, this JSON needs to be exactly the same as the previous one,
+            -- i.e. important doesn't change the topology.
+            checkNgrams getNgrams [json| {"version": 2
+                                         ,"count":2
+                                         ,"data":[
+                                           {"ngrams":"abelian group"
+                                           ,"size":2
+                                           ,"list":"MapTerm"
+                                           ,"root": "new abelian group"
+                                           ,"parent": "new abelian group"
+                                           ,"occurrences":[]
+                                           ,"children":[]
+                                           },
+                                           {"ngrams":"new abelian group"
+                                           ,"size":1
+                                           ,"list":"MapTerm"
+                                           ,"root":null
+                                           ,"parent":null
+                                           ,"occurrences":[]
+                                           ,"children":["abelian group"]
+                                           }
+                                           ]
+                                         }
+                                  |]
 
     describe "POST /api/v1.0/lists/:id/csv/add/form/async (CSV)" $ do
 

test/Test/Instances.hs

@@ -12,6 +12,7 @@ Portability : POSIX
 {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}
 
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Instances
 where
@@ -382,15 +383,133 @@ instance Arbitrary DET.WSRequest where
                     , pure DET.WSDeauthorize ]
 
 
+arbitraryNgramsTerm :: Gen Ngrams.NgramsTerm
+arbitraryNgramsTerm = elements
+  [ "time"
+  , "year"
+  , "people"
+  , "way"
+  , "day"
+  , "man"
+  , "thing"
+  , "woman"
+  , "life"
+  , "child"
+  , "world"
+  , "school"
+  , "state"
+  , "family"
+  , "student"
+  , "group"
+  , "country"
+  , "problem"
+  , "hand"
+  , "part"
+  , "place"
+  , "case"
+  , "week"
+  , "company"
+  , "system"
+  , "program"
+  , "question"
+  , "work"
+  , "government"
+  , "number"
+  , "night"
+  , "point"
+  , "home"
+  , "water"
+  , "room"
+  , "mother"
+  , "area"
+  , "money"
+  , "story"
+  , "fact"
+  , "month"
+  , "lot"
+  , "right"
+  , "study"
+  , "book"
+  , "eye"
+  , "job"
+  , "word"
+  , "business"
+  , "issue"
+  , "side"
+  , "kind"
+  , "head"
+  , "house"
+  , "service"
+  , "friend"
+  , "father"
+  , "power"
+  , "hour"
+  , "game"
+  , "line"
+  , "end"
+  , "member"
+  , "law"
+  , "car"
+  , "city"
+  , "community"
+  , "name"
+  , "president"
+  , "team"
+  , "minute"
+  , "idea"
+  , "kid"
+  , "body"
+  , "information"
+  , "back"
+  , "parent"
+  , "face"
+  , "others"
+  , "level"
+  , "office"
+  , "door"
+  , "health"
+  , "person"
+  , "art"
+  , "war"
+  , "history"
+  , "party"
+  , "result"
+  , "change"
+  , "morning"
+  , "reason"
+  , "research"
+  , "girl"
+  , "guy"
+  , "moment"
+  , "air"
+  , "teacher"
+  , "force"
+  , "education"
+  ]
+
+
 -- Ngrams
 instance Arbitrary a => Arbitrary (Ngrams.MSet a)
+-- We cannot pick some completely arbitrary values for the ngrams terms,
+-- see the rationale in the instance for 'NgramsElement'.
 instance Arbitrary Ngrams.NgramsTerm where
-  arbitrary = Ngrams.NgramsTerm <$>
-    -- we take into accoutn the fact, that tojsonkey strips the text
-    (arbitrary `suchThat` (\t -> t == T.strip t))
+  arbitrary = arbitraryNgramsTerm
 instance Arbitrary Ngrams.TabType where arbitrary = arbitraryBoundedEnum
 instance Arbitrary Ngrams.NgramsElement where
-  arbitrary = elements [Ngrams.newNgramsElement Nothing "sport"]
+  -- We cannot pick some completely arbitrary values for the ngrams elements
+  -- because we still want to simulate potential hierarchies, i.e. forests of ngrams.
+  -- so we sample the ngrams terms from a selection, and we restrict the number of max
+  -- children for each 'NgramsElement' to the size parameter to not have very large trees.
+  arbitrary = do
+    _ne_ngrams      <- arbitrary
+    _ne_size        <- arbitrary
+    _ne_list        <- arbitrary
+    _ne_occurrences <- arbitrary
+    _ne_root        <- arbitrary `suchThat` (maybe True (\x -> x /= _ne_ngrams)) -- can't be root of itself
+    _ne_parent      <- arbitrary `suchThat` (maybe True (\x -> x /= _ne_ngrams)) -- can't be parent of itself
+    _ne_children    <- Ngrams.mSetFromList <$> (sized (\n -> vectorOf n arbitrary `suchThat` (\x -> _ne_ngrams `notElem` x))) -- can't be cyclic
+    pure Ngrams.NgramsElement{..}
+
 instance Arbitrary Ngrams.NgramsTable where
   arbitrary = pure ngramsMockTable
 instance Arbitrary Ngrams.OrderBy where arbitrary = arbitraryBoundedEnum

test/Test/Ngrams/Query.hs

 {-# LANGUAGE TypeApplications #-}
-module Test.Ngrams.Query (tests) where
+module Test.Ngrams.Query (tests, mkMapTerm) where
 
 import Control.Monad
 import Data.Coerce

test/Test/Offline/Ngrams.hs

+{-# LANGUAGE QuasiQuotes      #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns     #-}
 module Test.Offline.Ngrams (tests) where
 
 import Prelude
 
+import Control.Lens
+import Data.Map.Strict qualified as Map
 import Data.Text qualified as T
+import Gargantext.API.Ngrams (filterNgramsNodes, buildForest, destroyForest, pruneForest)
+import Gargantext.API.Ngrams.Types
 import Gargantext.API.Ngrams.Types qualified as NT
 import Gargantext.Core
+import Gargantext.Core.Text.Terms.Mono (isSep)
 import Gargantext.Core.Text.Terms.WithList
 import Gargantext.Core.Types
 import Gargantext.Database.Action.Flow.Utils (docNgrams)
-import Gargantext.Database.Schema.Context
 import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Schema.Context
+import Test.HUnit
+import Test.Hspec
 import Test.Instances ()
+import Test.Ngrams.Query (mkMapTerm)
 import Test.QuickCheck
-import Test.Hspec
-import Control.Lens
-import qualified Test.QuickCheck as QC
-import Gargantext.Core.Text.Terms.Mono (isSep)
+import Test.QuickCheck qualified as QC
+import Data.Tree
+import Text.RawString.QQ (r)
+import Data.Char (isSpace)
+import Data.Map.Strict (Map)
+import Test.Hspec.QuickCheck (prop)
 
 
 genScientificText :: Gen T.Text
@@ -89,6 +101,31 @@ tests = describe "Ngrams" $ do
    it "return results for non-empty input terms" $ property testBuildPatternsNonEmpty
   describe "docNgrams" $ do
    it "always matches if the input text contains any of the terms" $ property testDocNgramsOKMatch
+  describe "ngram forests" $ do
+   it "building a simple tree works"  testBuildNgramsTree_01
+   it "building a complex tree works" testBuildNgramsTree_02
+   it "building a complex deep tree works" testBuildNgramsTree_03
+   it "pruning a simple tree works" testPruningNgramsForest_01
+   it "pruning a complex tree works" testPruningNgramsForest_02
+   prop "destroyForest . buildForest === id" buildDestroyForestRoundtrips
+  describe "hierarchical grouping" $ do
+   it "filterNgramsNodes with empty query is identity" testFilterNgramsNodesEmptyQuery
+
+hierarchicalTableMap :: Map NgramsTerm NgramsElement
+hierarchicalTableMap = Map.fromList [
+    ("vehicle", mkMapTerm "vehicle" & ne_children .~ mSetFromList ["car"])
+  , ("car", mkMapTerm "car" & ne_root .~ Just "vehicle"
+                            & ne_parent .~ Just "vehicle"
+                            & ne_children .~ mSetFromList ["ford"])
+  , ("ford", mkMapTerm "ford" & ne_root .~ Just "vehicle"
+                              & ne_parent .~ Just "car")
+  ]
+
+testFilterNgramsNodesEmptyQuery :: Assertion
+testFilterNgramsNodesEmptyQuery = do
+  let input = hierarchicalTableMap
+  let actual = filterNgramsNodes (Just MapTerm) Nothing Nothing (const True) input
+  actual @?= input
 
 testDocNgramsOKMatch :: Lang -> DocumentWithMatches -> Property
 testDocNgramsOKMatch lang (DocumentWithMatches ts doc) =
@@ -103,3 +140,166 @@ testBuildPatternsNonEmpty :: Lang -> NonEmptyList NgramsTermNonEmpty -> Property
 testBuildPatternsNonEmpty lang ts =
   let ts' = map (NT.NgramsTerm . unNgramsTermNonEmpty) $ getNonEmpty ts
   in counterexample "buildPatterns returned no results" $ length (buildPatternsWith lang ts') > 0
+
+newtype ASCIIForest = ASCIIForest String
+  deriving Eq
+
+instance Show ASCIIForest where
+  show (ASCIIForest x) = x
+
+compareForestVisually :: Forest NgramsElement -> String -> Property
+compareForestVisually f expected =
+  let actual               = init $ drawForest (map (fmap renderEl) f)
+      outermostIndentation = T.length . T.takeWhile isSpace . T.dropWhile (=='\n') . T.pack $ expected
+  in ASCIIForest actual === ASCIIForest (sanitiseDrawing outermostIndentation expected)
+  where
+    renderEl :: NgramsElement -> String
+    renderEl = T.unpack . unNgramsTerm . _ne_ngrams
+
+    toTextPaths :: String -> [T.Text]
+    toTextPaths = T.splitOn "\n" . T.strip . T.pack
+
+    sanitiseDrawing :: Int -> String -> String
+    sanitiseDrawing outermostIndentation =
+      let dropLayout t = case T.uncons t of
+            Just (' ', _) -> T.drop outermostIndentation t
+            _             -> t -- leave it be
+      in T.unpack . T.unlines . map dropLayout . toTextPaths
+
+testBuildNgramsTree_01 :: Property
+testBuildNgramsTree_01 =
+  let t1 = Map.fromList [ ( "foo", mkMapTerm "foo" & ne_children .~ mSetFromList ["bar"])
+                        , ( "bar", mkMapTerm "bar" & ne_parent   .~ Just "foo")
+                        ]
+  in (buildForest t1) `compareForestVisually` [r|
+         bar
+
+         foo
+         |
+         `- bar
+|]
+
+testBuildNgramsTree_02 :: Property
+testBuildNgramsTree_02 =
+  buildForest hierarchicalTableMap `compareForestVisually` [r|
+         car
+         |
+         `- ford
+
+         ford
+
+         vehicle
+         |
+         `- car
+            |
+            `- ford
+|]
+
+testBuildNgramsTree_03 :: Property
+testBuildNgramsTree_03 =
+  let input = Map.fromList [
+         ("animalia", mkMapTerm "animalia" & ne_children .~ mSetFromList ["chordata"])
+       , ("chordata", mkMapTerm "chordata" & ne_root .~ Just "animalia"
+                                 & ne_parent .~ Just "animalia"
+                                 & ne_children .~ mSetFromList ["mammalia"])
+       , ("mammalia", mkMapTerm "mammalia" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "chordata"
+                                   & ne_children .~ mSetFromList ["carnivora", "primates"]
+                                   )
+       , ("carnivora", mkMapTerm "carnivora" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "mammalia"
+                                   & ne_children .~ mSetFromList ["felidae"]
+                                   )
+       , ("felidae", mkMapTerm "felidae" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "carnivora"
+                                   & ne_children .~ mSetFromList ["panthera"]
+                                   )
+       , ("panthera", mkMapTerm "panthera" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "felidae"
+                                   & ne_children .~ mSetFromList ["panthera leo", "panthera tigris"]
+                                   )
+       , ("panthera leo", mkMapTerm "panthera leo" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "pathera"
+                                   )
+       , ("panthera tigris", mkMapTerm "panthera tigris" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "panthera"
+                                   )
+       , ("panthera tigris", mkMapTerm "panthera tigris" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "panthera"
+                                   )
+       , ("primates", mkMapTerm "primates" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "mammalia"
+                                   & ne_children .~ mSetFromList ["hominidae"]
+                                   )
+       , ("hominidae", mkMapTerm "hominidae" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "primates"
+                                   & ne_children .~ mSetFromList ["homo"]
+                                   )
+       , ("homo", mkMapTerm "homo" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "hominidae"
+                                   & ne_children .~ mSetFromList ["homo sapiens"]
+                                   )
+       , ("homo sapies", mkMapTerm "homo sapiens" & ne_root .~ Just "animalia"
+                                   & ne_parent .~ Just "homo"
+                                   )
+       ]
+
+  in pruneForest (buildForest input) `compareForestVisually` [r|
+         animalia
+         |
+         `- chordata
+            |
+            `- mammalia
+               |
+               +- carnivora
+               |  |
+               |  `- felidae
+               |     |
+               |     `- panthera
+               |        |
+               |        +- panthera leo
+               |        |
+               |        `- panthera tigris
+               |
+               `- primates
+                  |
+                  `- hominidae
+                     |
+                     `- homo
+|]
+
+
+newtype TableMapLockStep = TableMapLockStep { getTableMap :: Map NgramsTerm NgramsElement }
+  deriving (Show, Eq)
+
+instance Arbitrary TableMapLockStep where
+  arbitrary = do
+    pairs <- map (\(k,v) -> (k, v & ne_ngrams .~ k)) <$> arbitrary
+    pure $ TableMapLockStep (Map.fromList pairs)
+
+-- /PRECONDITION/: The '_ne_ngrams' field always matches the 'NgramsTerm', key of the map.
+buildDestroyForestRoundtrips :: TableMapLockStep -> Property
+buildDestroyForestRoundtrips (TableMapLockStep mp) =
+  (destroyForest . buildForest $ mp) === mp
+
+testPruningNgramsForest_01 :: Property
+testPruningNgramsForest_01 =
+  let t1 = Map.fromList [ ( "foo", mkMapTerm "foo" & ne_children .~ mSetFromList ["bar"])
+                        , ( "bar", mkMapTerm "bar" & ne_parent   .~ Just "foo")
+                        ]
+  in (pruneForest $ buildForest t1) `compareForestVisually` [r|
+         foo
+         |
+         `- bar
+|]
+
+testPruningNgramsForest_02 :: Property
+testPruningNgramsForest_02 =
+  (pruneForest $ buildForest hierarchicalTableMap) `compareForestVisually` [r|
+         vehicle
+         |
+         `- car
+            |
+            `- ford
+|]
+