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
+      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
-    Left err -> panicTrace $ T.pack $ "[Gargantext.Core.Viz.Phylo.API] getPhyloDataJson: " <> err
-    Right gd -> pure (gd, phyloConfig)
+  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  $ 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

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)