Merge branch 'dev' into 341-dev-websockets

CHANGELOG.md

+## Version 0.0.7.1.14
+
+* [BACK][FIX][Write Frame microservice proxy improvements (#364)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/364)
+
+## Version 0.0.7.1.13
+
+* [FRONT][ERGO][[Node Phylo] Default initial behaviour on clicking a Phylo node for the 1st time (#582)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/582)
+* [BACK][PROXY][Enabling the microservices proxy trigger endless "Refresh to update" modals (#374)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/374)
+* [BACK][REFACT][[REFACTORING] renaming Corpus to Document for HAL related file (#372)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/372)
+
+## Version 0.0.7.1.12
+
+* [BACK][INFRA][Microservices notes proxy doesn't work with local CodiMD (#370)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/370)
+* [BACK][DOC][[Documentation] Document development tooling (#371)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/371)
+
+## Version 0.0.7.1.11
+
+* [BACK][SECURITY][Allow the microservices proxy to be disabled or enabled by configuration settings (#369)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/369)
+
+## Version 0.0.7.1.10
+
+* [BACK][FIX][Improving message error from the TSV import (#361)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/361)
+* [BACK][FIX][Creation of corpus from HAL's API crash (#366)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/366)
+* [BACK][FIX][[Documentation] Improve README (#365)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/365)
+
 ## Version 0.0.7.1.9
 
 * [BACK][FIX][Write Frame microservice proxy improvements (#364)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/364)

bin/gargantext-cli/CLI/Server/Routes.hs

@@ -18,6 +18,7 @@ import Options.Applicative
 import Prelude
 import Servant.API
 import Servant.API.Routes
+import Servant.API.WebSocket qualified as WS (WebSocketPending)
 import Servant.Auth qualified as Servant
 
 routesCmd :: Mod CommandFields CLI
@@ -42,6 +43,9 @@ export_p = CLIR_export <$>
 instance HasRoutes api => HasRoutes (Servant.Auth xs a :> api) where
   getRoutes = getRoutes @api
 
+instance HasRoutes WS.WebSocketPending where
+  getRoutes = []
+
 instance HasRoutes Raw where
   getRoutes = []
 

cabal.project

@@ -93,7 +93,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/hal.git
-    tag: 3a7d039e07c8564e8ff84ef88480924d18aa5018
+    tag: 1dbd939257d33126e49d2679375553df1f2eebc5
 
 source-repository-package
     type: git

cabal.project.freeze

@@ -93,6 +93,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.c2hs ==0.28.8,
              c2hs +base3 -regression,
              any.cabal-doctest ==1.0.9,
+             any.cache ==0.1.3.0,
              any.call-stack ==0.4.0,
              any.case-insensitive ==1.2.1.0,
              any.cassava ==0.5.3.0,
@@ -277,6 +278,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.hspec-wai ==0.11.1,
              any.hspec-wai-json ==0.11.0,
              any.hstatistics ==0.3.1,
+             any.http-accept ==0.2,
              any.http-api-data ==0.5,
              http-api-data -use-text-show,
              any.http-client ==0.7.14,
@@ -555,6 +557,8 @@ constraints: any.Cabal ==3.8.1.0,
              streaming-commons -use-bytestring-builder,
              any.strict ==0.5,
              any.string-conversions ==0.4.0.1,
+             any.stringsearch ==0.3.6.6,
+             stringsearch -base3 +base4,
              any.swagger2 ==2.8.7,
              any.syb ==0.7.2.4,
              any.system-cxx-std-lib ==1.0,
@@ -664,6 +668,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.wai-extra ==3.1.13.0,
              wai-extra -build-example,
              any.wai-logger ==2.4.0,
+             any.wai-util ==0.8,
              any.wai-websockets ==3.0.1.2,
              wai-websockets +example,
              any.warp ==3.3.25,

docs/editor_setup.md

+Editor Setup
+=============
+
+This document tells you how to turn VSCodium into a Haskell integrated
+development environment (IDE). Hopefully, the process looks roughly the same
+with any editor that supports the language server protocol (LSP).
+
+1. Install [the VSCodium editor](https://vscodium.com/#install)
+2. Install [direnv](https://direnv.net/docs/installation.html) on your system
+3. Install [GHCup](https://www.haskell.org/ghcup/install/).
+   During the installation process, it will ask you whether to install
+   haskell-language-server (HLS); accept.
+4. Install the following VSCodium extensions using VSCodium's built-in
+   package manager (the "Extensions" tab on the left):
+   - [direnv](https://open-vsx.org/vscode/item?itemName=mkhl.direnv).
+     Warning: there are several extensions with that name; choose the one by `mkhl`
+   - [Haskell](https://open-vsx.org/vscode/item?itemName=haskell.haskell)
+
+Restart VSCodium, open the `haskell-gargantext` project. Wait a few seconds;
+you might get a popup telling you that GHCup needs to download some version
+of GHC; accept.
+
+Now *if everything went well*, you should have Haskell intellisense working
+in your editor: hover over a symbol to get its type and documentation,
+right-click a symbol and click "Jump to definition" to jump to its definition,
+etc.
+
+Sadly, there is a good chance that something did go wrong. To help you
+troubleshoot, here's a rundown of what should have happened under the hood when
+you opened the project — assuming I didn't misunderstand anything:
+1. The `direnv` extension sees the `.envrc` file at the root of the project,
+   and sets the environment variables accordingly (all `.envrc` actually says
+   is to use a Nix shell).
+2. The `haskell` extension looks up what version of GHC is needed and tells that
+   to GHCup.
+3. If needed, GHCup downloads the right version of GHC for the project and adds
+   it to its collection of GHC compilers in `~/.ghcup/ghc/`
+4. Now the `haskell` extension has everything it needs.
+
+Things to try if something goes wrong
+--------------------------------------
+
+- Make sure that you have compiled the project before.
+
+- The current HLS version might be too recent to work with your GHC version.
+  To check that and use an adequate HLS version:
+  - Check out the project's GHC version around the beginning of `cabal.project`;
+  - Look up the corresponding "Last supporting HLS version" in [this table](https://haskell-language-server.readthedocs.io/en/latest/support/ghc-version-support.html#current-ghc-version-support-status).
+    For instance, if the project's GHC version is 9.4.7, you need HLS v2.5.0.0 *at most*.
+  - Tell GHCup to compile the corresponding version of HLS based the corresponding version of GHC,
+    with the following command (again, using GHC 9.4.7 as an example):
+    ```shell
+    $ ghcup compile hls --version 2.5.0.0 --ghc 9.4.7
+    ```
+  Now in principle the VSCodium `haskell` extension should have everything
+  it needs to provide Intellisense.

docs/running_commands.md

+Running commands from the REPL
+===============================
+
+You can interact with the Gargantext server directly from GHCI, the Haskell REPL.
+This saves you the need to have the frontend running, and it allows you
+to interact directly using types and functions defined in the backend source.
+
+Launching and setting up the REPL
+----------------------------------
+
+**From within a Nix shell** (as indicated here by the `n$` prompt —
+don't type it!), run:
+```shell
+n$ cabal repl
+```
+
+Wait for the Gargantext modules to compile. You're now in GHCI.
+Import the custom prelude, as well as the `runCmdReplServantErr` function:
+```haskell
+ghci> import Gargantext.Prelude
+ghci> import Gargantext.API.Dev (runCmdReplServantErr)
+```
+> `runCmdReplServantErr` is a variant of the `runCmd` function (defined in
+> `Gargantext.Database.Prelude`) designed to be called directly from the REPL.
+
+You might miss some symbols not in the Gargantext prelude, such as `String`.
+If you need such symbols, you can of course just import them directly, like so:
+```haskell
+ghci> import GHC.Base (String)
+```
+
+Running commands
+-----------------
+
+Make sure that:
+- The database is up,
+- The Gargantext server is running locally.
+
+Write the command you want to run by defining a value of type
+`Cmd'' DevEnv ServerError a`, then apply `runCmdReplServantErr` to it and run
+the resulting action from within the REPL.
+
+The server should have run teh command and updated the database accordingly.
+
+Saving your REPL setup
+-----------------------
+
+To avoid typing all of that every time, and saving your own helper functions,
+you can define your own module somewhere in the hierarchy. For instance,
+you could write something like
+```haskell
+module Gargantext.ReplHelper where
+
+import Gargantext.Prelude
+import Gargantext.API.Dev (runCmdReplServantErr)
+import GHC.Base (String)
+
+runMyCustomCommand :: IO ()
+runMyCustomCommand = runCmdReplServantErr ... -- insert your command here
+```
+in `src/Gargantext/ReplHelper.hs`. You'll also need to edit `gargantext.cabal`
+to tell it about your new module:
+```cabal
+...
+library
+  import:
+    defaults
+  exposed-modules:
+      Gargantext.ReplHelper
+      Gargantext
+      Gargantext.API
+...
+```
+
+Once you have added/edited your REPL helper module, you can live-reload
+and import it from within GHCI:
+```haskell
+ghci> :r
+ghci> import Gargantext.ReplHelper
+```
+Alternatively, restarting GHCI will reload the module, but it will also recompile
+everything.

gargantext-settings.toml

@@ -16,10 +16,11 @@ allowed-origins = [
   , "https://dev.sub.gargantext.org"
   , "http://localhost:8008"
   , "http://localhost:8108"
+  , "http://localhost:3000"
   ]
 
 use-origins-for-hosts = true
 
-[microservices]
-
-proxy-port = 8009
+[microservices.proxy]
+port    = 8009
+enabled = false

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.1.9
+version: 0.0.7.1.14
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -530,10 +530,12 @@ library
     , blaze-svg ^>= 0.3.6.1
     , boolexpr ^>= 0.2
     , bytestring ^>= 0.10.12.0
+    , cache >= 0.1.3.0
     , case-insensitive ^>= 1.2.1.0
     , cassava ^>= 0.5.2.0
     , cborg ^>= 0.2.6.0
     , cereal ^>= 0.5.8.2
+    , clock >= 0.8
     , conduit ^>= 1.3.4.2
     , conduit-extra ^>= 1.3.5
     , containers ^>= 0.6.5.1
@@ -676,6 +678,7 @@ library
     , stemmer ^>= 0.5.2
     , stm ^>= 2.5.0.1
     , stm-containers >= 1.2.1 && < 1.3
+    , stringsearch >= 0.3.6.6
     , swagger2 ^>= 2.6
     , taggy-lens ^>= 0.1.2
     , tagsoup ^>= 0.14.8
@@ -703,6 +706,7 @@ library
     , wai-app-static ^>= 3.1.7.3
     , wai-cors ^>= 0.2.7
     , wai-extra ^>= 3.1.8
+    , wai-util >= 0.8
     , wai-websockets ^>= 3.0.1.2
     , warp ^>= 3.3.20
     , websockets ^>= 0.12.7.3
@@ -761,6 +765,7 @@ executable gargantext-cli
     , servant
     , servant-auth
     , servant-routes < 0.2
+    , servant-websockets >= 2.0.0 && < 2.1
     , shelly
     , split ^>= 0.2.3.4
     , text ^>= 1.2.4.1
@@ -813,9 +818,90 @@ executable gargantext-central-exchange
     , unordered-containers ^>= 0.2.16.0
     , vector ^>= 0.7.3
 
+common testDependencies
+  build-depends:
+      base >=4.7 && <5
+    , QuickCheck ^>= 2.14.2
+    , aeson ^>= 1.5.6.0
+    , aeson-pretty ^>= 0.8.9
+    , aeson-qq
+    , async ^>= 2.2.4
+    , boolexpr ^>= 0.2
+    , bytestring ^>= 0.10.12.0
+    , cache >= 0.1.3.0
+    , case-insensitive
+    , conduit ^>= 1.3.4.2
+    , containers ^>= 0.6.5.1
+    , crawlerArxiv
+    , cryptohash
+    , directory
+    , extra ^>= 1.7.9
+    , fast-logger ^>= 3.0.5
+    , fmt
+    , gargantext
+    , gargantext-prelude
+    , graphviz ^>= 2999.20.1.0
+    , hspec ^>= 2.7.10
+    , hspec-core
+    , hspec-expectations >= 0.8 && < 0.9
+    , hspec-wai
+    , hspec-wai-json
+    , http-api-data
+    , http-client ^>= 0.6.4.1
+    , http-client-tls ^>= 0.3.5.3
+    , http-types
+    , lens >= 5.2.2 && < 5.3
+    , monad-control >= 1.0.3 && < 1.1
+    , mtl ^>= 2.2.2
+    , network-uri
+    , parsec ^>= 3.1.14.0
+    , patches-class ^>= 0.1.0.1
+    , patches-map ^>= 0.1.0.1
+    , postgres-options >= 0.2 && < 0.3
+    , postgresql-simple >= 0.6.4 && < 0.7
+    , pretty
+    , process ^>= 1.6.13.2
+    , protolude ^>= 0.3.3
+    , quickcheck-instances ^>= 0.3.25.2
+    , raw-strings-qq
+    , recover-rtti >= 0.4 && < 0.5
+    , resource-pool >= 0.2.3.2 && < 0.2.4
+    , servant-auth
+    , servant-auth
+    , servant-auth-client
+    , servant-client
+    , servant-client-core
+    , servant-job
+    , servant-server
+    , shelly >= 1.9 && < 2
+    , split
+    , stm ^>= 2.5.0.1
+    , streaming-commons
+    , tasty ^>= 1.4.2.1
+    , tasty-golden
+    , tasty-hspec
+    , tasty-hunit
+    , tasty-quickcheck
+    , tasty-smallcheck
+    , template-haskell
+    , text ^>= 1.2.4.1
+    , time ^>= 1.9.3
+    , tmp-postgres >= 1.34.1 && < 1.35
+    , tree-diff
+    , unicode-collation >= 0.1.3.6
+    , unliftio
+    , unordered-containers ^>= 0.2.16.0
+    , utf8-string ^>= 1.0.2
+    , validity ^>= 0.11.0.1
+    , vector ^>= 0.12.3.0
+    , wai
+    , wai-extra
+    , warp
+
 test-suite garg-test-tasty
   import:
       defaults
+    , testDependencies
   type: exitcode-stdio-1.0
   main-is: drivers/tasty/Main.hs
   other-modules:
@@ -826,6 +912,7 @@ test-suite garg-test-tasty
       Test.Core.Similarity
       Test.Core.Text
       Test.Core.Text.Corpus.Query
+      Test.Core.Text.Corpus.TSV
       Test.Core.Text.Examples
       Test.Core.Text.Flow
       Test.Core.Utils
@@ -904,8 +991,7 @@ test-suite garg-test-tasty
     , raw-strings-qq
     , recover-rtti >= 0.4 && < 0.5
     , resource-pool >= 0.2.3.2 && < 0.2.4
-    , servant >= 0.18.3 && < 0.20
-    , servant-auth
+    -- , servant >= 0.18.3 && < 0.20
     , servant-auth
     , servant-auth-client
     , servant-client
@@ -940,6 +1026,7 @@ test-suite garg-test-tasty
 test-suite garg-test-hspec
   import:
       defaults
+    , testDependencies
   type: exitcode-stdio-1.0
   main-is: drivers/hspec/Main.hs
   other-modules:
@@ -950,6 +1037,7 @@ test-suite garg-test-hspec
       Test.API.GraphQL
       Test.API.Notifications
       Test.API.Private
+      Test.API.Private.Share
       Test.API.Routes
       Test.API.Setup
       Test.API.UpdateList
@@ -1003,7 +1091,7 @@ test-suite garg-test-hspec
     , raw-strings-qq
     , recover-rtti >= 0.4 && < 0.5
     , resource-pool >= 0.2.3.2 && < 0.2.4
-    , servant >= 0.18.3 && < 0.20
+    -- , servant >= 0.18.3 && < 0.20
     , servant-auth
     , servant-auth-client
     , servant-client

src/Gargantext/API.hs

@@ -37,7 +37,9 @@ module Gargantext.API
 import Control.Concurrent
 import Control.Concurrent.Async qualified as Async
 import Control.Lens hiding (Level)
+import Data.Cache qualified as InMemory
 import Data.List (lookup)
+import Data.Set qualified as Set
 import Data.Text (pack)
 import Data.Text.Encoding qualified as TE
 import Data.Text.IO (putStrLn)
@@ -65,6 +67,8 @@ import Network.Wai.Middleware.Cors
 import Network.Wai.Middleware.RequestLogger
 -- import Paths_gargantext (getDataDir)
 import Servant hiding (Header)
+import Servant.Client.Core.BaseUrl (showBaseUrl)
+import System.Clock qualified as Clock
 import System.Cron.Schedule qualified as Cron
 -- import System.FilePath
 
@@ -80,7 +84,8 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge
   periodicActions <- schedulePeriodicActions env
 
   let runServer = run port (mid app) `finally` stopGargantext periodicActions
-  let runProxy  = run proxyPort (mid (microServicesProxyApp env))
+  proxyCache <- InMemory.newCache (Just oneHour)
+  let runProxy  = run proxyPort (mid (microServicesProxyApp proxyCache env))
 
   Async.race_ runServer runProxy
 
@@ -92,6 +97,7 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge
             _ -> panicTrace $
               "You must run 'gargantext-init " <> pack (_IniFile iniFile) <>
               "' before running gargantext-server (only the first time)."
+        oneHour = Clock.fromNanoSecs 3600_000_000_000
 
 portRouteInfo :: PortNumber -> PortNumber -> IO ()
 portRouteInfo mainPort proxyPort = do
@@ -158,7 +164,7 @@ makeGargMiddleware :: CORSSettings -> Mode -> IO Middleware
 makeGargMiddleware crsSettings mode = do
     let corsMiddleware = cors $ \_incomingRq -> Just
           simpleCorsResourcePolicy
-            { corsOrigins = Just (map mkCorsOrigin (crsSettings ^. corsAllowedOrigins), True)
+            { corsOrigins = Just $ (Set.toList $ Set.fromList $ map mkCorsOrigin (crsSettings ^. corsAllowedOrigins), True)
             , corsMethods = [ methodGet   , methodPost   , methodPut
                             , methodDelete, methodOptions, methodHead]
             , corsIgnoreFailures = False
@@ -172,7 +178,7 @@ makeGargMiddleware crsSettings mode = do
         pure $ loggerMiddleware . corsMiddleware
   where
     mkCorsOrigin :: CORSOrigin -> Origin
-    mkCorsOrigin = TE.encodeUtf8 . _CORSOrigin
+    mkCorsOrigin (CORSOrigin u) = TE.encodeUtf8 . pack . showBaseUrl $ u
 
 ---------------------------------------------------------------------
 -- | API Global

src/Gargantext/API/Admin/Settings/CORS.hs

@@ -2,6 +2,7 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
 module Gargantext.API.Admin.Settings.CORS where
 
 import Prelude
@@ -10,10 +11,11 @@ import Control.Arrow
 import Data.Text qualified as T
 import Toml
 import Control.Lens hiding (iso, (.=))
-import Data.String (IsString)
+import Servant.Client.Core
+import Data.Maybe (fromMaybe)
 
-newtype CORSOrigin = CORSOrigin { _CORSOrigin :: T.Text }
-  deriving (Show, Eq, IsString)
+newtype CORSOrigin = CORSOrigin { _CORSOrigin :: BaseUrl }
+  deriving (Show, Eq)
 
 data CORSSettings =
   CORSSettings {
@@ -30,7 +32,8 @@ corsOriginCodec :: TomlBiMap CORSOrigin AnyValue
 corsOriginCodec = _Orig >>> _Text
   where
    _Orig :: BiMap e CORSOrigin T.Text
-   _Orig = iso _CORSOrigin CORSOrigin
+   _Orig = iso (T.pack . showBaseUrl . _CORSOrigin)
+               (\(T.unpack -> u) -> CORSOrigin . fromMaybe (error $ "invalid origin: " <> u) . parseBaseUrl $ u)
 
 corsSettingsCodec :: TomlCodec CORSSettings
 corsSettingsCodec = CORSSettings

src/Gargantext/API/Admin/Settings/MicroServices.hs

@@ -13,12 +13,14 @@ import Toml
 data MicroServicesSettings =
   MicroServicesSettings {
     -- | The port where the microservices proxy will be listening on.
-    _msProxyPort :: Int
+    _msProxyPort    :: !Int
+  , _msProxyEnabled :: !Bool
   } deriving (Show, Eq)
 
 microServicesSettingsCodec :: TomlCodec MicroServicesSettings
 microServicesSettingsCodec = MicroServicesSettings
-  <$> Toml.int "proxy-port" .= _msProxyPort
+  <$> Toml.int  "port"    .= _msProxyPort
+  <*> Toml.bool "enabled" .= _msProxyEnabled
 
 mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl
 mkProxyUrl GargConfig{..} MicroServicesSettings{..} =

src/Gargantext/API/Admin/Settings/TOML.hs

@@ -22,7 +22,7 @@ makeLenses ''GargTomlSettings
 settingsCodec :: TomlCodec GargTomlSettings
 settingsCodec = GargTomlSettings
   <$> (Toml.table corsSettingsCodec "cors" .= _gargCorsSettings)
-  <*> (Toml.table  microServicesSettingsCodec "microservices" .= _gargMicroServicesSettings)
+  <*> (Toml.table  microServicesSettingsCodec "microservices.proxy" .= _gargMicroServicesSettings)
 
 -- | Extends the 'allowed-origins' in the CORSettings with the URLs embellished
 -- with the proxy port.
@@ -33,9 +33,7 @@ addProxyToAllowedOrigins stgs =
     addProxies :: Int -> CORSSettings -> CORSSettings
     addProxies port cors =
       let origins = _corsAllowedOrigins cors
-          mkUrl (CORSOrigin u) = case parseBaseUrl (T.unpack u) of
-            Nothing -> CORSOrigin u
-            Just bh -> CORSOrigin $ T.pack $ showBaseUrl $ bh { baseUrlPort = port }
+          mkUrl (CORSOrigin bh) = CORSOrigin $ bh { baseUrlPort = port }
       in cors { _corsAllowedOrigins = origins <> Prelude.map mkUrl origins }
 
 -- | Loads the 'CORSSettings' from the 'toml' file.
@@ -48,5 +46,7 @@ loadGargTomlSettings tomlFile = do
           logMsg ioLogger ERROR $ T.unpack $ "Error, gargantext-settings.toml parsing failed: " <> Toml.prettyTomlDecodeErrors errs
           panicTrace "Please fix the errors in your gargantext-settings.toml file."
       Right settings0 -> case settings0 ^. gargCorsSettings . corsUseOriginsForHosts of
-        True  -> pure $ addProxyToAllowedOrigins $ settings0 & over (gargCorsSettings . corsAllowedHosts) (\_ -> "http://localhost:3000" : (settings0 ^. gargCorsSettings . corsAllowedOrigins))
-        False -> pure $ addProxyToAllowedOrigins $ settings0 & over (gargCorsSettings . corsAllowedHosts) ("http://localhost:3000" :)
+        True  -> pure $ addProxyToAllowedOrigins $
+                   settings0 & over (gargCorsSettings . corsAllowedHosts)
+                     (\_ -> (settings0 ^. gargCorsSettings . corsAllowedOrigins))
+        False -> pure $ addProxyToAllowedOrigins settings0

src/Gargantext/API/Node/ShareURL.hs

 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Gargantext.API.Node.ShareURL where
 
-import Data.Text
-import Gargantext.Prelude
+import Control.Lens
+import Data.Text qualified as T
+import Data.Validity qualified as V
+import Gargantext.API.Admin.Types (appPort, settings, Settings)
 import Gargantext.API.Prelude
-import Gargantext.Core.Types (NodeType, NodeId, unNodeId)
-import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
-import Control.Lens.Getter (view)
-import Gargantext.Core.Config (gc_url)
 import Gargantext.API.Routes.Named.Share qualified as Named
+import Gargantext.Core.Config (gc_url, GargConfig)
+import Gargantext.Core.Types (NodeType, NodeId, unNodeId, _ValidationError)
+import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
+import Gargantext.Prelude
+import Network.URI (parseURI)
+import Prelude (String)
 import Servant.Server.Generic (AsServerT)
 
 shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m)
@@ -19,14 +24,33 @@ shareURL = Named.ShareURL getUrl
 getUrl :: (IsGargServer env err m, CmdCommon env)
        => Maybe NodeType
        -> Maybe NodeId
-       -> m Text
+       -> m Named.ShareLink
 getUrl nt id = do
--- TODO add check that the node is able to be shared (in a shared folder)
-    case nt of
-        Nothing -> pure "Invalid node Type"
-        Just t ->
-            case id of
-                Nothing -> pure "Invalid node ID"
-                Just i -> do
-                    url <- view $ hasConfig . gc_url
-                    pure $ url <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
+  -- TODO add check that the node is able to be shared (in a shared folder)
+  gc      <- view hasConfig
+  urlPort <- view settings
+  case get_url nt id gc urlPort of
+    Left err        -> throwError $ _ValidationError # (V.check False err)
+    Right shareLink -> pure shareLink
+
+get_url :: Maybe NodeType
+        -> Maybe NodeId
+        -> GargConfig
+        -> Settings
+        -> Either String Named.ShareLink
+get_url nt id gc stgs = do
+  let urlHost = T.unpack $ gc ^. gc_url
+  let urlPort = stgs ^. appPort
+  t <- maybe (Left "Invalid node Type") Right nt
+  i <- maybe (Left "Invalid node ID")   Right id
+
+  -- Include the port the server is running on if this is
+  -- localhost, so that share URLs would work out of the box.
+  let !rawURL
+        | "localhost" `isInfixOf` urlHost
+        = urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
+        | otherwise
+        = urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
+  maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'")
+        (Right . Named.ShareLink)
+        (parseURI rawURL)

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

@@ -92,7 +92,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
   , listGetAPI     :: mode :- NamedRoutes List.GETAPI
   , listJsonAPI    :: mode :- NamedRoutes List.JSONAPI
   , listTsvAPI     :: mode :- NamedRoutes List.TSVAPI
-  , shareUrlEp     :: mode :- "shareurl" :> NamedRoutes ShareURL
+  , shareUrlAPI    :: mode :- "shareurl" :> NamedRoutes ShareURL
   } deriving Generic
 
 

src/Gargantext/API/Routes/Named/Share.hs

 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.API.Routes.Named.Share (
   -- * Routes types
     ShareNode(..)
   , Unpublish(..)
   , ShareURL(..)
+  , ShareLink(..)
+  , renderShareLink
 
   -- * API types (which appears in the routes)
   , ShareNodeParams(..)
   ) where
 
-import Data.Text (Text)
+import Data.Aeson
+import Data.Swagger
+import Data.Text qualified as T
 import GHC.Generics
 import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) )
 import Gargantext.Database.Admin.Types.Node
+import Network.URI (parseURI)
 import Prelude
 import Servant
 
+-- | A shareable link.
+-- N.B. We don't use a 'BareUrl' internally, because parsing something like
+-- 'http://localhost/#/share/NodeCorpus/16'
+-- would fail because '#/share/NodeCorpus/16' by the RFC3968 spec is considered
+-- an uriFragment, but BaseUrl cannot handle that.
+newtype ShareLink = ShareLink { getShareLink :: URI }
+  deriving (Show, Eq, Ord)
+
+renderShareLink :: ShareLink -> T.Text
+renderShareLink = T.pack . show . getShareLink
+
+instance ToJSON ShareLink where
+  toJSON = toJSON . renderShareLink
+
+instance FromJSON ShareLink where
+  parseJSON = withText "ShareLink" $ \txt ->
+    let urlStr = T.unpack txt
+    in case parseURI urlStr of
+          Nothing -> fail $ "Invalid URL: " <> urlStr
+          Just u  -> pure $ ShareLink u
+
+instance ToSchema ShareLink where
+  declareNamedSchema _ = declareNamedSchema (Proxy @T.Text)
 
 newtype ShareURL mode = ShareURL
   { shareUrlEp :: mode :- Summary "Fetch URL for sharing a node"
                        :> QueryParam "type" NodeType
                        :> QueryParam "id" NodeId
-                       :> Get '[JSON] Text
+                       :> Get '[JSON] ShareLink
   } deriving Generic
 
 

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

@@ -63,5 +63,5 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
        , listGetAPI        = List.getAPI
        , listJsonAPI       = List.jsonAPI
        , listTsvAPI        = List.tsvAPI
-       , shareUrlEp        = shareURL
+       , shareUrlAPI       = shareURL
        }

src/Gargantext/API/Viz/Types.hs

@@ -36,8 +36,8 @@ instance ToSchema Value where declareNamedSchema _ = declareNamedSchema (Proxy :
 -- 'purescript-gargantext' package.
 data PhyloData = PhyloData { pd_corpusId :: NodeId
                            , pd_listId   :: NodeId
-                           , pd_data     :: GraphData
-                           , pd_config   :: PhyloConfig
+                           , pd_data     :: Maybe GraphData
+                           , pd_config   :: Maybe PhyloConfig
                            }
   deriving (Generic, Show, Eq)
 

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

@@ -21,7 +21,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..
 import Gargantext.Defaults qualified as Defaults
 import Gargantext.Prelude hiding (intercalate)
 import HAL qualified
-import HAL.Doc.Corpus qualified as HAL
+import HAL.Doc.Document qualified as HAL
 import HAL.Types qualified as HAL
 import Servant.Client (ClientError)
 
@@ -38,23 +38,23 @@ getC la q ml = do
 --    Left err -> panic $ pack $ show err
 --    Right (len, docsC) -> pure (len, docsC .| mapMC (toDoc' la))
 
-toDoc' :: Maybe ISO639.ISO639_1 -> HAL.Corpus -> IO HyperdataDocument
-toDoc' la (HAL.Corpus { .. }) = do
+toDoc' :: Maybe ISO639.ISO639_1 -> HAL.Document -> IO HyperdataDocument
+toDoc' la (HAL.Document { .. }) = do
   -- printDebug "[toDoc corpus] h" h
-  let mDateS = _corpus_date <|> Just (pack $ show Defaults.year)
+  let mDateS = _document_date <|> Just (pack $ show Defaults.year)
   let (utctime, (pub_year, pub_month, pub_day)) = Date.mDateSplit mDateS
-  let abstractDefault = unwords _corpus_abstract
+  let abstractDefault = unwords _document_abstract
   let abstract = case la of
         Nothing -> abstractDefault
-        Just l  -> maybe abstractDefault unwords (Map.lookup l _corpus_abstract_lang_map)
+        Just l  -> maybe abstractDefault unwords (Map.lookup l _document_abstract_lang_map)
   pure HyperdataDocument { _hd_bdd = Just "Hal"
-                         , _hd_doi = Just $ pack $ show _corpus_docid
+                         , _hd_doi = Just $ pack $ show _document_docid
                          , _hd_url = Nothing
                          , _hd_page = Nothing
-                         , _hd_title = Just $ unwords _corpus_title
-                         , _hd_authors = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" _corpus_authors_names
-                         , _hd_institutes = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" $ _corpus_authors_affiliations <> map show _corpus_struct_id
-                         , _hd_source = Just $ maybe "Nothing" identity _corpus_source
+                         , _hd_title = Just $ unwords _document_title
+                         , _hd_authors = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" _document_authors_names
+                         , _hd_institutes = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" $ _document_authors_affiliations <> map show _document_struct_id
+                         , _hd_source = Just $ maybe "Nothing" identity _document_source
                          , _hd_abstract = Just abstract
                          , _hd_publication_date = fmap show utctime
                          , _hd_publication_year = pub_year

src/Gargantext/Core/Text/Corpus/Parsers/TSV.hs

@@ -20,6 +20,9 @@ import Data.ByteString.Lazy qualified as BL
 import Data.Csv
 import Data.Text (pack)
 import Data.Text qualified as T
+import Data.Text.Lazy            qualified as TL
+import Data.Text.Lazy.Encoding    qualified as TL
+import Data.Text.Read     qualified as DTR
 import Data.Time.Segment (jour)
 import Data.Vector (Vector)
 import Data.Vector qualified as V
@@ -205,7 +208,7 @@ hyperdataDocument2tsvDoc h = TsvDoc { tsv_title = m $ _hd_title h
     mI = maybe 0 identity
 
 
-data Delimiter = Tab | Comma
+data Delimiter = Tab | Comma | Line deriving (Eq, Show)
 
 tsvDecodeOptions :: Delimiter -> DecodeOptions
 tsvDecodeOptions d = defaultDecodeOptions {decDelimiter = delimiter d}
@@ -216,6 +219,151 @@ tsvEncodeOptions d = defaultEncodeOptions {encDelimiter = delimiter d}
 delimiter :: Delimiter -> Word8
 delimiter Tab   = fromIntegral $ ord '\t'
 delimiter Comma = fromIntegral $ ord ','
+delimiter Line  = fromIntegral $ ord '\n'
+------------------------------------------------------------------------
+
+
+testDelimiter :: Delimiter -> BL.ByteString -> Bool
+testDelimiter del bs =
+    let x = BL.splitWith (== delimiter Line) bs
+        vec = V.fromList x in
+          case BL.splitWith (== delimiter del) <$> ((V.!?) vec 0) of
+            Nothing -> False
+            Just e -> case BL.splitWith (== delimiter del) <$> ((V.!?) vec 1) of
+              Nothing -> False
+              Just f -> length e == length f && length e > 2
+
+findDelimiter :: BL.ByteString -> Either Text Delimiter
+findDelimiter bs
+  | testDelimiter Tab bs = Right Tab
+  | testDelimiter Comma bs = Right Comma
+  | otherwise = Left (pack "Problem with the delimiter : be sure that the delimiter is a tabulation for each line")
+
+isNumeric :: Text -> Either Bool Int
+isNumeric str = case DTR.decimal str of
+  Right (x,y) -> if y == ""
+    then Right x
+    else Left False
+  Left _ -> Left False
+
+lBLToText :: BL.ByteString -> Text
+lBLToText b = TL.toStrict $ TL.decodeUtf8 b
+
+validNumber :: BL.ByteString -> Text -> Int -> Either Text Bool
+validNumber x columnHeader ligne = do
+    let number = T.replace (T.pack "\"") (T.pack "") (lBLToText x)
+    case isNumeric number of
+      Right val 
+        | val < 0 -> Left $ ("Value of column '" <> columnHeader <> "' at line " <> pack (show ligne) <> " is negative")
+        |otherwise -> Right True
+      Left _ -> Left $ ("Error in column '" <> columnHeader <> "' at line " <> pack (show ligne) <> " : value is not a number ")
+
+
+validTextField :: BL.ByteString -> Text -> Int -> Either Text Bool
+validTextField x columnHeader ligne = do
+  let xs = T.replace (T.pack "\"\"") (T.pack "") (lBLToText x) in
+    if not (T.null xs) 
+      then 
+        if (T.length xs > 0) && ((T.length (T.filter (== '\"') xs) == 0) || ((T.head xs == '"') && (T.last xs == '"') && (T.length (T.filter (== '\"') xs) == 2))) 
+          then return True 
+          else Left $ ("Encapsulation problem at line " <> pack (show ligne) <> " in column '" <> columnHeader <> "' : the caracter  \"  must only appear at the beginning and the end of a field ")
+      else return True
+      -- else Left $ ("The column '" <> columnHeader <> "' at line " <>  pack (show ligne) <> " is empty")
+      -- Put a warning for the user to know their is a problem (empty column)
+
+
+testValue :: BL.ByteString -> Text -> Int -> Either Text Bool
+testValue val columnHeader ligne = case columnHeader of
+    "Publication Day" -> validNumber val columnHeader ligne
+    "Publication Month" -> validNumber val columnHeader ligne
+    "Publication Year" -> validNumber val columnHeader ligne
+    "Authors" -> validTextField val columnHeader ligne
+    "Title" -> validTextField val columnHeader ligne
+    "Source" -> validTextField val columnHeader ligne
+    "Abstract" -> validTextField val columnHeader ligne
+    _ -> Right True
+
+testErrorPerLine :: [BL.ByteString] -> Delimiter -> [Text] -> Int -> Either Text Bool
+testErrorPerLine [] _ [] _ = Right True
+testErrorPerLine _ del [] l | del == Comma = Left (pack $ "Too much field at line " <> show l <> ". Try using tabulation as a delimiter. Other delimiter like comma (,) may appear in some text.")
+                            | otherwise =  Left (pack $ "Too much field at line " <> show l)
+testErrorPerLine [] _ _ l = Left (pack $ "Missing one field at line " <> show l)
+testErrorPerLine (v:val) del (h:headers) ligne =
+    case testValue v h ligne of
+        Left _err -> Left _err
+        Right _ -> testErrorPerLine val del headers ligne
+
+
+checkNextLine :: Vector BL.ByteString -> Delimiter -> [Text] -> BL.ByteString -> Int -> Either Text (Int,[BL.ByteString])
+checkNextLine bl del headers res x = do
+  case BL.splitWith (==delimiter del) <$> ((V.!?) bl (x+1)) of
+    Nothing  -> Right (x, (BL.splitWith (==delimiter del) res))
+    Just value -> if length value > 1 
+      then Right (x, (BL.splitWith (==delimiter del) res))
+      else case BL.append res <$> ((V.!?) bl (x+1)) of
+        Nothing  -> Left "checkNextLine2"
+        Just val -> checkNextLine bl del headers val (x+1)
+
+getMultipleLinefile :: Vector BL.ByteString -> Delimiter -> [Text] -> BL.ByteString -> Int -> Either Text (Int,[BL.ByteString])
+getMultipleLinefile bl del headers res x = do
+    let tmp = BL.splitWith (==delimiter del) res in
+        if length tmp == length headers 
+          then checkNextLine bl del headers res x
+          else
+            if (length tmp > length headers) || (V.length bl == (x + 1)) 
+              then Left (pack $ "Cannot parse the file at line " <> show x <> ". Maybe because of a delimiter") 
+              else do
+                case BL.append res <$> ((V.!?) bl (x+1)) of
+                  Nothing  -> Left "getMultipleLinefile"
+                  Just val -> getMultipleLinefile bl del headers val (x+1)
+
+anx :: Vector BL.ByteString -> Delimiter -> [Text] -> Int -> Either Text Delimiter
+anx bl del headers x
+            | length bl == x = Right del
+            | otherwise      = 
+              case (V.!?) bl x of 
+                Nothing -> Left "anx"
+                Just bs ->
+                  case getMultipleLinefile bl del headers bs x of 
+                    Left _err -> Left _err
+                    Right (y, val) -> case testErrorPerLine val del headers (x + 1) of
+                      Left _err -> Left _err
+                      Right _   -> anx bl del headers (y+1)
+
+
+testIfErrorInFile :: [BL.ByteString] -> Delimiter -> [Text] -> Either Text Delimiter
+testIfErrorInFile bl del headers = anx (V.fromList bl) del headers 1
+
+testCorrectFile :: BL.ByteString -> Either Text Delimiter 
+testCorrectFile bs = 
+  case findDelimiter bs of
+    Left _err -> Left _err
+    Right del -> do
+      let bl = BL.splitWith (==delimiter Line) bs in
+        case getHeaders bl del of
+          Left _err -> Left _err
+          Right headers -> testIfErrorInFile bl del headers        
+
+
+
+----------Test headers added to ggt
+
+
+-- use a map to remove \r that sometimes appear at the end of a line
+testAllHeadersPresence :: [Text] -> Either Text [Text]
+testAllHeadersPresence headers = do
+    let listHeaders = filter (`notElem` (map (T.replace (T.pack "\r") (T.pack ""))headers)) ["Publication Day", "Publication Month", "Publication Year", "Authors", "Title", "Source", "Abstract"]
+    if null listHeaders
+        then Right headers
+        else Left ((pack " Missing column : ") <> T.intercalate ", " listHeaders)
+
+getHeaders :: [BL.ByteString] -> Delimiter -> Either Text [Text]
+getHeaders bl del = do
+    let vec = V.fromList bl in
+        case BL.splitWith (==delimiter del) <$> ((V.!?) vec 0) of 
+          Nothing -> Left "Error getHeaders"
+          Just headers -> testAllHeadersPresence (map (\x -> T.replace (T.pack "\"") (T.pack "") (lBLToText x)) headers)
+
 
 ------------------------------------------------------------------------
 
@@ -251,10 +399,10 @@ readByteStringStrict d ff = readByteStringLazy d ff . BL.fromStrict
 -- | TODO use readFileLazy
 readTSVFile :: FilePath -> IO (Either Text (Header, Vector TsvDoc))
 readTSVFile fp = do
-  result <- readTsvLazyBS Comma <$> BL.readFile fp
-  case result of
-    Left _err -> readTsvLazyBS Tab <$> BL.readFile fp
-    Right res -> pure $ Right res
+  file <- BL.readFile fp
+  case (testCorrectFile file) of
+    Left _err -> pure $ Left _err
+    Right del -> pure $ readTsvLazyBS del file
 
 
 

src/Gargantext/Core/Viz/Phylo/API.hs

@@ -28,7 +28,6 @@ import Gargantext.Core.Types.Phylo (GraphData(..))
 import Gargantext.Core.Viz.LegacyPhylo hiding (Phylo(..))
 import Gargantext.Core.Viz.Phylo (PhyloConfig(..), defaultConfig, _phylo_param, _phyloParam_config)
 import Gargantext.Core.Viz.Phylo.API.Tools
-import Gargantext.Core.Viz.Phylo.Example (phyloCleopatre)
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, defaultList)
@@ -58,21 +57,27 @@ getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do
   listId   <- case lId of
                 Nothing -> defaultList corpusId
                 Just ld -> pure ld
-  (gd, phyloConfig) <- getPhyloDataJson phyloId
+  pd <- getPhyloDataJson phyloId
   -- printDebug "getPhylo" theData
-  pure $ PhyloData corpusId listId gd phyloConfig
+  case pd of
+    Nothing -> pure $ PhyloData corpusId listId Nothing Nothing
+    Just (gd, phyloConfig) ->
+      pure $ PhyloData corpusId listId (Just gd) (Just phyloConfig)
 
 
 
-getPhyloDataJson :: PhyloId -> GargNoServer (GraphData, PhyloConfig)
+getPhyloDataJson :: PhyloId -> GargNoServer (Maybe (GraphData, PhyloConfig))
 getPhyloDataJson phyloId = do
-  maybePhyloData <- getPhyloData phyloId
-  let phyloData = fromMaybe phyloCleopatre maybePhyloData
-  let phyloConfig = _phyloParam_config $ _phylo_param phyloData
-  phyloJson <- liftBase $ phylo2dot2json phyloData
-  case parseEither parseJSON phyloJson of
+  phyloData <- getPhyloData phyloId
+  phyloJson <- liftBase $ maybePhylo2dot2json phyloData
+  case phyloJson of
+    Nothing -> pure Nothing
+    Just pj  ->
+      case parseEither parseJSON pj of
         Left err -> panicTrace $ T.pack $ "[Gargantext.Core.Viz.Phylo.API] getPhyloDataJson: " <> err
-    Right gd -> pure (gd, phyloConfig)
+        Right gd -> pure  $ Just (gd, phyloConfig phyloData)
+  where
+    phyloConfig phyloData = _phyloParam_config . _phylo_param $ fromMaybe (panicTrace "[Gargantext.Core.Viz.Phylo.API] getPhyloDataJson: no phylo data") phyloData
 
 
 -- getPhyloDataSVG phId _lId l msb  = do

src/Gargantext/Core/Viz/Phylo/API/Tools.hs

@@ -69,6 +69,10 @@ savePhylo :: PhyloId -> DBCmd err ()
 savePhylo = undefined
 
 --------------------------------------------------------------------
+maybePhylo2dot2json :: Maybe Phylo -> IO (Maybe Value)
+maybePhylo2dot2json Nothing = pure Nothing
+maybePhylo2dot2json (Just phylo) = Just <$> phylo2dot2json phylo
+
 phylo2dot2json :: Phylo -> IO Value
 phylo2dot2json phylo = do
   withTempDirectory "/tmp" "phylo" $ \dirPath -> do

src/Gargantext/Database/Action/Node.hs

@@ -25,6 +25,7 @@ import Data.Text qualified as T
 import Gargantext.API.Admin.Settings.MicroServices
 import Gargantext.API.Admin.Types (settings, _microservicesSettings, HasSettings)
 import Gargantext.Core
+import Gargantext.Core.Config (GargConfig(..))
 import Gargantext.Core.Types (Name)
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Hyperdata.Default
@@ -34,7 +35,6 @@ import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Prelude hiding (hash)
-import Gargantext.Core.Config (GargConfig(..))
 import Gargantext.Prelude.Crypto.Hash (hash)
 import Servant.Client.Core.BaseUrl
 
@@ -96,8 +96,14 @@ mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[])
 
 mkNodeWithParent_ConfigureHyperdata    _ _ _ _ = nodeError NotImplYet
 
-internalNotesProxy :: BaseUrl -> T.Text
-internalNotesProxy proxyUrl = T.pack $ showBaseUrl proxyUrl <> "/notes"
+-- | Creates the base URL for the notes microservices proxy, or defaults
+-- to the notes microservice if the proxy has been disabled from the settings.
+internalNotesProxy :: GargConfig -> MicroServicesSettings -> T.Text
+internalNotesProxy cfg msSettings
+  | _msProxyEnabled msSettings = T.pack $ showBaseUrl proxyUrl <> "/notes"
+  | otherwise                  = _gc_frame_write_url cfg
+  where
+    proxyUrl = mkProxyUrl cfg msSettings
 
 -- | Function not exposed
 mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType, HasSettings env)
@@ -116,7 +122,7 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
   cfg <- view hasConfig
   stt <- view settings
   u <- case nt of
-        Notes -> pure $ internalNotesProxy (mkProxyUrl cfg $ _microservicesSettings stt)
+        Notes -> pure $ internalNotesProxy cfg (_microservicesSettings stt)
         Calc  -> pure $ _gc_frame_calc_url  cfg
         NodeFrameVisio -> pure $ _gc_frame_visio_url  cfg
         _              -> nodeError NeedsConfiguration

stack.yaml

@@ -15,6 +15,7 @@
 - "hspec-core-2.11.1"
 - "hspec-discover-2.11.1"
 - "hspec-expectations-0.8.3"
+- "http-accept-0.2"
 - "ihaskell-0.11.0.0"
 - "ipython-kernel-0.11.0.0"
 - "located-base-0.1.1.1"
@@ -48,6 +49,7 @@
 - "validation-selective-0.2.0.0"
 - "vector-0.12.3.0"
 - "wai-3.2.4"
+- "wai-util-0.8"
 - commit: 2b5d69448557e89002c0179ea1aaf59bb757a6e3
   git: "https://github.com/AccelerateHS/accelerate-llvm.git"
   subdirs:
@@ -132,7 +134,7 @@
   git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git"
   subdirs:
   - .
-- commit: 3a7d039e07c8564e8ff84ef88480924d18aa5018
+- commit: 1dbd939257d33126e49d2679375553df1f2eebc5
   git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git"
   subdirs:
   - .
@@ -519,6 +521,9 @@ flags:
     "optimised-mixer": false
   "streaming-commons":
     "use-bytestring-builder": false
+  stringsearch:
+    base3: false
+    base4: true
   tagged:
     deepseq: true
     transformers: true

test-data/gargantext-settings.toml

@@ -19,6 +19,6 @@ allowed-origins = [
 
 use-origins-for-hosts = true
 
-[microservices]
-
-proxy-port = 8009
+[microservices.proxy]
+port    = 8009
+enabled = false

test/Test/API/Private.hs

@@ -7,29 +7,29 @@ module Test.API.Private (
     tests
   ) where
 
+import Gargantext.API.Routes.Named.Node
+import Gargantext.API.Routes.Named.Private
+import Gargantext.Core.Types (Node)
 import Gargantext.Core.Types.Individu
+import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
 import Gargantext.Prelude hiding (get)
 import Network.HTTP.Client hiding (Proxy)
+import Network.Wai
 import Servant.Auth.Client ()
 import Servant.Client
+import Servant.Client.Generic (genericClient)
+import Test.API.Private.Share qualified as Share
 import Test.API.Routes (mkUrl)
 import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
+import Test.Database.Types
 import Test.Hspec
 import Test.Hspec.Wai hiding (pendingWith)
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Hspec.Wai.JSON (json)
 import Test.Utils (protected, shouldRespondWithFragment, withValidLogin)
-import Gargantext.API.Routes.Named.Private
-import Gargantext.Core.Types (Node)
-import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
-import Servant.Client.Generic (genericClient)
-import Gargantext.API.Routes.Named.Node
 
-
-tests :: Spec
-tests = sequential $ aroundAll withTestDBAndPort $ do
-  describe "Prelude" $ do
-    it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
+privateTests :: SpecWith ((TestEnv, Int), Application)
+privateTests =
   describe "Private API" $ do
     baseUrl <- runIO $ parseBaseUrl "http://localhost"
     manager <- runIO $ newManager defaultManagerSettings
@@ -90,3 +90,13 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \token -> do
             protected token "GET" (mkUrl port "/tree/1") "" `shouldRespondWith` 403
+
+
+tests :: Spec
+tests = do
+  sequential $ aroundAll withTestDBAndPort $ do
+    describe "Prelude" $ do
+      it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
+    privateTests
+  describe "Share API" $ do
+    Share.tests

test/Test/API/Private/Share.hs

+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.API.Private.Share (
+    tests
+  ) where
+
+import Control.Lens
+import Data.ByteString.Lazy.Char8 qualified as CL8
+import Data.Text qualified as T
+import Gargantext.API.Errors
+import Gargantext.API.Routes.Named
+import Gargantext.API.Routes.Named.Private
+import Gargantext.API.Routes.Named.Share
+import Gargantext.Core.Types
+import Gargantext.Core.Types.Individu
+import Gargantext.Prelude
+import Network.HTTP.Client hiding (responseBody)
+import Prelude (fail)
+import Servant.Auth.Client qualified as SC
+import Servant.Client
+import Test.API.Routes
+import Test.API.Setup
+import Test.API.UpdateList (newCorpusForUser)
+import Test.Hspec
+import Test.Hspec.Wai.Internal (withApplication)
+import Test.Utils
+
+shareURL :: SC.Token -> Maybe NodeType -> Maybe NodeId -> ClientM ShareLink
+shareURL token =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & shareUrlAPI
+               & shareUrlEp
+
+tests :: Spec
+tests = sequential $ aroundAll withTestDBAndPort $ do
+  describe "Prelude" $ do
+    it "setup DB triggers" $ \((testEnv, _), _) -> do
+      setupEnvironment testEnv
+      -- Let's create the Alice user.
+      createAliceAndBob testEnv
+
+    baseUrl <- runIO $ parseBaseUrl "http://localhost"
+    manager <- runIO $ newManager defaultManagerSettings
+    let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })
+
+    it "should fail if no node type is specified" $ \((_testEnv, serverPort), app) -> do
+      withApplication app $ do
+        withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
+          url <- liftIO $ runClientM (shareURL (toServantToken token) Nothing Nothing) (clientEnv serverPort)
+          case url of
+            Left (FailureResponse _req res)
+              -> liftIO $ (CL8.unpack $ responseBody res) `shouldSatisfy` (T.isInfixOf "Invalid node Type" . T.pack)
+            _ -> fail "Test did not fail as expected!"
+
+    it "should fail if no node ID is specified" $ \((_testEnv, serverPort), app) -> do
+      withApplication app $ do
+        withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
+          url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) Nothing) (clientEnv serverPort)
+          case url of
+            Left (FailureResponse _req res)
+              -> liftIO $ (CL8.unpack $ responseBody res) `shouldSatisfy` (T.isInfixOf "Invalid node ID" . T.pack)
+            _ -> fail "Test did not fail as expected!"
+
+    it "should return a valid URL" $ \((testEnv, serverPort), app) -> do
+      withApplication app $ do
+        withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
+          cId <- liftIO $ newCorpusForUser testEnv "alice"
+          url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) (Just cId)) (clientEnv serverPort)
+          case url of
+            Left err
+              -> fail (show err)
+            Right (ShareLink _)
+              -> pure ()
+
+    it "should include the port if needed (like localhost)" $ \((testEnv, serverPort), app) -> do
+      withApplication app $ do
+        withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
+          cId <- liftIO $ newCorpusForUser testEnv "alice"
+          url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) (Just cId)) (clientEnv serverPort)
+          case url of
+            Left err
+              -> fail (show err)
+            Right (ShareLink uri)
+              -> liftIO $ "localhost:80" `T.isInfixOf` T.pack (show uri) `shouldBe` True

test/Test/API/Setup.hs

@@ -7,6 +7,8 @@ import Control.Concurrent.Async qualified as Async
 import Control.Concurrent.MVar
 import Control.Lens
 import Control.Monad.Reader
+import Data.Cache qualified as InMemory
+import Data.Streaming.Network (bindPortTCP)
 import Gargantext.API (makeApp)
 import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
 import Gargantext.API.Admin.Settings
@@ -47,8 +49,7 @@ import Servant.Client
 import Servant.Job.Async qualified as ServantAsync
 import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo, fakeSettingsPath)
 import Test.Database.Types
-import qualified UnliftIO
-import Data.Streaming.Network (bindPortTCP)
+import UnliftIO qualified
 
 
 newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
@@ -137,9 +138,10 @@ withBackendServerAndProxy action =
     gargApp <- withLoggerHoisted Mock $ \ioLogger -> do
                  env <- newTestEnv testEnv ioLogger 8080
                  makeApp env
+    proxyCache <- InMemory.newCache Nothing
     proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do
                   env <- newTestEnv testEnv ioLogger 8080
-                  pure $ microServicesProxyApp env
+                  pure $ microServicesProxyApp proxyCache env
 
     Warp.testWithApplication (pure gargApp) $ \serverPort ->
       testWithApplicationOnPort (pure proxyApp) proxyPort $

test/Test/Server/ReverseProxy.hs

@@ -38,6 +38,7 @@ writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do
                                                & ($ (Token "bogus"))
                                                & notesEp
                                                & ($ (FrameId "abcdef"))
+                                               & ($ Nothing)
                                                & ($ "GET")
                            ) (clientEnv proxyPort)
 
@@ -66,6 +67,7 @@ writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do
                                                    & ($ (toServantToken $ autRes ^. authRes_token))
                                                    & notesEp
                                                    & ($ (FrameId "abcdef"))
+                                                   & ($ Nothing)
                                                    & ($ "GET")
                                ) (clientEnv proxyPort)
 

test/drivers/tasty/Main.hs

@@ -13,6 +13,7 @@ module Main where
 import Gargantext.Prelude
 
 import qualified Test.Core.Text.Corpus.Query     as CorpusQuery
+import qualified Test.Core.Text.Corpus.TSV       as TSVParser
 import qualified Test.Core.Utils                 as Utils
 import qualified Test.Graph.Clustering           as Graph
 import qualified Test.Ngrams.NLP                 as NLP
@@ -50,6 +51,7 @@ main = do
     , jobsSpec
     , NgramsQuery.tests
     , CorpusQuery.tests
+    , TSVParser.tests
     , JSON.tests
     , Errors.tests
     , similaritySpec