Merge branch 'testing' into stable

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)

README.md

@@ -188,6 +188,13 @@ When a devlopment is needed on libraries (for instance, the HAL crawler in https
 
 > Note: without `stack.yaml` we would have to only fix `cabal.project` -> `source-repository-package` commit id. Sha256 is there to make sure CI reruns the tests.
 
+### Tooling info
+
+Once you get Gargantext to compile and run on your machine, you will likely want
+the following:
+- Language support (intellisense) in your editor; see `docs/editor_setup.md`
+- Being able to send commands to the Gargantext server from GHCI; see `docs/running_commands.md`
+
 ## Use Cases <a name="use-cases"></a>
 
 ### Multi-User with Graphical User Interface (Server Mode)

bin/update-project-dependencies

@@ -18,8 +18,8 @@ fi
 # with the `sha256sum` result calculated on the `cabal.project` and
 # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
 # cache can kick in.
-expected_cabal_project_hash="ec368714e0d4213dcc60e7c98344ab9a4ecbcff522deb4c57a12490e3b048585"
-expected_cabal_project_freeze_hash="ca1592c985ffead024c6635eb39b293e2525a547fe93293fdee9ce1148083f22"
+expected_cabal_project_hash="c2c8ffc22f513f962745a00db6f9199eca89066ecbb47c850e5969550a4e6e1e"
+expected_cabal_project_freeze_hash="05ee74fc30b25edf135f4f9c53a2c134752184545b7a9e837f27e36d507a7a80"
 
 cabal --store-dir=$STORE_DIR v2-build --dry-run
 cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml

cabal.project

@@ -93,7 +93,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/hal.git
-    tag: 3665ccda54893d01bb27220538eefdde0c1e7419
+    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,
@@ -274,6 +275,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,
@@ -545,6 +547,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,
@@ -654,6 +658,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

@@ -15,6 +15,7 @@ allowed-origins = [
   , "https://msh.sub.gargantext.org"
   , "https://dev.sub.gargantext.org"
   , "http://localhost:8008"
+  , "http://localhost:3000"
   ]
 
 use-origins-for-hosts = true

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.1.11
+version: 0.0.7.1.14
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -520,10 +520,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
@@ -662,6 +664,7 @@ library
     , split ^>= 0.2.3.4
     , stemmer ^>= 0.5.2
     , stm ^>= 2.5.0.1
+    , stringsearch >= 0.3.6.6
     , swagger2 ^>= 2.6
     , taggy-lens ^>= 0.1.2
     , tagsoup ^>= 0.14.8
@@ -689,6 +692,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
@@ -778,61 +782,17 @@ executable gargantext-server
     , unordered-containers ^>= 0.2.16.0
     , vector ^>= 0.7.3
 
-test-suite garg-test-tasty
-  import:
-    defaults
-  type: exitcode-stdio-1.0
-  main-is: drivers/tasty/Main.hs
-  other-modules:
-      Test.API.Routes
-      CLI.Phylo.Common
-      Test.API.Setup
-      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
-      Test.Database.Operations
-      Test.Database.Operations.DocumentSearch
-      Test.Database.Operations.NodeStory
-      Test.Database.Setup
-      Test.Database.Types
-      Test.Graph.Clustering
-      Test.Graph.Distance
-      Test.Ngrams.Lang
-      Test.Ngrams.Lang.En
-      Test.Ngrams.Lang.Fr
-      Test.Ngrams.Lang.Occurrences
-      Test.Ngrams.Metrics
-      Test.Ngrams.NLP
-      Test.Ngrams.Query
-      Test.Ngrams.Query.PaginationCorpus
-      Test.Offline.Errors
-      Test.Offline.JSON
-      Test.Offline.Phylo
-      Test.Offline.Stemming.Lancaster
-      Test.Parsers.Date
-      Test.Parsers.Types
-      Test.Parsers.WOS
-      Test.Server.ReverseProxy
-      Test.Types
-      Test.Utils
-      Test.Utils.Crypto
-      Test.Utils.Jobs
-      Paths_gargantext
-  hs-source-dirs:
-      test bin/gargantext-cli
-  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+common testDependencies
   build-depends:
-      QuickCheck ^>= 2.14.2
+      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
@@ -878,9 +838,9 @@ test-suite garg-test-tasty
     , servant-job
     , servant-server
     , shelly >= 1.9 && < 2
+    , split
     , stm ^>= 2.5.0.1
     , streaming-commons
-    , split
     , tasty ^>= 1.4.2.1
     , tasty-golden
     , tasty-hspec
@@ -892,9 +852,9 @@ test-suite garg-test-tasty
     , time ^>= 1.9.3
     , tmp-postgres >= 1.34.1 && < 1.35
     , tree-diff
-    , unordered-containers ^>= 0.2.16.0
     , 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
@@ -902,9 +862,59 @@ test-suite garg-test-tasty
     , wai-extra
     , warp
 
+test-suite garg-test-tasty
+  import:
+      defaults
+    , testDependencies
+  type: exitcode-stdio-1.0
+  main-is: drivers/tasty/Main.hs
+  other-modules:
+      Test.API.Routes
+      CLI.Phylo.Common
+      Test.API.Setup
+      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
+      Test.Database.Operations
+      Test.Database.Operations.DocumentSearch
+      Test.Database.Operations.NodeStory
+      Test.Database.Setup
+      Test.Database.Types
+      Test.Graph.Clustering
+      Test.Graph.Distance
+      Test.Ngrams.Lang
+      Test.Ngrams.Lang.En
+      Test.Ngrams.Lang.Fr
+      Test.Ngrams.Lang.Occurrences
+      Test.Ngrams.Metrics
+      Test.Ngrams.NLP
+      Test.Ngrams.Query
+      Test.Ngrams.Query.PaginationCorpus
+      Test.Offline.Errors
+      Test.Offline.JSON
+      Test.Offline.Phylo
+      Test.Offline.Stemming.Lancaster
+      Test.Parsers.Date
+      Test.Parsers.Types
+      Test.Parsers.WOS
+      Test.Server.ReverseProxy
+      Test.Types
+      Test.Utils
+      Test.Utils.Crypto
+      Test.Utils.Jobs
+      Paths_gargantext
+  hs-source-dirs:
+      test bin/gargantext-cli
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+
 test-suite garg-test-hspec
   import:
       defaults
+    , testDependencies
   type: exitcode-stdio-1.0
   main-is: drivers/hspec/Main.hs
   other-modules:
@@ -914,6 +924,7 @@ test-suite garg-test-hspec
       Test.API.Errors
       Test.API.GraphQL
       Test.API.Private
+      Test.API.Private.Share
       Test.API.Routes
       Test.API.Setup
       Test.API.UpdateList
@@ -928,70 +939,6 @@ test-suite garg-test-hspec
   hs-source-dirs:
       test
   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      QuickCheck ^>= 2.14.2
-    , aeson ^>= 1.5.6.0
-    , aeson-qq
-    , async ^>= 2.2.4
-    , boolexpr ^>= 0.2
-    , bytestring ^>= 0.10.12.0
-    , case-insensitive
-    , conduit ^>= 1.3.4.2
-    , containers ^>= 0.6.5.1
-    , crawlerArxiv
-    , extra ^>= 1.7.9
-    , fast-logger ^>= 3.0.5
-    , fmt
-    , gargantext
-    , gargantext-prelude
-    , hspec ^>= 2.7.10
-    , hspec-core
-    , hspec-expectations >= 0.8 && < 0.9
-    , hspec-wai
-    , hspec-wai-json
-    , http-api-data
-    , http-types
-    , http-client ^>= 0.6.4.1
-    , http-client-tls ^>= 0.3.5.3
-    , 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
-    , process ^>= 1.6.13.2
-    , 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-client
-    , servant-client
-    , servant-client-core
-    , servant-job
-    , servant-server
-    , shelly >= 1.9 && < 2
-    , stm ^>= 2.5.0.1
-    , streaming-commons
-    , tasty ^>= 1.4.2.1
-    , 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
-    , unliftio
-    , unordered-containers ^>= 0.2.16.0
-    , validity ^>= 0.11.0.1
-    , wai
-    , wai-extra
-    , warp
 
 benchmark garg-bench
   main-is:       Main.hs

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)
@@ -64,6 +66,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
 
