Publish in notes is now URL sharing

This commit maps the "Publish" action inside CodiMD/HedgeDoc to the
share URL feature.

bin/update-project-dependencies

@@ -19,7 +19,7 @@ fi
 # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
 # cache can kick in.
 expected_cabal_project_hash="c2c8ffc22f513f962745a00db6f9199eca89066ecbb47c850e5969550a4e6e1e"
-expected_cabal_project_freeze_hash="0999af7642e822e6b4e2996b743c8f924cdfa406c9b2941bb53f1ca7b3a0737d"
+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.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,
@@ -656,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,

gargantext.cabal

@@ -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
@@ -690,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
@@ -779,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
@@ -879,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
@@ -893,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
@@ -903,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:
@@ -930,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,6 +37,7 @@ 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)
@@ -66,6 +67,7 @@ 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
 
@@ -81,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
 
@@ -93,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

src/Gargantext/API/Node/ShareURL.hs

@@ -7,15 +7,16 @@ module Gargantext.API.Node.ShareURL where
 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.API.Routes.Named.Share qualified as Named
-import Gargantext.Core.Config (gc_url)
+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)
-import Gargantext.API.Admin.Types (appPort, settings)
 
 shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m)
 shareURL = Named.ShareURL getUrl
@@ -26,9 +27,20 @@ getUrl :: (IsGargServer env err m, CmdCommon env)
        -> m Named.ShareLink
 getUrl nt id = do
   -- TODO add check that the node is able to be shared (in a shared folder)
-  urlHost <- T.unpack <$> view (hasConfig . gc_url)
-  urlPort <- view (settings . appPort)
-  let res = do
+  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
 
@@ -42,6 +54,3 @@ getUrl nt id = do
   maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'")
         (Right . Named.ShareLink)
         (parseURI rawURL)
-  case res of
-    Left err        -> throwError $ _ValidationError # (V.check False err)
-    Right shareLink -> pure shareLink

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 (
@@ -26,6 +27,7 @@ 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
@@ -35,15 +37,20 @@ 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.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
@@ -53,6 +60,7 @@ import Servant.Server.Generic
 import Text.RE.Replace hiding (Capture)
 import Text.RE.TDFA.ByteString
 
+
 -- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
 instance {-# OVERLAPPING #-}
   ( AddSetCookies ('S n) a a
@@ -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
@@ -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,19 +156,22 @@ 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
    }
 
@@ -197,14 +210,14 @@ configFileSettings env sty =
     { 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
+  , 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
@@ -213,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
@@ -225,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
@@ -265,6 +299,29 @@ 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
+
 defaultForwardServerWithSettings :: ServiceType
                                  -> (Request -> Request)
                                  -> Env
@@ -298,13 +355,14 @@ defaultForwardServerWithSettings sty presendModifyRequest env proxySettings =
 
 defaultForwardServer :: ServiceType
                      -> (Request -> Request)
+                     -> (ResponseHeaders -> ResponseHeaders)
                      -> Env
                      -> ServerT Raw m
-defaultForwardServer sty presendModifyRequest env =
+defaultForwardServer sty presendModifyRequest mapRespHeaders env =
   defaultForwardServerWithSettings sty presendModifyRequest env $
     defaultWaiProxySettings {
         wpsProcessBody = \_req _res -> Just $ replaceRelativeLinks proxyDestination proxyPath
-      , wpsModifyResponseHeaders = \_req _res -> tweakResponseHeaders
+      , wpsModifyResponseHeaders = \_req _res -> (mapRespHeaders . tweakResponseHeaders)
       , wpsRedirectCounts = 5
       }
   where
@@ -316,7 +374,6 @@ defaultForwardServer sty presendModifyRequest env =
     proxyUrlStr :: String
     proxyUrlStr = showBaseUrl (proxyUrl env)
 
-
 --
 -- Utility functions
 --

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:
@@ -316,7 +318,7 @@ flags:
   "full-text-search":
     "build-search-demo": false
   gargantext:
-    "no-phylo-debug-logs": false
+    "no-phylo-debug-logs": true
     "test-crypto": false
   "ghc-lib-parser":
     "threaded-rts": 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)