Skip to content

haskell-gargantext
haskell-gargantext
Verified Commit 1a213aeb authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
2 Browse files
Options

Merge branch 'dev' into 483-dev-corenlp-in-nix-flake

parents d7aa1301 61aac410
Pipeline #7790 failed with stages
          in 142 minutes and 14 seconds
          Hide whitespace changes
          Inline Side-by-side
          Showing with 998 additions and 388 deletions
          CHANGELOG.md
          View file @ 1a213aeb
          ## 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 ## 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) * [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
          View file @ 1a213aeb
          ...@@ -11,10 +11,7 @@ Import a corpus binary. ...@@ -11,10 +11,7 @@ Import a corpus binary.
          -} -}
          {-# LANGUAGE LambdaCase #-}
          {-# LANGUAGE Strict #-} {-# LANGUAGE Strict #-}
          {-# LANGUAGE TypeOperators #-}
          {-# LANGUAGE TypeApplications #-}
          module CLI.Ini where module CLI.Ini where
          ...@@ -108,12 +105,12 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo = ...@@ -108,12 +105,12 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
          mkFrontendConfig :: Ini.GargConfig -> CTypes.FrontendConfig mkFrontendConfig :: Ini.GargConfig -> CTypes.FrontendConfig
          mkFrontendConfig (Ini.GargConfig { .. }) = 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_backend_name = _gc_backend_name
          , _fc_url_backend_api = _gc_url_backend_api
          , _fc_cors , _fc_cors
          , _fc_microservices , _fc_microservices
          , _fc_appPort = 3000
          , _fc_cookie_settings = CTypes.defaultCookieSettings } , _fc_cookie_settings = CTypes.defaultCookieSettings }
          where where
          _fc_cors = CTypes.CORSSettings { _corsAllowedOrigins = [ _fc_cors = CTypes.CORSSettings { _corsAllowedOrigins = [
          ...@@ -142,6 +139,10 @@ mkFrontendConfig (Ini.GargConfig { .. }) = ...@@ -142,6 +139,10 @@ mkFrontendConfig (Ini.GargConfig { .. }) =
          case parseBaseUrl (T.unpack url) of case parseBaseUrl (T.unpack url) of
          Nothing -> panicTrace $ "Cannot parse base url for: " <> url Nothing -> panicTrace $ "Cannot parse base url for: " <> url
          Just b -> CTypes.CORSOrigin b 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 :: CTypes.NotificationsConfig
          defaultNotificationsConfig = defaultNotificationsConfig =
          ......
          bin/gargantext-cli/CLI/Server.hs
          View file @ 1a213aeb
          ...@@ -77,13 +77,11 @@ serverParser = hsubparser ( ...@@ -77,13 +77,11 @@ serverParser = hsubparser (
          start_p :: Parser CLIServer start_p :: Parser CLIServer
          start_p = fmap CLIS_start $ ServerArgs start_p = fmap CLIS_start $ ServerArgs
          <$> mode_p <$> mode_p
          <*> port_p
          <*> settings_p <*> settings_p
          start_all_p :: Parser CLIServer start_all_p :: Parser CLIServer
          start_all_p = fmap CLIS_startAll $ ServerArgs start_all_p = fmap CLIS_startAll $ ServerArgs
          <$> mode_p <$> mode_p
          <*> port_p
          <*> settings_p <*> settings_p
          mode_p :: Parser Mode mode_p :: Parser Mode
          ...@@ -92,21 +90,13 @@ mode_p = option auto ( long "mode" ...@@ -92,21 +90,13 @@ mode_p = option auto ( long "mode"
          <> metavar "M" <> metavar "M"
          <> help "Possible modes: Dev | Mock | Prod" ) <> 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 :: Parser CLIServer
          version_p = pure CLIS_version version_p = pure CLIS_version
          startServerCLI :: Logger IO -> ServerArgs -> IO () startServerCLI :: Logger IO -> ServerArgs -> IO ()
          startServerCLI ioLogger (ServerArgs { .. }) = do 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. -- Sets the locale to avoid encoding issues like in #284.
          setLocaleEncoding utf8 setLocaleEncoding utf8
          ...@@ -114,4 +104,4 @@ startServerCLI ioLogger (ServerArgs { .. }) = do ...@@ -114,4 +104,4 @@ startServerCLI ioLogger (ServerArgs { .. }) = do
          logMsg ioLogger ERROR "Mock mode not supported!" logMsg ioLogger ERROR "Mock mode not supported!"
          exitFailure exitFailure
          startGargantext server_mode server_port server_toml startGargantext server_mode server_toml
          bin/gargantext-cli/CLI/Types.hs
          View file @ 1a213aeb
          ...@@ -100,7 +100,6 @@ data CLIServer ...@@ -100,7 +100,6 @@ data CLIServer
          data ServerArgs = ServerArgs data ServerArgs = ServerArgs
          { server_mode :: !Mode { server_mode :: !Mode
          , server_port :: !Int
          , server_toml :: !SettingsFile } , server_toml :: !SettingsFile }
          deriving (Show, Eq) deriving (Show, Eq)
          ......
          devops/docker/docker-compose.yaml
          View file @ 1a213aeb
          ...@@ -40,7 +40,8 @@ services: ...@@ -40,7 +40,8 @@ services:
          POSTGRES_PASSWORD: C8kdcUrAQy66U POSTGRES_PASSWORD: C8kdcUrAQy66U
          POSTGRES_DB: gargandbV5 POSTGRES_DB: gargandbV5
          volumes: volumes:
          - garg-pgdata14:/var/lib/postgresql/data # - garg-pgdata14:/var/lib/postgresql/data
          - docker_garg-pgdata14:/var/lib/postgresql/data
          - ../:/gargantext - ../:/gargantext
          - ../dbs:/dbs - ../dbs:/dbs
          - ../postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro - ../postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro
          ...@@ -71,6 +72,8 @@ services: ...@@ -71,6 +72,8 @@ services:
          volumes: volumes:
          #garg-pgdata: #garg-pgdata:
          garg-pgdata14: # garg-pgdata14:
          docker_garg-pgdata14:
          external: true
          js-cache: js-cache:
          pgadmin: pgadmin:
          gargantext-settings.toml_toModify
          View file @ 1a213aeb
          [frontend] [frontend]
          # Main url serving the FrontEnd (public URL)
          external_url = "http://localhost:8008"
          # Main url serving the FrontEnd # host/port where the GarganText server will bind to
          url = "http://localhost" 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 backend_name = "localhost"
          url_backend_api = "http://localhost:8008/api/v1.0"
          jwt_settings = "TODO" jwt_settings = "TODO"
          ......
          gargantext.cabal
          View file @ 1a213aeb
          ...@@ -5,7 +5,7 @@ cabal-version: 3.4 ...@@ -5,7 +5,7 @@ cabal-version: 3.4
          -- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
          name: gargantext name: gargantext
          version: 0.0.7.4.7 version: 0.0.7.4.8
          synopsis: Search, map, share synopsis: Search, map, share
          description: Please see README.md description: Please see README.md
          category: Data category: Data
          ...@@ -570,6 +570,7 @@ library ...@@ -570,6 +570,7 @@ library
          , json-stream ^>= 0.4.2.4 , json-stream ^>= 0.4.2.4
          , lens >= 5.2.2 && < 5.3 , lens >= 5.2.2 && < 5.3
          , lens-aeson < 1.3 , lens-aeson < 1.3
          , list-zipper
          , massiv < 1.1 , massiv < 1.1
          , matrix ^>= 0.3.6.1 , matrix ^>= 0.3.6.1
          , mime-mail >= 0.5.1 , mime-mail >= 0.5.1
          ......
          nix/pkgs.nix
          View file @ 1a213aeb
          ...@@ -17,18 +17,19 @@ rec { ...@@ -17,18 +17,19 @@ rec {
          else else
          pkgs.stdenv; # Keep default on other platforms (clang on macOS) pkgs.stdenv; # Keep default on other platforms (clang on macOS)
          ghc966 = pkgs.haskell.compiler.ghc966; ghcVersion = "ghc966";
          cabal_install = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.ghc966.cabal-install; gargGhc = pkgs.haskell.compiler.${ghcVersion};
          cabal_install = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.${ghcVersion}.cabal-install;
          graphviz = pkgs.callPackage ./graphviz.nix { }; graphviz = pkgs.callPackage ./graphviz.nix { };
          igraph_0_10_4 = pkgs.callPackage ./igraph.nix { }; igraph_0_10_4 = pkgs.callPackage ./igraph.nix { };
          cabal2stack = pkgs.callPackage ./cabal2stack.nix { ghc = ghc966; }; cabal2stack = pkgs.callPackage ./cabal2stack.nix { ghc = gargGhc; };
          nng_notls = pkgs.nng.overrideAttrs (old: { nng_notls = pkgs.nng.overrideAttrs (old: {
          cmakeFlags = (old.cmakeFlags or [ ]) ++ [ "-DNNG_ENABLE_TLS=OFF" ]; cmakeFlags = (old.cmakeFlags or [ ]) ++ [ "-DNNG_ENABLE_TLS=OFF" ];
          }); });
          hsBuildInputs = [ hsBuildInputs = [
          ghc966 gargGhc
          cabal_install cabal_install
          pkgs.haskellPackages.alex pkgs.haskellPackages.alex
          pkgs.haskellPackages.ghcid pkgs.haskellPackages.ghcid
          ......
          src/Gargantext/API.hs
          View file @ 1a213aeb
          ...@@ -49,7 +49,7 @@ import Gargantext.API.Routes.Named (API) ...@@ -49,7 +49,7 @@ import Gargantext.API.Routes.Named (API)
          import Gargantext.API.Routes.Named.EKG (EkgAPI) import Gargantext.API.Routes.Named.EKG (EkgAPI)
          import Gargantext.API.Server.Named (server) import Gargantext.API.Server.Named (server)
          import Gargantext.Core.Config 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.Config.Utils (readConfig)
          import Gargantext.Core.Notifications (withNotifications) import Gargantext.Core.Notifications (withNotifications)
          import Gargantext.Database.Prelude qualified as DB import Gargantext.Database.Prelude qualified as DB
          ...@@ -62,21 +62,20 @@ import Network.Wai.Handler.Warp hiding (defaultSettings) ...@@ -62,21 +62,20 @@ import Network.Wai.Handler.Warp hiding (defaultSettings)
          import Network.Wai.Middleware.Cors import Network.Wai.Middleware.Cors
          import Network.Wai.Middleware.RequestLogger (logStdout) import Network.Wai.Middleware.RequestLogger (logStdout)
          import Servant hiding (Header) 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.Clock qualified as Clock
          import System.Cron.Schedule qualified as Cron import System.Cron.Schedule qualified as Cron
          -- | startGargantext takes as parameters port number and Toml file. -- | startGargantext takes as parameters port number and Toml file.
          startGargantext :: Mode -> PortNumber -> SettingsFile -> IO () startGargantext :: Mode -> SettingsFile -> IO ()
          startGargantext mode port sf@(SettingsFile settingsFile) = do startGargantext mode sf@(SettingsFile settingsFile) = do
          config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port config <- readConfig sf
          withLoggerIO (config ^. gc_logging) $ \logger -> do withLoggerIO (config ^. gc_logging) $ \logger -> do
          when (port /= config ^. gc_frontend_config . fc_appPort) $
          panicTrace "TODO: conflicting settings of port"
          withNotifications config $ \dispatcher -> do withNotifications config $ \dispatcher -> do
          env <- newEnv logger config dispatcher env <- newEnv logger config dispatcher
          let fc = env ^. env_config . gc_frontend_config let fc = env ^. env_config . gc_frontend_config
          let proxyStatus = microServicesProxyStatus fc let proxyStatus = microServicesProxyStatus fc
          let port = baseUrlPort (fc ^. fc_internal_url)
          runDbCheck env runDbCheck env
          startupInfo config port proxyStatus startupInfo config port proxyStatus
          app <- makeApp env app <- makeApp env
          ......
          src/Gargantext/API/Admin/FrontEnd.hs
          View file @ 1a213aeb
          ...@@ -16,9 +16,10 @@ Loads all static file for the front-end. ...@@ -16,9 +16,10 @@ Loads all static file for the front-end.
          --------------------------------------------------------------------- ---------------------------------------------------------------------
          module Gargantext.API.Admin.FrontEnd where module Gargantext.API.Admin.FrontEnd where
          import GHC.IO (FilePath)
          import Servant import Servant
          type FrontEndAPI = Raw type FrontEndAPI = Raw
          frontEndServer :: Server FrontEndAPI frontEndServer :: FilePath -> Server FrontEndAPI
          frontEndServer = serveDirectoryFileServer "./purescript-gargantext/dist" frontEndServer path = serveDirectoryFileServer path
          src/Gargantext/API/Ngrams.hs
          View file @ 1a213aeb
          ...@@ -18,12 +18,13 @@ add get ...@@ -18,12 +18,13 @@ add get
          {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
          {-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}
          {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-}
          {-# LANGUAGE ConstraintKinds #-}
          {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE IncoherentInstances #-}
          {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
          {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
          {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
          {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
          module Gargantext.API.Ngrams module Gargantext.API.Ngrams
          ...@@ -82,10 +83,21 @@ module Gargantext.API.Ngrams ...@@ -82,10 +83,21 @@ module Gargantext.API.Ngrams
          -- * Handlers to be used when serving top-level API requests -- * Handlers to be used when serving top-level API requests
          , getTableNgramsCorpusHandler , getTableNgramsCorpusHandler
          -- * Internals for testing
          , compute_new_state_patches
          , PatchHistory(..)
          , newNgramsFromNgramsStatePatch
          , filterNgramsNodes
          -- * Operations on a forest
          , buildForest
          , destroyForest
          , pruneForest
          ) )
          where 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.Aeson.Text qualified as DAT
          import Data.List qualified as List import Data.List qualified as List
          import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
          ...@@ -94,9 +106,11 @@ import Data.Patch.Class (Action(act), Transformable(..), ours) ...@@ -94,9 +106,11 @@ import Data.Patch.Class (Action(act), Transformable(..), ours)
          import Data.Set qualified as Set import Data.Set qualified as Set
          import Data.Text (isInfixOf, toLower, unpack) import Data.Text (isInfixOf, toLower, unpack)
          import Data.Text.Lazy.IO as DTL ( writeFile ) import Data.Text.Lazy.IO as DTL ( writeFile )
          import Data.Tree
          import Gargantext.API.Ngrams.Tools (getNodeStory) import Gargantext.API.Ngrams.Tools (getNodeStory)
          import Gargantext.API.Ngrams.Types 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.Text.Ngrams (Ngrams, NgramsType)
          import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, ContextId, HasValidationError) import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, ContextId, HasValidationError)
          import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..)) import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
          ...@@ -107,7 +121,6 @@ import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf) ...@@ -107,7 +121,6 @@ import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
          import Text.Collate qualified as Unicode import Text.Collate qualified as Unicode
          {- {-
          -- TODO sequences of modifications (Patchs) -- TODO sequences of modifications (Patchs)
          type NgramsIdPatch = Patch NgramsId NgramsPatch type NgramsIdPatch = Patch NgramsId NgramsPatch
          ...@@ -261,25 +274,11 @@ commitStatePatch :: NodeStoryEnv err ...@@ -261,25 +274,11 @@ commitStatePatch :: NodeStoryEnv err
          -> Versioned NgramsStatePatch' -> Versioned NgramsStatePatch'
          -> DBUpdate err (Versioned NgramsStatePatch') -> DBUpdate err (Versioned NgramsStatePatch')
          commitStatePatch env listId (Versioned _p_version p) = do commitStatePatch env listId (Versioned _p_version p) = do
          -- printDebug "[commitStatePatch]" listId
          a <- getNodeStory env listId a <- getNodeStory env listId
          let archiveSaver = view hasNodeArchiveStoryImmediateSaver env 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 let
          (p', q') = transformWith ngramsStatePatchConflictResolution p q (p', q') = compute_new_state_patches p (PatchHistory $ a ^. a_history)
          a' = a & a_version +~ 1 a' = a & a_version +~ 1
          & a_state %~ act p' & a_state %~ act p'
          & a_history %~ (p' :) & a_history %~ (p' :)
          ...@@ -335,6 +334,27 @@ commitStatePatch env listId (Versioned _p_version p) = do ...@@ -335,6 +334,27 @@ commitStatePatch env listId (Versioned _p_version p) = do
          pure newA 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. -- This is a special case of tableNgramsPut where the input patch is empty.
          tableNgramsPull :: NodeStoryEnv err tableNgramsPull :: NodeStoryEnv err
          ...@@ -410,6 +430,60 @@ dumpJsonTableMap fpath nodeId ngramsType = do ...@@ -410,6 +430,60 @@ dumpJsonTableMap fpath nodeId ngramsType = do
          liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m) liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
          pure () 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 Errors management
          -- TODO: polymorphic for Annuaire or Corpus or ... -- TODO: polymorphic for Annuaire or Corpus or ...
          ...@@ -417,7 +491,7 @@ dumpJsonTableMap fpath nodeId ngramsType = do ...@@ -417,7 +491,7 @@ dumpJsonTableMap fpath nodeId ngramsType = do
          -- TODO: should take only one ListId -- TODO: should take only one ListId
          -- | /pure/ function to query a 'Map NgramsTerm NgramsElement', according to a -- | /pure/ function to query a 'Map NgramsTerm NgramsElement', according to a
          -- search function. Returns a /versioned/ 'NgramsTable' which is paginated and -- search function. Returns a /versioned/ 'NgramsTable' which is paginated and
          -- sorted according to the input 'NgramsSearchQuery', together with the -- sorted according to the input 'NgramsSearchQuery', together with the
          -- occurrences of the elements. -- occurrences of the elements.
          searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement) searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement)
          ...@@ -426,42 +500,14 @@ searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement) ...@@ -426,42 +500,14 @@ searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement)
          -> VersionedWithCount NgramsTable -> VersionedWithCount NgramsTable
          searchTableNgrams versionedTableMap NgramsSearchQuery{..} = searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
          let tableMap = versionedTableMap ^. v_data 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 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 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. -- Sorts the input 'NgramsElement' list.
          -- /IMPORTANT/: As we might be sorting ngrams in all sorts of language, -- /IMPORTANT/: As we might be sorting ngrams in all sorts of language,
          -- some of them might include letters with accents and other unicode symbols, -- some of them might include letters with accents and other unicode symbols,
          ...@@ -477,14 +523,6 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} = ...@@ -477,14 +523,6 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
          ngramTermsAscSorter = on unicodeDUCETSorter (unNgramsTerm . view ne_ngrams) ngramTermsAscSorter = on unicodeDUCETSorter (unNgramsTerm . view ne_ngrams)
          ngramTermsDescSorter = on (\n1 n2 -> unicodeDUCETSorter n2 n1) (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 -- | For each input root, extends its occurrence count with
          -- the information found in the subitems. -- the information found in the subitems.
          withInners :: Map NgramsTerm NgramsElement -> Set NgramsElement -> Set NgramsElement withInners :: Map NgramsTerm NgramsElement -> Set NgramsElement -> Set NgramsElement
          ......
          src/Gargantext/API/Ngrams/NgramsTree.hs
          View file @ 1a213aeb
          ...@@ -10,10 +10,17 @@ Portability : POSIX ...@@ -10,10 +10,17 @@ Portability : POSIX
          -} -}
          {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
          module Gargantext.API.Ngrams.NgramsTree 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 (HashMap)
          import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
          import Data.List qualified as List import Data.List qualified as List
          ...@@ -23,41 +30,80 @@ import Data.Tree ( Tree(Node), unfoldForest ) ...@@ -23,41 +30,80 @@ import Data.Tree ( Tree(Node), unfoldForest )
          import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
          import Gargantext.Core.Types.Main ( ListType(..) ) import Gargantext.Core.Types.Main ( ListType(..) )
          import Gargantext.Database.Admin.Types.Node ( NodeId ) import Gargantext.Database.Admin.Types.Node ( NodeId )
          import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger) import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
          import Gargantext.Prelude import Gargantext.Prelude
          import Test.QuickCheck ( Arbitrary(arbitrary) ) import Test.QuickCheck ( Arbitrary(arbitrary) )
          type Children = Text -- | Ngrams forms a forest, i.e. a set of trees, each tree represents a strong grouping
          type Root = Text -- 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 -- | Models a general ngram tree polymorphic over a label 'l' and a measure 'm'.
          , mt_value :: Double data GeneralisedNgramsTree l m =
          , mt_children :: [NgramsTree] GeneralisedNgramsTree { mt_label :: l
          } , mt_value :: m
          deriving (Generic, Show, Eq) , mt_children :: [GeneralisedNgramsTree l m]
          }
          deriving (Generic, Show, Eq, Ord)
          toNgramsTree :: Tree (NgramsTerm,Double) -> NgramsTree instance (ToJSON l, ToJSON m) => ToJSON (GeneralisedNgramsTree l m) where
          toNgramsTree (Node (NgramsTerm l,v) xs) = NgramsTree l v (map toNgramsTree xs) 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 instance ToSchema NgramsTree where
          declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
          instance Arbitrary NgramsTree instance Arbitrary NgramsTree
          where 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)
          -> HashMap NgramsTerm (Set NodeId) -- and two hashmaps mapping an 'NgramsTerm' to their values, builds an 'NgramsForest'.
          -> HashMap NgramsTerm NgramsRepoElement toNgramsForest :: ListType
          -> [NgramsTree] -> HashMap NgramsTerm (Set NodeId)
          toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots -> HashMap NgramsTerm NgramsRepoElement
          -> NgramsForest
          toNgramsForest lt vs m = NgramsForest $ map toNgramsTree $ unfoldForest buildNode roots
          where where
          buildNode r = maybe ((r, value r),[]) buildNode r = maybe ((r, value r),[])
          (\x -> ((r, value r), mSetToList $ _nre_children x)) (\x -> ((r, value r), mSetToList $ _nre_children x))
          (HashMap.lookup r m) (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 :: [NgramsTerm]
          rootsCandidates = catMaybes rootsCandidates = catMaybes
          ......
          src/Gargantext/API/Node/Corpus/Export.hs
          View file @ 1a213aeb
          ...@@ -28,11 +28,12 @@ import Gargantext.API.Node.Corpus.Export.Types ( Corpus(..), CorpusSQLite(..) ) ...@@ -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.Corpus.Export.Utils (getContextNgrams, mkCorpusSQLite, mkCorpusSQLiteData)
          import Gargantext.API.Node.Document.Export.Types qualified as DocumentExport import Gargantext.API.Node.Document.Export.Types qualified as DocumentExport
          import Gargantext.API.Prelude (IsGargServer) import Gargantext.API.Prelude (IsGargServer)
          import Gargantext.API.Routes.Named.Corpus qualified as Named
          import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
          import Gargantext.Core.Text.Ngrams (NgramsType(..)) import Gargantext.Core.Text.Ngrams (NgramsType(..))
          import Gargantext.Core.Types.Main ( ListType(MapTerm) ) import Gargantext.Core.Types.Main ( ListType(MapTerm) )
          import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) ) 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.Prelude
          import Gargantext.Database.Query.Table.Node ( defaultList ) import Gargantext.Database.Query.Table.Node ( defaultList )
          import Gargantext.Database.Query.Table.NodeContext (selectDocNodes) import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
          ...@@ -41,7 +42,6 @@ import Gargantext.Prelude hiding (hash) ...@@ -41,7 +42,6 @@ import Gargantext.Prelude hiding (hash)
          import Gargantext.Prelude.Crypto.Hash (hash) import Gargantext.Prelude.Crypto.Hash (hash)
          import Servant (Headers, Header, addHeader) import Servant (Headers, Header, addHeader)
          import Servant.Server.Generic (AsServerT) import Servant.Server.Generic (AsServerT)
          import qualified Gargantext.API.Routes.Named.Corpus as Named
          -------------------------------------------------- --------------------------------------------------
          -- | Hashes are ordered by Set -- | Hashes are ordered by Set
          ......
          src/Gargantext/API/Node/Corpus/Export/Types.hs
          View file @ 1a213aeb
          ...@@ -87,3 +87,4 @@ data CorpusSQLiteData = ...@@ -87,3 +87,4 @@ data CorpusSQLiteData =
          , _csd_stop_context_ngrams :: Map ContextId (Set NgramsTerm) , _csd_stop_context_ngrams :: Map ContextId (Set NgramsTerm)
          , _csd_candidate_context_ngrams :: Map ContextId (Set NgramsTerm) , _csd_candidate_context_ngrams :: Map ContextId (Set NgramsTerm)
          } deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
          src/Gargantext/API/Node/Corpus/Export/Utils.hs
          View file @ 1a213aeb
          ...@@ -141,7 +141,9 @@ mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpa ...@@ -141,7 +141,9 @@ mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpa
          S.withConnection fpath $ \conn -> do S.withConnection fpath $ \conn -> do
          -- better performance -- better performance
          -- https://kerkour.com/sqlite-for-servers -- 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 "CREATE TABLE info (key, value);"
          S.execute conn "INSERT INTO info (key, value) VALUES ('gargVersion', ?)" (S.Only $ showVersion _csd_version) 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 ...@@ -179,6 +181,10 @@ mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpa
          , iso8601Show ctxDate , iso8601Show ctxDate
          , Aeson.encode ctxHyperdata )) <$> _csd_contexts) , 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 bsl <- BSL.readFile fpath
          pure $ CorpusSQLite { _cs_bs = bsl } pure $ CorpusSQLite { _cs_bs = bsl }
          ......
          src/Gargantext/API/Node/ShareURL.hs
          View file @ 1a213aeb
          {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
          {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
          {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
          ...@@ -10,7 +10,7 @@ import Data.Validity qualified as V ...@@ -10,7 +10,7 @@ import Data.Validity qualified as V
          import Gargantext.API.Prelude (IsGargServer) import Gargantext.API.Prelude (IsGargServer)
          import Gargantext.API.Routes.Named.Share qualified as Named import Gargantext.API.Routes.Named.Share qualified as Named
          import Gargantext.Core.Config (GargConfig, gc_frontend_config, HasConfig(hasConfig)) 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.Core.Types (NodeType, NodeId, unNodeId, _ValidationError)
          import Gargantext.Database.Prelude (IsDBEnvExtra) import Gargantext.Database.Prelude (IsDBEnvExtra)
          import Gargantext.Prelude import Gargantext.Prelude
          ...@@ -37,18 +37,21 @@ get_url :: Maybe NodeType ...@@ -37,18 +37,21 @@ get_url :: Maybe NodeType
          -> GargConfig -> GargConfig
          -> Either String Named.ShareLink -> Either String Named.ShareLink
          get_url nt id gc = do get_url nt id gc = do
          let urlHost = T.unpack $ gc ^. gc_frontend_config . fc_url let fc = gc ^. gc_frontend_config
          let urlPort = gc ^. gc_frontend_config . fc_appPort -- 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 t <- maybe (Left "Invalid node Type") Right nt
          i <- maybe (Left "Invalid node ID") Right id 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 -- Include the port the server is running on if this is
          -- localhost, so that share URLs would work out of the box. -- localhost, so that share URLs would work out of the box.
          let !rawURL let !rawURL = T.unpack $ (getPublicUrl fc) <> sharePart
          | "localhost" `isInfixOf` urlHost -- | "localhost" `isInfixOf` urlHost
          = urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i) -- = urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
          | otherwise -- | otherwise
          = urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i) -- = urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
          maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'") maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'")
          (Right . Named.ShareLink) (Right . Named.ShareLink)
          (parseURI rawURL) (parseURI rawURL)
          src/Gargantext/API/Server/Named.hs
          View file @ 1a213aeb
          ...@@ -16,7 +16,7 @@ import Gargantext.API.Admin.EnvTypes (Env) ...@@ -16,7 +16,7 @@ import Gargantext.API.Admin.EnvTypes (Env)
          import Gargantext.API.Admin.FrontEnd (frontEndServer) import Gargantext.API.Admin.FrontEnd (frontEndServer)
          import Gargantext.API.Auth.PolicyCheck () import Gargantext.API.Auth.PolicyCheck ()
          import Gargantext.API.Errors 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.Prelude (GargM)
          import Gargantext.API.Routes.Named import Gargantext.API.Routes.Named
          import Gargantext.API.Server.Named.Public (serverPublicGargAPI) import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
          ...@@ -24,7 +24,7 @@ import Gargantext.API.Swagger (openApiDoc) ...@@ -24,7 +24,7 @@ import Gargantext.API.Swagger (openApiDoc)
          import Gargantext.API.ThrowAll (serverPrivateGargAPI) import Gargantext.API.ThrowAll (serverPrivateGargAPI)
          import Gargantext.Core.Notifications.Dispatcher.WebSocket qualified as Dispatcher import Gargantext.Core.Notifications.Dispatcher.WebSocket qualified as Dispatcher
          import Gargantext.Core.Config (gc_frontend_config, hasConfig) 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.Prelude hiding (Handler, catch)
          import Gargantext.System.Logging (logLocM, LogLevel(..)) import Gargantext.System.Logging (logLocM, LogLevel(..))
          import Paths_gargantext qualified as PG -- cabal magic build module import Paths_gargantext qualified as PG -- cabal magic build module
          ...@@ -40,7 +40,7 @@ serverGargAPI env ...@@ -40,7 +40,7 @@ serverGargAPI env
          , gargForgotPasswordAsyncAPI = forgotPasswordAsync , gargForgotPasswordAsyncAPI = forgotPasswordAsync
          , gargVersionAPI = gargVersion , gargVersionAPI = gargVersion
          , gargPrivateAPI = serverPrivateGargAPI , gargPrivateAPI = serverPrivateGargAPI
          , gargPublicAPI = serverPublicGargAPI (env ^. hasConfig . gc_frontend_config . fc_url_backend_api) , gargPublicAPI = serverPublicGargAPI (env ^. hasConfig . gc_frontend_config . fc_external_url)
          } }
          where where
          gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError)) gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError))
          ...@@ -66,7 +66,7 @@ server env = ...@@ -66,7 +66,7 @@ server env =
          -- (Proxy :: Proxy AuthContext) -- (Proxy :: Proxy AuthContext)
          (transformJSON errScheme) (transformJSON errScheme)
          Dispatcher.wsServer Dispatcher.wsServer
          , frontendAPI = frontEndServer , frontendAPI = frontEndServer (env ^. hasConfig . gc_frontend_config . fc_directory)
          } }
          where where
          transformJSON :: forall a. GargErrorScheme -> GargM Env BackendInternalError a -> Handler a transformJSON :: forall a. GargErrorScheme -> GargM Env BackendInternalError a -> Handler a
          ......
          src/Gargantext/API/Server/Named/Private.hs
          View file @ 1a213aeb
          ...@@ -9,7 +9,7 @@ import Gargantext.API.Errors.Types (BackendInternalError) ...@@ -9,7 +9,7 @@ import Gargantext.API.Errors.Types (BackendInternalError)
          import Gargantext.API.Members (members) import Gargantext.API.Members (members)
          import Gargantext.API.Ngrams.List qualified as List import Gargantext.API.Ngrams.List qualified as List
          import Gargantext.API.Node (annuaireNodeAPI, corpusNodeAPI, nodeAPI, nodeNodeAPI, nodesAPI, roots) 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.Export qualified as CorpusExport
          import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus
          import Gargantext.API.Node.Document.Export (documentExportAPI) import Gargantext.API.Node.Document.Export (documentExportAPI)
          ...@@ -19,7 +19,7 @@ import Gargantext.API.Node.ShareURL ( shareURL ) ...@@ -19,7 +19,7 @@ import Gargantext.API.Node.ShareURL ( shareURL )
          import Gargantext.API.Prelude (GargM) import Gargantext.API.Prelude (GargM)
          import Gargantext.API.Routes (addWithTempFileApi, addCorpusWithQuery) import Gargantext.API.Routes (addWithTempFileApi, addCorpusWithQuery)
          import Gargantext.API.Routes.Named.Private qualified as Named 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.API.Server.Named.Viz qualified as Viz
          import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
          import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny)
          ......
          src/Gargantext/API/Server/Named/Public.hs
          View file @ 1a213aeb
          ...@@ -4,9 +4,9 @@ module Gargantext.API.Server.Named.Public ( ...@@ -4,9 +4,9 @@ module Gargantext.API.Server.Named.Public (
          ) where ) where
          import Control.Lens ((^?), _Just) import Control.Lens ((^?), _Just)
          import Data.List qualified as List
          import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
          import Data.Set qualified as Set import Data.Set qualified as Set
          import Data.Text qualified as T
          import Gargantext.API.Node.File (fileApi) import Gargantext.API.Node.File (fileApi)
          import Gargantext.API.Prelude (serverError, IsGargServer) import Gargantext.API.Prelude (serverError, IsGargServer)
          import Gargantext.API.Public.Types (PublicData(..)) import Gargantext.API.Public.Types (PublicData(..))
          ...@@ -22,29 +22,30 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) ...@@ -22,29 +22,30 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
          import Gargantext.Database.Query.Table.NodeNode (selectPublicNodes) import Gargantext.Database.Query.Table.NodeNode (selectPublicNodes)
          import Gargantext.Database.Schema.Node ( NodePoly(..), node_date, node_hyperdata ) -- (NodePoly(..)) import Gargantext.Database.Schema.Node ( NodePoly(..), node_date, node_hyperdata ) -- (NodePoly(..))
          import Gargantext.Prelude import Gargantext.Prelude
          import Servant import Servant ( ServerError(errBody), err405 )
          import Servant.Client.Core.BaseUrl (BaseUrl(..), showBaseUrl)
          import Servant.Server.Generic (AsServerT) 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 $ serverPublicGargAPI baseUrl = Named.GargPublicAPI $
          Named.GargPublicAPI' Named.GargPublicAPI'
          { publicHomeAPI = api_home baseUrl { publicHomeAPI = apiHome baseUrl
          , publicNodeAPI = Named.NodeAPI api_node , publicNodeAPI = Named.NodeAPI apiNode
          } }
          api_home :: IsGargServer env err m => Text -> Named.HomeAPI (AsServerT m) apiHome :: IsGargServer env err m => BaseUrl -> Named.HomeAPI (AsServerT m)
          api_home baseUrl = Named.HomeAPI $ runDBQuery $ catMaybes apiHome baseUrl = Named.HomeAPI $ runDBQuery $ catMaybes
          <$> map (toPublicData baseUrl) <$> map (toPublicData baseUrl)
          <$> filterPublicDatas <$> filterPublicDatas
          <$> selectPublic <$> selectPublic
          api_node :: IsGargServer env err m => NodeId -> Named.FileAPI (AsServerT m) apiNode :: IsGargServer env err m => NodeId -> Named.FileAPI (AsServerT m)
          api_node nId = Named.FileAPI $ do apiNode nId = Named.FileAPI $ do
          pubNodes <- runDBQuery publicNodes pubNodes <- runDBQuery publicNodes
          -- TODO optimize with SQL -- TODO optimize with SQL
          case Set.member nId pubNodes of (if Set.member nId pubNodes
          False -> serverError $ err405 { errBody = "Not allowed" } then fileApi nId
          True -> fileApi nId else serverError $ err405 { errBody = "Not allowed" })
          ------------------------------------------------------------------------- -------------------------------------------------------------------------
          ...@@ -61,7 +62,7 @@ filterPublicDatas :: [(Node HyperdataFolder, Maybe Int)] ...@@ -61,7 +62,7 @@ filterPublicDatas :: [(Node HyperdataFolder, Maybe Int)]
          filterPublicDatas datas = filterPublicDatas datas =
          map (\(n,mi) -> map (\(n,mi) ->
          let mi' = UnsafeMkNodeId <$> mi in let mi' = UnsafeMkNodeId <$> mi in
          ( _node_id n, (n, maybe [] (:[]) mi' )) ( _node_id n, (n, maybeToList mi' ))
          ) datas ) datas
          & Map.fromListWith (\(n1,i1) (_n2,i2) -> (n1, i1 <> i2)) & Map.fromListWith (\(n1,i1) (_n2,i2) -> (n1, i1 <> i2))
          & Map.filter (not . null . snd) & Map.filter (not . null . snd)
          ...@@ -72,28 +73,29 @@ publicNodes :: HasNodeError err ...@@ -72,28 +73,29 @@ publicNodes :: HasNodeError err
          publicNodes = do publicNodes = do
          candidates <- filterPublicDatas <$> selectPublicNodes candidates <- filterPublicDatas <$> selectPublicNodes
          pure $ Set.fromList pure $ Set.fromList
          $ List.concat $ concatMap (\(n, ns) -> _node_id n : ns) candidates
          $ map (\(n, ns) -> (_node_id n) : ns) candidates
          -- http://localhost:8008/api/v1.0/node/23543/file/download<Paste> -- http://localhost:8008/api/v1.0/node/23543/file/download<Paste>
          -- http://localhost:8000/images/Gargantextuel-212x300.jpg -- http://localhost:8000/images/Gargantextuel-212x300.jpg
          toPublicData :: Text -> (Node HyperdataFolder, [NodeId]) -> Maybe PublicData toPublicData :: BaseUrl -> (Node HyperdataFolder, [NodeId]) -> Maybe PublicData
          toPublicData base (n , mn) = do toPublicData baseUrl (n , mn) = do
          title <- (hd ^? (_Just . hf_data . cf_title)) title <- hd ^? (_Just . hf_data . cf_title)
          abstract <- (hd ^? (_Just . hf_data . cf_desc )) abstract <- hd ^? (_Just . hf_data . cf_desc )
          img <- (Just $ url' mn) -- "images/Gargantextuel-212x300.jpg" img <- Just $ url' mn -- "images/Gargantextuel-212x300.jpg"
          url <- (Just $ url' mn) url <- Just $ url' mn
          date <- Just (show $ utc2year (n^.node_date)) date <- Just (show $ utc2year (n^.node_date))
          database <- (hd ^? (_Just . hf_data . cf_query)) database <- hd ^? (_Just . hf_data . cf_query)
          author <- (hd ^? (_Just . hf_data . cf_authors)) author <- hd ^? (_Just . hf_data . cf_authors)
          pure $ PublicData { .. } pure $ PublicData { .. }
          where where
          hd = head hd = head
          $ filter (\(HyperdataField cd _ _) -> cd == JSON) $ filter (\(HyperdataField cd _ _) -> cd == JSON)
          $ n^. (node_hyperdata . hc_fields) $ n^. (node_hyperdata . hc_fields)
          url' :: [NodeId] -> Text path :: [NodeId] -> Text
          url' mn' = base path mn' = "/api/v1.0"
          <> "/public/" <> "/public/"
          <> (show $ (maybe 0 unNodeId $ head mn')) <> show (maybe 0 unNodeId (head mn'))
          <> "/file/download" <> "/file/download"
          url' :: [NodeId] -> Text
          url' mn' = T.pack $ showBaseUrl $ baseUrl { baseUrlPath = T.unpack $ path mn' }
          src/Gargantext/API/Server/Named/Remote.hs
          View file @ 1a213aeb
          ...@@ -38,7 +38,7 @@ import Gargantext.API.Errors.Types ...@@ -38,7 +38,7 @@ import Gargantext.API.Errors.Types
          import Gargantext.API.Ngrams.Prelude (getNgramsList) import Gargantext.API.Ngrams.Prelude (getNgramsList)
          import Gargantext.API.Ngrams.Types (NgramsList) import Gargantext.API.Ngrams.Types (NgramsList)
          import Gargantext.API.Node.Document.Export (get_document_json) 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.Prelude (IsGargServer)
          import Gargantext.API.Routes.Client (remoteImportClient) import Gargantext.API.Routes.Client (remoteImportClient)
          import Gargantext.API.Routes.Named.Remote qualified as Named import Gargantext.API.Routes.Named.Remote qualified as Named
          ......
          src/Gargantext/Core/Config.hs
          View file @ 1a213aeb
          ...@@ -53,7 +53,7 @@ import Gargantext.Core.Config.Worker (WorkerSettings) ...@@ -53,7 +53,7 @@ import Gargantext.Core.Config.Worker (WorkerSettings)
          import Gargantext.Prelude import Gargantext.Prelude
          import Network.HTTP.Client qualified as HTTP import Network.HTTP.Client qualified as HTTP
          import Servant.Auth.Server (JWTSettings) import Servant.Auth.Server (JWTSettings)
          import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl) import Servant.Client (BaseUrl(..))
          import Toml.Schema import Toml.Schema
          import Toml.Schema.FromValue (typeError) import Toml.Schema.FromValue (typeError)
          ...@@ -142,10 +142,8 @@ instance ToTable GargConfig where ...@@ -142,10 +142,8 @@ instance ToTable GargConfig where
          mkProxyUrl :: GargConfig -> BaseUrl mkProxyUrl :: GargConfig -> BaseUrl
          mkProxyUrl GargConfig{..} = mkProxyUrl GargConfig{ _gc_frontend_config = cfg } =
          case parseBaseUrl (T.unpack $ _fc_url _gc_frontend_config) of (_fc_external_url cfg) { baseUrlPort = _msProxyPort $ _fc_microservices cfg }
          Nothing -> BaseUrl Http "localhost" 80 ""
          Just bh -> bh { baseUrlPort = _msProxyPort $ _fc_microservices _gc_frontend_config }
          class HasConfig env where class HasConfig env where
          ......
          src/Gargantext/Core/Config/Types.hs
          View file @ 1a213aeb
          ...@@ -27,13 +27,14 @@ module Gargantext.Core.Config.Types ...@@ -27,13 +27,14 @@ module Gargantext.Core.Config.Types
          , f_istex_url , f_istex_url
          , PortNumber , PortNumber
          , FrontendConfig(..) , FrontendConfig(..)
          , fc_url , fc_external_url
          , fc_internal_url
          , fc_backend_name , fc_backend_name
          , fc_url_backend_api , fc_directory
          , fc_cors , fc_cors
          , fc_microservices , fc_microservices
          , fc_appPort
          , fc_cookie_settings , fc_cookie_settings
          , getPublicUrl
          , defaultCookieSettings , defaultCookieSettings
          , MicroServicesProxyStatus(..) , MicroServicesProxyStatus(..)
          , microServicesProxyStatus , microServicesProxyStatus
          ...@@ -63,7 +64,7 @@ import Database.PostgreSQL.Simple qualified as PGS ...@@ -63,7 +64,7 @@ import Database.PostgreSQL.Simple qualified as PGS
          import Gargantext.Prelude import Gargantext.Prelude
          import Servant.Auth.Server (CookieSettings(..), JWTSettings, XsrfCookieSettings(..), defaultJWTSettings, readKey, writeKey) import Servant.Auth.Server (CookieSettings(..), JWTSettings, XsrfCookieSettings(..), defaultJWTSettings, readKey, writeKey)
          import Servant.Auth.Server qualified as SAuth 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 System.Directory (doesFileExist)
          import Toml import Toml
          import Toml.Schema import Toml.Schema
          ...@@ -199,35 +200,49 @@ defaultCookieSettings = SAuth.defaultCookieSettings { cookieXsrfSetting = Just x ...@@ -199,35 +200,49 @@ defaultCookieSettings = SAuth.defaultCookieSettings { cookieXsrfSetting = Just x
          -- TODO jwtSettings = defaultJWTSettings -- TODO jwtSettings = defaultJWTSettings
          data FrontendConfig = data FrontendConfig =
          FrontendConfig { _fc_url :: !Text FrontendConfig { _fc_external_url :: !BaseUrl
          , _fc_internal_url :: !BaseUrl
          , _fc_directory :: !FilePath
          , _fc_backend_name :: !Text , _fc_backend_name :: !Text
          , _fc_url_backend_api :: !Text
          , _fc_cors :: !CORSSettings , _fc_cors :: !CORSSettings
          , _fc_microservices :: !MicroServicesSettings , _fc_microservices :: !MicroServicesSettings
          , _fc_appPort :: !PortNumber
          , _fc_cookie_settings :: !CookieSettings , _fc_cookie_settings :: !CookieSettings
          } }
          deriving (Generic, Show) deriving (Generic, Show)
          instance FromValue FrontendConfig where instance FromValue FrontendConfig where
          fromValue = parseTableFromValue $ do 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_backend_name <- reqKey "backend_name"
          _fc_url_backend_api <- reqKey "url_backend_api"
          _fc_cors <- reqKey "cors" _fc_cors <- reqKey "cors"
          _fc_microservices <- reqKey "microservices" _fc_microservices <- reqKey "microservices"
          let _fc_appPort = 3000
          return $ FrontendConfig { _fc_cookie_settings = defaultCookieSettings, .. } return $ FrontendConfig { _fc_cookie_settings = defaultCookieSettings, .. }
          instance ToValue FrontendConfig where instance ToValue FrontendConfig where
          toValue = defaultTableToValue toValue = defaultTableToValue
          instance ToTable FrontendConfig where instance ToTable FrontendConfig where
          toTable (FrontendConfig { .. }) = table [ "url" .= _fc_url toTable (FrontendConfig { .. }) = table
          , "backend_name" .= _fc_backend_name [ "external_url" .= (T.pack $ showBaseUrl _fc_external_url)
          , "url_backend_api" .= _fc_url_backend_api , "internal_url" .= (T.pack $ showBaseUrl _fc_internal_url)
          , "cors" .= _fc_cors , "directory" .= _fc_directory
          , "microservices" .= _fc_microservices ] , "backend_name" .= _fc_backend_name
          , "cors" .= _fc_cors
          , "microservices" .= _fc_microservices ]
          makeLenses ''FrontendConfig makeLenses ''FrontendConfig
          getPublicUrl :: FrontendConfig -> Text
          getPublicUrl (FrontendConfig { .. }) = T.pack $ showBaseUrl _fc_external_url
          data MicroServicesProxyStatus data MicroServicesProxyStatus
          = PXY_enabled PortNumber = PXY_enabled PortNumber
          | PXY_disabled | PXY_disabled
          ......
          src/Gargantext/Core/Mail.hs
          View file @ 1a213aeb
          ...@@ -16,7 +16,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) ...@@ -16,7 +16,7 @@ import Control.Monad.Trans.Control (MonadBaseControl)
          import Data.List qualified as List import Data.List qualified as List
          import Data.Text (splitOn) import Data.Text (splitOn)
          import Gargantext.Core.Config (gc_frontend_config, HasConfig(..)) 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.Config.Mail (gargMail, GargMail(..), MailConfig)
          import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
          import Gargantext.Database.Schema.User (UserLight(..)) import Gargantext.Database.Schema.User (UserLight(..))
          ...@@ -75,7 +75,7 @@ mail mailCfg model = do ...@@ -75,7 +75,7 @@ mail mailCfg model = do
          (m,u) = email_to model (m,u) = email_to model
          subject = email_subject model subject = email_subject model
          body = emailWith (ServerAddress (view (gc_frontend_config . fc_backend_name) cfg) 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 liftBase $ gargMail mailCfg (GargMail { gm_to = m
          , gm_name = Just u , gm_name = Just u
          , gm_subject = subject , gm_subject = subject
          ......
          src/Gargantext/Core/NodeStory.hs
          View file @ 1a213aeb
          ...@@ -43,27 +43,31 @@ TODO: ...@@ -43,27 +43,31 @@ TODO:
          {-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
          {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
          {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
          {-# LANGUAGE ScopedTypeVariables #-}
          module Gargantext.Core.NodeStory module Gargantext.Core.NodeStory
          ( module Gargantext.Core.NodeStory.Types ( module Gargantext.Core.NodeStory.Types
          , getNodesArchiveHistory , getNodesArchiveHistory
          , Archive(..) , Archive(..)
          , ArchiveStateForest
          , nodeExists , nodeExists
          , getNodesIdWithType , getNodesIdWithType
          , mkNodeStoryEnv , mkNodeStoryEnv
          , upsertNodeStories , upsertNodeStories
          -- , getNodeStory
          , getNodeStory' , getNodeStory'
          , nodeStoriesQuery , nodeStoriesQuery
          , currentVersion , currentVersion
          , archiveStateFromList , archiveStateFromList
          , archiveStateToList , archiveStateToList
          , fixNodeStoryVersions , fixNodeStoryVersions
          , fixChildrenDuplicatedAsParents , getParentsChildren
          , getParentsChildren ) -- * Operations on trees and forests
          where , buildForest
          , pruneForest
          import Control.Lens ((%~), non, _Just, at, over) ) where
          import Control.Lens ((%~), non, _Just, at, over, Lens')
          import Data.ListZipper
          import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
          import Data.Set qualified as Set import Data.Set qualified as Set
          import Database.PostgreSQL.Simple qualified as PGS import Database.PostgreSQL.Simple qualified as PGS
          ...@@ -77,6 +81,73 @@ import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) ) ...@@ -77,6 +81,73 @@ import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
          import Gargantext.Database.Admin.Config () import Gargantext.Database.Admin.Config ()
          import Gargantext.Database.Prelude import Gargantext.Database.Prelude
          import Gargantext.Prelude hiding (to) 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 getNodeStory' :: NodeId -> DBQuery err x ArchiveList
          ...@@ -94,15 +165,6 @@ getNodeStory' nId = do ...@@ -94,15 +165,6 @@ getNodeStory' nId = do
          -- `node_id`, `version` and there is a M2M table -- `node_id`, `version` and there is a M2M table
          -- `node_stories_ngrams` without the `version` colum? Then we would -- `node_stories_ngrams` without the `version` colum? Then we would
          -- have `version` in only one place. -- 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 pure $ foldl' combine initArchive dbData
          where where
          -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine` -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
          ...@@ -174,29 +236,18 @@ updateNodeStory nodeId currentArchive newArchive = do ...@@ -174,29 +236,18 @@ updateNodeStory nodeId currentArchive newArchive = do
          --printDebug "[updateNodeStory] delete applied" () --printDebug "[updateNodeStory] delete applied" ()
          updateArchiveStateList nodeId (newArchive ^. a_version) updates updateArchiveStateList nodeId (newArchive ^. a_version) updates
          --printDebug "[updateNodeStory] update applied" () --printDebug "[updateNodeStory] update applied" ()
          pure () 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 -> ArchiveList -> DBUpdate err ()
          upsertNodeStories nodeId newArchive = do upsertNodeStories nodeId newArchive = do
          -- printDebug "[upsertNodeStories] START nId" nId -- printDebug "[upsertNodeStories] START nId" nId
          -- printDebug "[upsertNodeStories] locking nId" nId -- printDebug "[upsertNodeStories] locking nId" nId
          (NodeStory m) <- getNodeStory nodeId (NodeStory m) <- getNodeStory nodeId
          case Map.lookup nodeId m of case Map.lookup nodeId m of
          Nothing -> do Nothing ->
          _ <- insertNodeStory nodeId newArchive void $ insertNodeStory nodeId newArchive
          pure () Just currentArchive ->
          Just currentArchive -> do void $ updateNodeStory nodeId currentArchive newArchive
          _ <- updateNodeStory nodeId currentArchive newArchive
          pure ()
          -- 3. Now we need to set versions of all node state to be the same -- 3. Now we need to set versions of all node state to be the same
          updateNodeStoryVersion nodeId newArchive updateNodeStoryVersion nodeId newArchive
          ...@@ -216,8 +267,9 @@ nodeStoryInc ns@(NodeStory nls) nId = do ...@@ -216,8 +267,9 @@ nodeStoryInc ns@(NodeStory nls) nId = do
          -- `nre_parent` and `nre_children`. We want to make sure that all -- `nre_parent` and `nre_children`. We want to make sure that all
          -- children entries (i.e. ones that have `nre_parent`) have the same -- children entries (i.e. ones that have `nre_parent`) have the same
          -- `list` as their parent entry. -- `list` as their parent entry.
          fixChildrenInNgrams :: NgramsState' -> NgramsState' -- NOTE(adn) Currently unused, see !424 for context.
          fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed _fixChildrenInNgrams :: NgramsState' -> NgramsState'
          _fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
          where where
          (nsParents, nsChildren) = getParentsChildren ns (nsParents, nsChildren) = getParentsChildren ns
          parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents
          ...@@ -233,29 +285,56 @@ fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed ...@@ -233,29 +285,56 @@ fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
          -- | (#281) Sometimes, when we upload a new list, a child can be left -- | (#281) Sometimes, when we upload a new list, a child can be left
          -- without a parent. Find such ngrams and set their 'root' and -- without a parent. Find such ngrams and set their 'root' and
          -- 'parent' to 'Nothing'. -- 'parent' to 'Nothing'.
          fixChildrenWithNoParent :: NgramsState' -> NgramsState' fixChildrenWithNoParent :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
          fixChildrenWithNoParent ns = archiveStateFromList $ nsParents <> nsChildrenFixed -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
          fixChildrenWithNoParent = Map.map go
          where where
          (nsParents, nsChildren) = getParentsChildren ns -- If the forest is somehow empty, do nothing. Otherwise, build a zipper and run
          parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents -- the algorithm.
          go :: Forest (NgramsTerm, NgramsRepoElement)
          nsChildrenFixFunc (nt, t, nre) = -> Forest (NgramsTerm, NgramsRepoElement)
          ( nt go fs = case zipper fs of
          , t Nothing -> fs
          , nre { _nre_root = root Just zfs -> maybe mempty toList $ execListZipperOp fixDanglingChildrenInForest zfs
          , _nre_parent = parent }
          ) fixDanglingChildrenInForest :: ListZipperOp (Tree (NgramsTerm, NgramsRepoElement)) ()
          where fixDanglingChildrenInForest = do
          (root, parent) = case parentNtMap ^. at (nre ^. nre_parent . _Just) . _Just . at t of z@(ListZipper l a r) <- get
          Just _ -> (nre ^. nre_root, nre ^. nre_parent) when (isOrphan (l <> r) a) $ void $ modifyFocus detachFromParent
          Nothing -> (Nothing, Nothing) unless (atEnd z) $ do
          moveRight
          nsChildrenFixed = nsChildrenFixFunc <$> nsChildren 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 -- | Sometimes children can also become parents (e.g. #313). Find such
          -- | children and remove them from the list. -- | children and remove them from the list.
          fixChildrenDuplicatedAsParents :: NgramsState' -> NgramsState' -- NOTE(adn) Currently unused, see !424 for context.
          fixChildrenDuplicatedAsParents ns = archiveStateFromList $ nsChildren <> nsParentsFixed _fixChildrenDuplicatedAsParents :: NgramsState' -> NgramsState'
          _fixChildrenDuplicatedAsParents ns = archiveStateFromList $ nsChildren <> nsParentsFixed
          where where
          (nsParents, nsChildren) = getParentsChildren ns (nsParents, nsChildren) = getParentsChildren ns
          parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
          ...@@ -280,34 +359,18 @@ getParentsChildren ns = (nsParents, nsChildren) ...@@ -280,34 +359,18 @@ getParentsChildren ns = (nsParents, nsChildren)
          mkNodeStoryEnv :: NodeStoryEnv err mkNodeStoryEnv :: NodeStoryEnv err
          mkNodeStoryEnv = do mkNodeStoryEnv = do
          -- tvar <- nodeStoryVar pool Nothing []
          let saver_immediate nId a = do 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 -- |NOTE Fixing a_state is kinda a hack. We shouldn't land
          -- |with bad state in the first place. -- |with bad state in the first place.
          upsertNodeStories nId $ upsertNodeStories nId $
          a & a_state %~ ( a & a_state %~ (
          fixChildrenDuplicatedAsParents destroyArchiveStateForest
          . fixChildrenInNgrams
          . fixChildrenWithNoParent . fixChildrenWithNoParent
          . buildForestsFromArchiveState
          ) )
          let archive_saver_immediate nId a = do let archive_saver_immediate nId a = do
          insertNodeArchiveHistory nId (a ^. a_version) $ reverse $ a ^. a_history insertNodeArchiveHistory nId (a ^. a_version) $ reverse $ a ^. a_history
          pure $ 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 NodeStoryEnv { _nse_saver = saver_immediate
          , _nse_archive_saver = archive_saver_immediate , _nse_archive_saver = archive_saver_immediate
          ...@@ -355,72 +418,3 @@ fixNodeStoryVersions = runDBTx $ do ...@@ -355,72 +418,3 @@ fixNodeStoryVersions = runDBTx $ do
          [PGS.Only (Just maxVersion)] -> do [PGS.Only (Just maxVersion)] -> do
          void $ mkPGUpdate updateVerQuery (maxVersion, nId, ngramsType) void $ mkPGUpdate updateVerQuery (maxVersion, nId, ngramsType)
          _ -> panicTrace "Should get only 1 result!" _ -> 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/Viz/Chart.hs
          View file @ 1a213aeb
          ...@@ -17,7 +17,7 @@ import Data.List qualified as List ...@@ -17,7 +17,7 @@ import Data.List qualified as List
          import Data.Map.Strict (toList) import Data.Map.Strict (toList)
          import Data.Set qualified as Set import Data.Set qualified as Set
          import Data.Vector qualified as V 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.Tools ( filterListWithRoot, getListNgrams, getRepo, mapTermListRoot )
          import Gargantext.API.Ngrams.Types ( NgramsTerm(NgramsTerm) ) import Gargantext.API.Ngrams.Types ( NgramsTerm(NgramsTerm) )
          import Gargantext.Core.NodeStory.Types ( NodeStoryEnv ) import Gargantext.Core.NodeStory.Types ( NodeStoryEnv )
          ...@@ -91,4 +91,4 @@ treeData env cId nt lt = do ...@@ -91,4 +91,4 @@ treeData env cId nt lt = do
          cs' <- HashMap.map (Set.map contextId2NodeId) <$> getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms cs' <- HashMap.map (Set.map contextId2NodeId) <$> getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms
          m <- getListNgrams env ls nt m <- getListNgrams env ls nt
          pure $ V.fromList $ toTree lt cs' m pure $ V.fromList $ getNgramsForest $ toNgramsForest lt cs' m
          stack.yaml
          View file @ 1a213aeb
          ...@@ -18,6 +18,7 @@ ...@@ -18,6 +18,7 @@
          - "data-default-0.8.0.0" - "data-default-0.8.0.0"
          - "data-default-class-0.2.0.0" - "data-default-class-0.2.0.0"
          - "deferred-folds-0.9.18.7" - "deferred-folds-0.9.18.7"
          - "deriving-compat-0.6.7"
          - "entropy-0.4.1.11" - "entropy-0.4.1.11"
          - "file-embed-lzma-0.1" - "file-embed-lzma-0.1"
          - "foldl-1.4.18" - "foldl-1.4.18"
          ...@@ -38,6 +39,7 @@ ...@@ -38,6 +39,7 @@
          - "jose-0.10.0.1" - "jose-0.10.0.1"
          - "language-c-0.10.0" - "language-c-0.10.0"
          - "linear-1.23" - "linear-1.23"
          - "list-zipper-0.0.12"
          - "massiv-1.0.4.1" - "massiv-1.0.4.1"
          - "megaparsec-9.7.0" - "megaparsec-9.7.0"
          - "microlens-th-0.4.3.16" - "microlens-th-0.4.3.16"
          ...@@ -367,7 +369,7 @@ flags: ...@@ -367,7 +369,7 @@ flags:
          gargantext: gargantext:
          "enable-benchmarks": false "enable-benchmarks": false
          "no-phylo-debug-logs": true "no-phylo-debug-logs": true
          "test-crypto": false "test-crypto": true
          graphviz: graphviz:
          "test-parsing": false "test-parsing": false
          hashable: hashable:
          ...@@ -540,8 +542,6 @@ flags: ...@@ -540,8 +542,6 @@ flags:
          transformers: true transformers: true
          tasty: tasty:
          unix: true unix: true
          "tasty-golden":
          "build-example": false
          "text-format": "text-format":
          developer: false developer: false
          "text-metrics": "text-metrics":
          ......
          test-data/test_config.toml
          View file @ 1a213aeb
          [frontend] [frontend]
          url = "http://localhost" external_url = "http://localhost"
          internal_url = "http://localhost"
          directory = "./purescript-gargantext/dist"
          backend_name = "localhost" backend_name = "localhost"
          url_backend_api = "http://localhost:8008/api/v1.0"
          jwt_settings = "TODO" jwt_settings = "TODO"
          [frontend.cors] [frontend.cors]
          ......
          test/Test/API/Setup.hs
          View file @ 1a213aeb
          ...@@ -24,7 +24,7 @@ import Gargantext.API.Admin.EnvTypes (Env (..), env_dispatcher) ...@@ -24,7 +24,7 @@ import Gargantext.API.Admin.EnvTypes (Env (..), env_dispatcher)
          import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
          import Gargantext.API.Prelude import Gargantext.API.Prelude
          import Gargantext.Core.Config hiding (jwtSettings) 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.Notifications (withNotifications)
          import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
          import Gargantext.Database.Action.Flow import Gargantext.Database.Action.Flow
          ...@@ -37,7 +37,7 @@ import Gargantext.Database.Prelude ...@@ -37,7 +37,7 @@ import Gargantext.Database.Prelude
          import Gargantext.Database.Query.Table.Node (getOrMkList) import Gargantext.Database.Query.Table.Node (getOrMkList)
          import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..)) import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
          import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp) import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
          import Gargantext.Prelude hiding (catches, Handler) import Gargantext.Prelude hiding (catches, to, Handler)
          import Gargantext.System.Logging import Gargantext.System.Logging
          import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.TLS (newTlsManager)
          import Network.HTTP.Types import Network.HTTP.Types
          ...@@ -48,6 +48,7 @@ import Network.Wai.Handler.Warp.Internal ...@@ -48,6 +48,7 @@ import Network.Wai.Handler.Warp.Internal
          import Network.WebSockets qualified as WS import Network.WebSockets qualified as WS
          import Prelude hiding (show) import Prelude hiding (show)
          import Servant.Auth.Client () import Servant.Auth.Client ()
          import Servant.Client.Core (baseUrlPort)
          import Test.Database.Setup (withTestDB) import Test.Database.Setup (withTestDB)
          import Test.Database.Types import Test.Database.Types
          import UnliftIO qualified import UnliftIO qualified
          ...@@ -72,7 +73,9 @@ newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> ...@@ -72,7 +73,9 @@ newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port ->
          newTestEnv testEnv logger port = do newTestEnv testEnv logger port = do
          !manager_env <- newTlsManager !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 -- dbParam <- pure $ testEnvToPgConnectionInfo testEnv
          -- !pool <- newPool dbParam -- !pool <- newPool dbParam
          ......
          test/Test/API/UpdateList.hs
          View file @ 1a213aeb
          ...@@ -27,23 +27,23 @@ module Test.API.UpdateList ( ...@@ -27,23 +27,23 @@ module Test.API.UpdateList (
          , mkNewWithForm , mkNewWithForm
          ) where ) where
          import Control.Lens (mapped, over)
          import Control.Monad.Fail (fail) import Control.Monad.Fail (fail)
          import Data.Aeson qualified as JSON import Data.Aeson qualified as JSON
          import Data.Aeson.QQ 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.Map.Strict qualified as Map
          import Data.Set qualified as Set import Data.Map.Strict.Patch qualified as PM
          import Data.Text.IO qualified as TIO import Data.Patch.Class
          import Data.Text qualified as T import Data.Text qualified as T
          import Data.Text.IO qualified as TIO
          import Fmt import Fmt
          import Gargantext.API.Admin.Auth.Types (Token) import Gargantext.API.Admin.Auth.Types (Token)
          import Gargantext.API.Errors import Gargantext.API.Errors
          import Gargantext.API.HashedResponse import Gargantext.API.HashedResponse
          import Gargantext.API.Ngrams qualified as APINgrams
          import Gargantext.API.Ngrams.List ( ngramsListFromTSVData ) import Gargantext.API.Ngrams.List ( ngramsListFromTSVData )
          import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..)) import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..))
          import Gargantext.API.Ngrams qualified as APINgrams import Gargantext.API.Ngrams.Types as NT
          import Gargantext.API.Ngrams.Types
          import Gargantext.API.Node.Corpus.New.Types qualified as FType import Gargantext.API.Node.Corpus.New.Types qualified as FType
          import Gargantext.API.Node.Types import Gargantext.API.Node.Types
          import Gargantext.API.Routes.Named import Gargantext.API.Routes.Named
          ...@@ -51,8 +51,8 @@ import Gargantext.API.Routes.Named.Corpus (addWithTempFileEp) ...@@ -51,8 +51,8 @@ import Gargantext.API.Routes.Named.Corpus (addWithTempFileEp)
          import Gargantext.API.Routes.Named.Node import Gargantext.API.Routes.Named.Node
          import Gargantext.API.Routes.Named.Private import Gargantext.API.Routes.Named.Private
          import Gargantext.API.Worker (workerAPIPost) import Gargantext.API.Worker (workerAPIPost)
          import Gargantext.Core.Config
          import Gargantext.Core qualified as Lang import Gargantext.Core qualified as Lang
          import Gargantext.Core.Config
          import Gargantext.Core.Text.Corpus.Query (RawQuery(..)) import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
          import Gargantext.Core.Text.List.Social import Gargantext.Core.Text.List.Social
          import Gargantext.Core.Text.Ngrams import Gargantext.Core.Text.Ngrams
          ...@@ -64,7 +64,7 @@ import Gargantext.Database.Query.Facet qualified as Facet ...@@ -64,7 +64,7 @@ import Gargantext.Database.Query.Facet qualified as Facet
          import Gargantext.Prelude hiding (get) import Gargantext.Prelude hiding (get)
          import Network.Wai.Handler.Warp qualified as Wai import Network.Wai.Handler.Warp qualified as Wai
          import Paths_gargantext (getDataFileName) import Paths_gargantext (getDataFileName)
          import qualified Prelude import Prelude qualified
          import Servant.Client.Streaming import Servant.Client.Streaming
          import System.FilePath import System.FilePath
          import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser, alice) import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser, alice)
          ...@@ -108,6 +108,17 @@ uploadJSONList log_cfg port token cId pathToNgrams clientEnv = do ...@@ -108,6 +108,17 @@ uploadJSONList log_cfg port token cId pathToNgrams clientEnv = do
          pure listId 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 tests :: Spec
          ...@@ -141,53 +152,180 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do ...@@ -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 it "does not create duplicates when uploading JSON (#313)" $ \(SpecContext testEnv port app _) -> do
          cId <- newCorpusForUser testEnv "alice" cId <- newCorpusForUser testEnv "alice"
          let log_cfg = (test_config testEnv) ^. gc_logging let log_cfg = (test_config testEnv) ^. gc_logging
          withApplication app $ do withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
          -- this term is imported from the .json file -- The test data has a single term called "abelian group". In this test
          let importedTerm = NgramsTerm "abelian group" -- we will try grouping together "abelian group" and "new abelian group".
          -- this is the new term, under which importedTerm will be grouped
          let newTerm = NgramsTerm "new abelian group"
          listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv 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 -- The #313 error is about importedTerm being duplicated
          -- in a specific case -- 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 nre = NgramsRepoElement 1 MapTerm Nothing Nothing (MSet mempty)
          let patch = PM.fromList [ let patch = PM.fromList [
          ( newTerm ( "new abelian group"
          , NgramsReplace { _patch_old = Nothing , NgramsReplace { _patch_old = Nothing
          , _patch_new = Just nre } ) , _patch_new = Just nre } )
          ] ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst patch)) clientEnv _ <- 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) -- check that new term is added (with no parent)
          checkNgrams [ (newTerm, []) checkNgrams getNgrams [json| { "version": 1
          , (importedTerm, []) ] ,"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 -- now patch it so that we have a group
          let patchChildren = PM.fromList [ let patchChildren = PM.fromList [
          ( newTerm ( "new abelian group"
          , toNgramsPatch [importedTerm] ) , toNgramsPatch ["abelian group"] )
          ] ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 32 $ NgramsTablePatch $ fst patchChildren)) clientEnv _ <- 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 -- 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 -- finally, upload the list again, the group should be as
          -- it was before (the bug in #313 was that "abelian group" -- it was before (the bug in #313 was that "abelian group"
          ...@@ -195,14 +333,31 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do ...@@ -195,14 +333,31 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
          _ <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv _ <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
          -- old (imported) term shouldn't become parentless -- old (imported) term shouldn't become parentless
          -- (#313 error was that we had [newTerm, importedTerm] instead) -- (#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,
          -- NOTE: Unfortunately, I'm not able to reproduce this -- i.e. important doesn't change the topology.
          -- error here, though I tried. Something is missing, maybe checkNgrams getNgrams [json| {"version": 2
          -- some nodestory integration with tests? ,"count":2
          checkNgrams [ (newTerm, [importedTerm]) ] ,"data":[
          {"ngrams":"abelian group"
          pure () ,"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 describe "POST /api/v1.0/lists/:id/csv/add/form/async (CSV)" $ do
          ......
          test/Test/Instances.hs
          View file @ 1a213aeb
          ...@@ -12,6 +12,7 @@ Portability : POSIX ...@@ -12,6 +12,7 @@ Portability : POSIX
          {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}
          {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
          {-# LANGUAGE ScopedTypeVariables #-}
          module Test.Instances module Test.Instances
          where where
          ...@@ -382,15 +383,133 @@ instance Arbitrary DET.WSRequest where ...@@ -382,15 +383,133 @@ instance Arbitrary DET.WSRequest where
          , pure DET.WSDeauthorize ] , 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 -- Ngrams
          instance Arbitrary a => Arbitrary (Ngrams.MSet a) 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 instance Arbitrary Ngrams.NgramsTerm where
          arbitrary = Ngrams.NgramsTerm <$> arbitrary = arbitraryNgramsTerm
          -- we take into accoutn the fact, that tojsonkey strips the text
          (arbitrary `suchThat` (\t -> t == T.strip t))
          instance Arbitrary Ngrams.TabType where arbitrary = arbitraryBoundedEnum instance Arbitrary Ngrams.TabType where arbitrary = arbitraryBoundedEnum
          instance Arbitrary Ngrams.NgramsElement where 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 instance Arbitrary Ngrams.NgramsTable where
          arbitrary = pure ngramsMockTable arbitrary = pure ngramsMockTable
          instance Arbitrary Ngrams.OrderBy where arbitrary = arbitraryBoundedEnum instance Arbitrary Ngrams.OrderBy where arbitrary = arbitraryBoundedEnum
          ......
          test/Test/Ngrams/Query.hs
          View file @ 1a213aeb
          {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
          module Test.Ngrams.Query (tests) where module Test.Ngrams.Query (tests, mkMapTerm) where
          import Control.Monad import Control.Monad
          import Data.Coerce import Data.Coerce
          ......
          test/Test/Offline/Ngrams.hs
          View file @ 1a213aeb
          {-# LANGUAGE QuasiQuotes #-}
          {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
          {-# LANGUAGE ViewPatterns #-}
          module Test.Offline.Ngrams (tests) where module Test.Offline.Ngrams (tests) where
          import Prelude import Prelude
          import Control.Lens
          import Data.Map.Strict qualified as Map
          import Data.Text qualified as T 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.API.Ngrams.Types qualified as NT
          import Gargantext.Core import Gargantext.Core
          import Gargantext.Core.Text.Terms.Mono (isSep)
          import Gargantext.Core.Text.Terms.WithList import Gargantext.Core.Text.Terms.WithList
          import Gargantext.Core.Types import Gargantext.Core.Types
          import Gargantext.Database.Action.Flow.Utils (docNgrams) import Gargantext.Database.Action.Flow.Utils (docNgrams)
          import Gargantext.Database.Schema.Context
          import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
          import Gargantext.Database.Schema.Context
          import Test.HUnit
          import Test.Hspec
          import Test.Instances () import Test.Instances ()
          import Test.Ngrams.Query (mkMapTerm)
          import Test.QuickCheck import Test.QuickCheck
          import Test.Hspec import Test.QuickCheck qualified as QC
          import Control.Lens import Data.Tree
          import qualified Test.QuickCheck as QC import Text.RawString.QQ (r)
          import Gargantext.Core.Text.Terms.Mono (isSep) import Data.Char (isSpace)
          import Data.Map.Strict (Map)
          import Test.Hspec.QuickCheck (prop)
          genScientificText :: Gen T.Text genScientificText :: Gen T.Text
          ...@@ -89,6 +101,31 @@ tests = describe "Ngrams" $ do ...@@ -89,6 +101,31 @@ tests = describe "Ngrams" $ do
          it "return results for non-empty input terms" $ property testBuildPatternsNonEmpty it "return results for non-empty input terms" $ property testBuildPatternsNonEmpty
          describe "docNgrams" $ do describe "docNgrams" $ do
          it "always matches if the input text contains any of the terms" $ property testDocNgramsOKMatch 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 -> Property
          testDocNgramsOKMatch lang (DocumentWithMatches ts doc) = testDocNgramsOKMatch lang (DocumentWithMatches ts doc) =
          ...@@ -103,3 +140,166 @@ testBuildPatternsNonEmpty :: Lang -> NonEmptyList NgramsTermNonEmpty -> Property ...@@ -103,3 +140,166 @@ testBuildPatternsNonEmpty :: Lang -> NonEmptyList NgramsTermNonEmpty -> Property
          testBuildPatternsNonEmpty lang ts = testBuildPatternsNonEmpty lang ts =
          let ts' = map (NT.NgramsTerm . unNgramsTermNonEmpty) $ getNonEmpty ts let ts' = map (NT.NgramsTerm . unNgramsTermNonEmpty) $ getNonEmpty ts
          in counterexample "buildPatterns returned no results" $ length (buildPatternsWith lang ts') > 0 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
          |]
          Markdown is supported
          0% or
          You are about to add 0 people to the discussion. Proceed with caution.
          Finish editing this message first!
          Please register or to comment