@@ -79,7 +83,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
 
@@ -91,6 +96,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
@@ -154,7 +160,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
@@ -168,7 +174,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/TOML.hs

@@ -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/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/MicroServices/ReverseProxy.hs

 {-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NumericUnderscores  #-}
 {-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE TypeOperators      #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE ViewPatterns        #-}
 {-# OPTIONS_GHC -Wno-orphans     #-}
 
 module Gargantext.MicroServices.ReverseProxy (
@@ -24,34 +25,41 @@ import Conduit
 import Data.ByteString qualified as B
 import Data.ByteString.Builder
 import Data.ByteString.Char8 qualified as C8
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Search qualified as BS
+import Data.Cache qualified as InMemory
 import Data.Conduit.List qualified as CC
 import Data.String
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
 import GHC.Generics
+import Gargantext.API.Admin.Auth.Types (AuthContext)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Settings.MicroServices
 import Gargantext.API.Admin.Types
+import Gargantext.API.Node.ShareURL qualified as Share
 import Gargantext.API.Routes.Named.Private
+import Gargantext.API.Routes.Named.Share (ShareLink(..))
 import Gargantext.API.ThrowAll (throwAllRoutes)
-import Gargantext.API.Types (HTML)
 import Gargantext.Core.Config (gc_frame_write_url)
+import Gargantext.Database.Admin.Types.Node (NodeType(..), NodeId (..))
 import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Prelude hiding (Handler)
 import Network.HTTP.ReverseProxy
 import Network.HTTP.Types (hCacheControl, RequestHeaders, hReferer, ResponseHeaders, Header)
-import Network.HTTP.Types.Header (hHost)
+import Network.HTTP.Types.Header (hHost, hSetCookie)
+import Network.HTTP.Types.Status (status302)
+import Network.Wai
+import Network.Wai.Util (redirect')
 import Servant hiding (Header)
 import Servant.Auth.Server
+import Servant.Auth.Server.Internal.AddSetCookie
 import Servant.Auth.Swagger ()
 import Servant.Client.Core.BaseUrl
 import Servant.Server.Generic
 import Text.RE.Replace hiding (Capture)
 import Text.RE.TDFA.ByteString
-import Text.RawString.QQ (r)
-import Gargantext.API.Admin.Auth.Types (AuthContext)
-import Servant.Auth.Server.Internal.AddSetCookie
-import Network.Wai
+
 
 -- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
 instance {-# OVERLAPPING #-}
@@ -66,7 +74,7 @@ instance {-# OVERLAPPING #-}
 --
 
 newtype FrameId = FrameId { _FrameId :: T.Text }
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Hashable)
 
 instance ToHttpApiData FrameId where
   toUrlPiece = toUrlPiece . _FrameId
@@ -122,7 +130,7 @@ data NotesProxy mode = NotesProxy
 
   -- | The config file which contains the server settings for the websocket connection
   -- that we have to overwrite with our settings.
-  , configFile    :: mode :- "config"    :> Get '[HTML] T.Text
+  , configFile    :: mode :- "config"    :> Raw
 
   -- | Once the connection has been established, this is the websocket endpoint to
   -- poll edits.
@@ -132,7 +140,9 @@ data NotesProxy mode = NotesProxy
   , meEndpoint  :: mode :- "me"        :> Raw
 
   -- | The initial endpoint which will be hit the first time we want to access the /notes endpoint.
-  , notesEp     :: mode :- Capture "frameId" FrameId :> Raw
+  , notesEp     :: mode :- Capture "frameId" FrameId
+                        :> QueryParam "node_id" NodeId
+                        :> Raw
 
   -- | The generic routes serving the assets.
   , notesStaticAssets :: mode :- Raw
@@ -146,48 +156,68 @@ data SocketIOProxy mode = SocketIOProxy
 -- The Server
 --
 
-microServicesProxyApp :: Env -> Application
-microServicesProxyApp env = genericServeTWithContext id (server env) cfg
+type ProxyCache = InMemory.Cache FrameId NodeId
+
+
+microServicesProxyApp :: ProxyCache -> Env -> Application
+microServicesProxyApp cache env = genericServeTWithContext id (server cache env) cfg
   where
     cfg :: Context AuthContext
     cfg = env ^. settings . jwtSettings
        :. env ^. settings . cookieSettings
        :. EmptyContext
 
-server :: Env -> ReverseProxyAPI (AsServerT Handler)
-server env = ReverseProxyAPI {
+server :: ProxyCache -> Env -> ReverseProxyAPI (AsServerT Handler)
+server cache env = ReverseProxyAPI {
     notesServiceProxy = \case
-      (Authenticated _autUser) -> notesProxyImplementation env
-      _ -> throwAllRoutes err401 $ notesProxyImplementation env
+      (Authenticated _autUser) -> notesProxyImplementation cache env
+      _ -> throwAllRoutes err401 $ notesProxyImplementation cache env
    , proxyPassAll      = proxyPassServer ST_notes env
    }
 
--- | A customised configuration file that the \"notes\" service would otherwise send us, that
+-- | Customise the configuration file that the \"notes\" service would otherwise send us, that
 -- overrides the 'urlpath' to contain the proper service path, so that the websocket connection
 -- can be started correctly. If we do not override the 'urlpath', due to the way things work
 -- internally, the Javascript of CodiMD would otherwise take the first slice of the URL path
 -- (something like `/notes/<frameId>`) and use /that/ as the <frameId>, which would be wrong
 -- as it would try to establish a connection to `noteId=notes`.
-configJS :: BaseUrl -> ServiceType -> T.Text
-configJS bu st = T.pack $ [r|
-window.domain  = '|] <> (baseUrlHost bu) <> [r|'
-window.urlpath = '|] <> renderServiceType st <> [r|'
-window.debug   = false
-window.version = '1.2.0'
+customiseConfigJS :: BaseUrl -> ServiceType -> ConduitT B.ByteString (Flush Builder) IO ()
+customiseConfigJS bu st = CC.map flushReplace
+  where
+    --  Replaces the relative links in the proxied page content with proper urls.
+    flushReplace :: B.ByteString -> Flush Builder
+    flushReplace = Chunk . byteString . replaceWindowDomain . replaceUrlPath
 
-window.allowedUploadMimeTypes = ["image/jpeg","image/png","image/jpg","image/gif","image/svg+xml"]
+    replaceWindowDomain :: B.ByteString -> B.ByteString
+    replaceWindowDomain htmlBlob =
+      replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~
+        [re|window.domain.*=*'.*'$|]
+      where
+        makeAbsolute _ _loc cap = case capturedText cap of
+          _                -> Just $ C8.pack $ "window.domain = '" <> (baseUrlHost bu) <> "'"
 
-window.DROPBOX_APP_KEY = ''
-|]
+    replaceUrlPath :: B.ByteString -> B.ByteString
+    replaceUrlPath htmlBlob =
+      replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~
+        [re|window.urlpath.*=*'.*'$|]
+      where
+        makeAbsolute _ _loc cap = case capturedText cap of
+          _                -> Just $ C8.pack $ "window.urlpath = '" <> renderServiceType st <> "'"
+
+configFileSettings :: Env -> ServiceType -> WaiProxySettings
+configFileSettings env sty =
+  defaultWaiProxySettings
+    { wpsProcessBody = \_req _res -> Just $ customiseConfigJS (proxyUrl env) sty
+    }
 
-notesProxyImplementation :: Env -> NotesProxy AsServer
-notesProxyImplementation env = NotesProxy {
+notesProxyImplementation :: ProxyCache -> Env -> NotesProxy AsServer
+notesProxyImplementation cache env = NotesProxy {
     slideEp     = \frameId  -> slideProxyServer env frameId
-  , publishEp   = \frameId  -> publishProxyServer env frameId
-  , configFile  = pure $ configJS (proxyUrl env) sty
+  , publishEp   = \frameId  -> publishProxyServer cache env frameId
+  , configFile  = defaultForwardServerWithSettings sty id env (configFileSettings env sty)
   , notesSocket = socketIOProxyImplementation sty env
   , meEndpoint  = proxyPassServer sty env
-  , notesEp     = \_frameId  -> defaultForwardServer sty id env
+  , notesEp     = \frameId mbNodeId -> notesForwardServer cache frameId mbNodeId sty id env
   , notesStaticAssets = proxyPassServer sty env
   }
   where
@@ -196,7 +226,7 @@ notesProxyImplementation env = NotesProxy {
 
 socketIOProxyImplementation :: ServiceType -> Env -> SocketIOProxy AsServer
 socketIOProxyImplementation sty env = SocketIOProxy {
-    socketIoEp = \_noteId -> defaultForwardServer sty id env
+    socketIoEp = \_noteId -> defaultForwardServer sty id id env
   }
 
 removeServiceFromPath :: ServiceType -> Request -> Request
@@ -208,21 +238,42 @@ removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty
 
 slideProxyServer :: Env -> FrameId -> ServerT Raw m
 slideProxyServer env (FrameId frameId) =
-  defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) env
+  defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) id env
   where
     changePath :: ByteString -> ByteString
     changePath _ = TE.encodeUtf8 $ "/p/" <> frameId <> "#/"
 
-publishProxyServer :: Env -> FrameId -> ServerT Raw m
-publishProxyServer env (FrameId frameId) =
-  defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) env
+-- | Rather than using the publish feature of HedgeDoc / CodiMD, we rely on our
+-- own URL sharing feauture.
+publishProxyServer :: ProxyCache -> Env -> FrameId -> ServerT Raw m
+publishProxyServer cache env frameId = Tagged $ \req res -> do
+  -- Lookup the cookie (indexed by frameId) which will contain the node id.
+  mbNodeId <- InMemory.lookup cache frameId
+  case mbNodeId of
+    Nothing -> do
+     forwardRaw req res
+    Just nodeId
+      -> do
+        -- Using a mock for now.
+        case Share.get_url (Just Notes) (Just nodeId) (_env_config env) (_env_settings env) of
+          Left _e ->
+            -- Invalid link, treat this as a normal proxy
+           forwardRaw req res
+          Right (ShareLink uri) ->
+            -- Follow the redirect
+            res =<< redirect' status302 [] uri
+
   where
+
+    forwardRaw =
+      unTagged (defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) id env)
+
     changePath :: ByteString -> ByteString
-    changePath _ = TE.encodeUtf8 $ "/s/" <> frameId
+    changePath _ = TE.encodeUtf8 $ "/s/" <> (_FrameId frameId)
 
 -- Generic server forwarder
 proxyPassServer :: ServiceType -> Env -> ServerT Raw m
-proxyPassServer sty env = defaultForwardServer sty id env
+proxyPassServer sty env = defaultForwardServer sty id id env
 
 mkProxyDestination :: Env -> ProxyDestination
 mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do
@@ -248,12 +299,35 @@ removeFromReferer pth originalRequest =
 proxyUrl :: Env -> BaseUrl
 proxyUrl env = mkProxyUrl (env ^. hasConfig) (env ^. env_settings . microservicesSettings)
 
+notesForwardServer :: ProxyCache
+                   -> FrameId
+                   -> Maybe NodeId
+                   -> ServiceType
+                   -> (Request -> Request)
+                   -> Env
+                   -> ServerT Raw m
+notesForwardServer cache frameId mbNodeId sty presendModifyRequest env =
+  case mbNodeId of
+    Nothing
+      -> defaultForwardServer sty presendModifyRequest id env
+    Just nid
+      -> do
+       -- Persist the node id in the cache
+       Tagged $ \req res -> do
+         InMemory.insert cache frameId nid
+         unTagged (defaultForwardServer sty presendModifyRequest (setFrameIdCookie frameId nid) env) req res
+  where
+    setFrameIdCookie :: FrameId -> NodeId -> (ResponseHeaders -> ResponseHeaders)
+    setFrameIdCookie (FrameId (T.unpack -> fid)) (UnsafeMkNodeId nid) origHeaders
+      = let sk = (hSetCookie, fromString $ fid <> "=" <> Prelude.show nid)
+      in sk : origHeaders
 
-defaultForwardServer :: ServiceType
+defaultForwardServerWithSettings :: ServiceType
                                  -> (Request -> Request)
                                  -> Env
+                                 -> WaiProxySettings
                                  -> ServerT Raw m
-defaultForwardServer sty presendModifyRequest env =
+defaultForwardServerWithSettings sty presendModifyRequest env proxySettings =
   Tagged $ waiProxyToSettings forwardRequest (proxySettings) (env ^. env_manager)
   where
 
@@ -263,14 +337,6 @@ defaultForwardServer sty presendModifyRequest env =
     proxyUrlStr :: String
     proxyUrlStr = showBaseUrl (proxyUrl env)
 
-    proxySettings :: WaiProxySettings
-    proxySettings =
-      defaultWaiProxySettings {
-          wpsProcessBody = \_req _res -> Just $ replaceRelativeLinks (C8.pack $ proxyUrlStr <> serviceTypeToProxyPath sty)
-        , wpsModifyResponseHeaders = \_req _res -> tweakResponseHeaders
-        , wpsRedirectCounts = 5
-        }
-
     setHost :: ProxyDestination -> RequestHeaders -> RequestHeaders
     setHost hst hdrs = (hHost, fwdHost hst) : filter ((/=) hHost . fst) hdrs
 
@@ -287,6 +353,27 @@ defaultForwardServer sty presendModifyRequest env =
                          }
       pure $ WPRModifiedRequest proxiedReq (ProxyDest (fwdHost proxyDestination) (fwdPort proxyDestination))
 
+defaultForwardServer :: ServiceType
+                     -> (Request -> Request)
+                     -> (ResponseHeaders -> ResponseHeaders)
+                     -> Env
+                     -> ServerT Raw m
+defaultForwardServer sty presendModifyRequest mapRespHeaders env =
+  defaultForwardServerWithSettings sty presendModifyRequest env $
+    defaultWaiProxySettings {
+        wpsProcessBody = \_req _res -> Just $ replaceRelativeLinks proxyDestination proxyPath
+      , wpsModifyResponseHeaders = \_req _res -> (mapRespHeaders . tweakResponseHeaders)
+      , wpsRedirectCounts = 5
+      }
+  where
+    proxyPath = C8.pack $ proxyUrlStr <> serviceTypeToProxyPath sty
+
+    proxyDestination :: ProxyDestination
+    proxyDestination = mkProxyDestination env
+
+    proxyUrlStr :: String
+    proxyUrlStr = showBaseUrl (proxyUrl env)
+
 --
 -- Utility functions
 --
@@ -306,12 +393,15 @@ tweakResponseHeaders = Prelude.map tweakHeader
       = (k,v)
 
 -- | Replaces the relative links in any HTML blob returned by the proxy.
-replaceRelativeLinks :: B.ByteString -> ConduitT B.ByteString (Flush Builder) IO ()
-replaceRelativeLinks assetPath = CC.map flushReplace
+replaceRelativeLinks :: ProxyDestination -> B.ByteString -> ConduitT B.ByteString (Flush Builder) IO ()
+replaceRelativeLinks proxyTarget assetPath = CC.map flushReplace
   where
     --  Replaces the relative links in the proxied page content with proper urls.
     flushReplace :: B.ByteString -> Flush Builder
-    flushReplace = Chunk . byteString . replaceIt
+    flushReplace = Chunk . byteString
+                         . BL.toStrict
+                         . BS.replace (C8.pack . showBaseUrl . _ProxyDestination $ proxyTarget) assetPath
+                         . replaceIt
 
     replaceIt :: B.ByteString -> B.ByteString
     replaceIt htmlBlob =

stack.yaml

@@ -14,6 +14,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"
@@ -46,6 +47,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:
@@ -126,7 +128,7 @@
   git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git"
   subdirs:
   - .
-- commit: 3665ccda54893d01bb27220538eefdde0c1e7419
+- commit: 1dbd939257d33126e49d2679375553df1f2eebc5
   git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git"
   subdirs:
   - .
@@ -513,6 +515,9 @@ flags:
     "optimised-mixer": false
   "streaming-commons":
     "use-bytestring-builder": false
+  stringsearch:
+    base3: false
+    base4: true
   tagged:
     deepseq: true
     transformers: true

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
@@ -44,8 +46,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
@@ -105,9 +106,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)