Merge

bin/gargantext-init/Main.hs

@@ -24,12 +24,14 @@ import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus)
 import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (Cmd, DBCmd)
+import Gargantext.Database.Prelude (DBCmd)
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Table.User (insertNewUsers, )
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..), readConfig)
+import Gargantext.API.Admin.Types
+import Gargantext.Database.Prelude (DBCmd')
 
 
 main :: IO ()
@@ -49,18 +51,18 @@ main = do
   cfg       <- readConfig         iniPath
   let secret = _gc_secretkey cfg
 
-  let createUsers :: Cmd BackendInternalError Int64
+  let createUsers :: forall env. HasSettings env => DBCmd' env BackendInternalError Int64
       createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
                                    NE.:| arbitraryNewUsers
                                    )
 
   let
-    mkRoots :: Cmd BackendInternalError [(UserId, RootId)]
+    mkRoots :: forall env. HasSettings env => DBCmd' env BackendInternalError [(UserId, RootId)]
     mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername)
     -- TODO create all users roots
 
   let
-    initMaster :: Cmd BackendInternalError (UserId, RootId, CorpusId, ListId)
+    initMaster :: forall env. HasSettings env => DBCmd' env BackendInternalError (UserId, RootId, CorpusId, ListId)
     initMaster = do
       (masterUserId, masterRootId, masterCorpusId)
                   <- getOrMkRootWithCorpus MkCorpusUserMaster

bin/gargantext-invitations/Main.hs

@@ -17,6 +17,7 @@ module Main where
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Node () -- instances only
 import Gargantext.API.Errors.Types
+import Gargantext.API.Admin.Types
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Admin.Types.Node
@@ -37,7 +38,7 @@ main = do
 
   _cfg       <- readConfig         iniPath
 
-  let invite :: (CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
+  let invite :: (HasSettings env, CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
       invite = Share.api (UserName $ cs user) (UnsafeMkNodeId $ (read node_id :: Int)) (Share.ShareTeamParams $ cs email)
 
   withDevEnv iniPath $ \env -> do

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="3d88bb97cd394b645692343591ae3230d5393ee07b4e805251fffb9aed4a52dd"
-expected_cabal_project_freeze_hash="09930a2fa36e4325d46e5d069595d300c6017472f405f8ac67158377816d132a"
+expected_cabal_project_hash="22167800d98d4f204c85c49420eaee0618e749062b9ae9709719638e54319ae9"
+expected_cabal_project_freeze_hash="7bb3ba71d0a1881a5c4fd420b9988155586e0cf51e9b6d55867bce3d311d59a5"
 
 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

@@ -166,6 +166,11 @@ source-repository-package
     location: https://github.com/robstewart57/rdf4h.git
     tag: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
 
+source-repository-package
+    type: git
+    location: https://github.com/adinapoli/http-reverse-proxy.git
+    tag: c90b7bc55b0e628d0b71ccee4e222833a19792f8
+
 allow-older: *
 allow-newer: *
 

cabal.project.freeze

@@ -283,6 +283,7 @@ constraints: any.Cabal ==3.8.1.0,
              http-conduit +aeson,
              any.http-date ==0.0.11,
              any.http-media ==0.8.1.1,
+             any.http-reverse-proxy ==0.6.1.0,
              any.http-types ==0.12.3,
              any.http2 ==4.1.4,
              http2 -devel -h2spec,
@@ -453,8 +454,10 @@ constraints: any.Cabal ==3.8.1.0,
              any.refact ==0.3.0.2,
              any.reflection ==2.1.7,
              reflection -slow +template-haskell,
+             any.regex ==1.1.0.2,
              any.regex-base ==0.94.0.2,
              any.regex-compat ==0.95.2.1,
+             any.regex-pcre-builtin ==0.95.2.3.8.44,
              any.regex-posix ==0.96.0.1,
              regex-posix -_regex-posix-clib,
              any.regex-tdfa ==1.3.2.2,

gargantext-cors-settings.toml → gargantext-settings.toml

+
+[cors]
+
 allowed-origins = [
     "https://demo.gargantext.org"
   , "https://formation.gargantext.org"
@@ -15,3 +18,7 @@ allowed-origins = [
   ]
 
 use-origins-for-hosts = true
+
+[microservices]
+
+proxy-port = 8009

gargantext.cabal

@@ -49,7 +49,7 @@ data-files:
     test-data/phylo/phylo2dot2json.golden.json
     test-data/stemming/lancaster.txt
     test-data/test_config.ini
-    gargantext-cors-settings.toml
+    gargantext-settings.toml
     .clippy.dhall
 
 -- common options
@@ -107,6 +107,8 @@ library
       Gargantext.API.Admin.Orchestrator.Types
       Gargantext.API.Admin.Settings
       Gargantext.API.Admin.Settings.CORS
+      Gargantext.API.Admin.Settings.MicroServices
+      Gargantext.API.Admin.Settings.TOML
       Gargantext.API.Admin.Types
       Gargantext.API.Auth.PolicyCheck
       Gargantext.API.Count.Types
@@ -249,6 +251,7 @@ library
       Gargantext.Database.Schema.Node
       Gargantext.Database.Schema.User
       Gargantext.Defaults
+      Gargantext.MicroServices.ReverseProxy
       Gargantext.System.Logging
       Gargantext.Utils.Dict
       Gargantext.Utils.Jobs
@@ -561,6 +564,7 @@ library
     , http-conduit ^>= 2.3.8
     , http-media ^>= 0.8.0.0
     , http-types ^>= 0.12.3
+    , http-reverse-proxy >= 0.6.1.0
     , hxt ^>= 9.3.1.22
     , ihaskell >= 0.11.0.0
     -- necessary for ihaskell to build
@@ -613,7 +617,10 @@ library
     , quickcheck-instances ^>= 0.3.25.2
     , rake ^>= 0.0.1
     , random ^>= 1.2.1
+    , raw-strings-qq
     , rdf4h ^>= 3.1.1
+    , recover-rtti >= 0.4 && < 0.5
+    , regex
     , regex-compat ^>= 0.95.2.1
     , regex-tdfa ^>= 1.3.1.2
     , replace-attoparsec ^>= 1.4.5.0

src/Gargantext/API.hs

@@ -35,6 +35,7 @@ module Gargantext.API
       where
 
 import Control.Concurrent
+import Control.Concurrent.Async qualified as Async
 import Control.Lens hiding (Level)
 import Data.List (lookup)
 import Data.Text (pack)
@@ -45,13 +46,15 @@ import Gargantext.API.Admin.Auth.Types (AuthContext)
 import Gargantext.API.Admin.EnvTypes (Env, Mode(..))
 import Gargantext.API.Admin.Settings (newEnv)
 import Gargantext.API.Admin.Settings.CORS
-import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings)
-import Gargantext.API.Routes.Named.EKG
+import Gargantext.API.Admin.Settings.MicroServices
+import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microservicesSettings)
 import Gargantext.API.Middleware (logStdoutDevSanitised)
 import Gargantext.API.Routes.Named (API)
+import Gargantext.API.Routes.Named.EKG
 import Gargantext.API.Server.Named (server)
 import Gargantext.API.Server.Named.EKG
 import Gargantext.Database.Prelude qualified as DB
+import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
 import Gargantext.Prelude hiding (putStrLn)
 import Gargantext.System.Logging
 import Network.HTTP.Types hiding (Query)
@@ -68,12 +71,17 @@ import System.FilePath
 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
 startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
   env <- newEnv logger port file
+  let proxyPort = env ^. settings.microservicesSettings.msProxyPort
   runDbCheck env
-  portRouteInfo port
+  portRouteInfo port proxyPort
   app <- makeApp env
   mid <- makeGargMiddleware (env ^. settings.corsSettings) mode
   periodicActions <- schedulePeriodicActions env
-  run port (mid app) `finally` stopGargantext periodicActions
+
+  let runServer = run port (mid app) `finally` stopGargantext periodicActions
+  let runProxy  = run proxyPort (mid (microServicesProxyApp env))
+
+  Async.race_ runServer runProxy
 
   where runDbCheck env = do
           r <- runExceptT (runReaderT DB.dbCheck env) `catch`
@@ -84,14 +92,15 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
               "You must run 'gargantext-init " <> pack file <>
               "' before running gargantext-server (only the first time)."
 
-portRouteInfo :: PortNumber -> IO ()
-portRouteInfo port = do
+portRouteInfo :: PortNumber -> PortNumber -> IO ()
+portRouteInfo mainPort proxyPort = do
   putStrLn   "=========================================================================================================="
   putStrLn   " GarganText Main Routes"
   putStrLn   "=========================================================================================================="
-  putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece port <> "/index.html"
-  putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
-  putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece port <> "/gql"
+  putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece mainPort <> "/index.html"
+  putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
+  putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
+  putStrLn $ " - Microservices proxy .....................: " <> "http://localhost:" <> toUrlPiece proxyPort
   putStrLn   "=========================================================================================================="
 
 -- | Stops the gargantext server and cancels all the periodic actions

src/Gargantext/API/Admin/EnvTypes.hs

@@ -12,6 +12,7 @@ module Gargantext.API.Admin.EnvTypes (
   , mkJobHandle
   , env_logger
   , env_manager
+  , env_settings
   , env_self_url
   , menv_firewall
   , dev_env_logger

src/Gargantext/API/Admin/Settings.hs

@@ -25,10 +25,9 @@ import Control.Monad.Logger (LogLevel(..))
 import Control.Monad.Reader
 import Data.ByteString.Lazy qualified as L
 import Data.Pool (Pool)
-import qualified Data.Pool as Pool
 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
 import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Admin.Settings.CORS
+import Gargantext.API.Admin.Settings.TOML (GargTomlSettings(..), loadGargTomlSettings)
 import Gargantext.API.Admin.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
@@ -52,15 +51,17 @@ import Servant.Job.Async (newJobEnv, defaultSettings)
 import System.Directory
 import System.IO (hClose)
 import System.IO.Temp (withTempFile)
+import qualified Data.Pool as Pool
 
 devSettings :: FilePath -> IO Settings
 devSettings jwkFile = do
   jwkExists <- doesFileExist jwkFile
   when (not jwkExists) $ writeKey jwkFile
   jwk       <- readKey jwkFile
-  gargCorsSettings <- loadGargCorsSettings
+  GargTomlSettings{..} <- loadGargTomlSettings
   pure $ Settings
-    { _corsSettings = gargCorsSettings
+    { _corsSettings = _gargCorsSettings
+    , _microservicesSettings = _gargMicroServicesSettings
     , _appPort = 3000
     , _logLevelLimit = LevelDebug
 --    , _dbServer = "localhost"

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

@@ -6,13 +6,11 @@ module Gargantext.API.Admin.Settings.CORS where
 
 import Prelude
 
+import Control.Arrow
 import Data.Text qualified as T
 import Toml
-import Gargantext.System.Logging
-import Paths_gargantext
-import Data.String
-import Control.Arrow
-import Control.Lens.TH
+import Control.Lens hiding (iso, (.=))
+import Data.String (IsString)
 
 newtype CORSOrigin = CORSOrigin { _CORSOrigin :: T.Text }
   deriving (Show, Eq, IsString)
@@ -35,23 +33,9 @@ corsOriginCodec = _Orig >>> _Text
    _Orig = iso _CORSOrigin CORSOrigin
 
 corsSettingsCodec :: TomlCodec CORSSettings
-corsSettingsCodec = CORSSettings <$> (Toml.arrayOf corsOriginCodec "allowed-origins" .= _corsAllowedOrigins)
+corsSettingsCodec = CORSSettings
+     <$> Toml.arrayOf corsOriginCodec "allowed-origins" .= _corsAllowedOrigins
      <*> pure mempty -- FIXME(adn) Currently we don't need to support this field.
      <*> Toml.bool "use-origins-for-hosts" .= _corsUseOriginsForHosts
 
--- | Loads the 'CORSSettings' from the 'toml' file.
-loadGargCorsSettings :: IO CORSSettings
-loadGargCorsSettings = do
-  corsFile <- getDataFileName "gargantext-cors-settings.toml"
-  tomlRes <- Toml.decodeFileEither corsSettingsCodec corsFile
-  case tomlRes of
-      Left errs      -> do
-        withLogger () $ \ioLogger -> do
-          logMsg ioLogger WARNING $ T.unpack $ "Error, gargantext-cors-settings.toml parsing failed: " <> Toml.prettyTomlDecodeErrors errs
-          pure $ CORSSettings ["http://localhost:8008"] ["http://localhost:3000"] False
-      Right settings0 -> case _corsUseOriginsForHosts settings0 of
-        True  -> pure $ settings0 { _corsAllowedHosts = "http://localhost:3000" : (_corsAllowedOrigins settings0) }
-        False -> pure $ settings0 { _corsAllowedHosts = "http://localhost:3000" : (_corsAllowedHosts settings0) }
-
-
 makeLenses ''CORSSettings

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

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Gargantext.API.Admin.Settings.MicroServices where
+
+import Prelude
+
+import Control.Lens.TH
+import Data.Text qualified as T
+import Gargantext.Prelude.Config
+import Servant.Client.Core.BaseUrl
+import Toml
+
+data MicroServicesSettings =
+  MicroServicesSettings {
+    -- | The port where the microservices proxy will be listening on.
+    _msProxyPort :: Int
+  } deriving (Show, Eq)
+
+microServicesSettingsCodec :: TomlCodec MicroServicesSettings
+microServicesSettingsCodec = MicroServicesSettings
+  <$> Toml.int "proxy-port" .= _msProxyPort
+
+mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl
+mkProxyUrl GargConfig{..} MicroServicesSettings{..} =
+  case parseBaseUrl (T.unpack _gc_url) of
+    Nothing -> BaseUrl Http "localhost" 80 ""
+    Just bh -> bh { baseUrlPort = _msProxyPort }
+
+
+makeLenses ''MicroServicesSettings

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

+{-# LANGUAGE TemplateHaskell #-}
+module Gargantext.API.Admin.Settings.TOML where
+
+import Control.Lens hiding ((.=))
+import Data.Text qualified as T
+import Gargantext.API.Admin.Settings.CORS
+import Gargantext.API.Admin.Settings.MicroServices
+import Gargantext.Prelude (panicTrace)
+import Gargantext.System.Logging
+import Paths_gargantext
+import Prelude
+import Toml
+import Servant.Client.Core.BaseUrl
+
+-- | Compatibility bridge until we fix #304 (move to Toml)
+data GargTomlSettings = GargTomlSettings
+  { _gargCorsSettings          :: !CORSSettings
+  , _gargMicroServicesSettings :: !MicroServicesSettings
+  }
+
+makeLenses ''GargTomlSettings
+
+settingsCodec :: TomlCodec GargTomlSettings
+settingsCodec = GargTomlSettings
+  <$> (Toml.table corsSettingsCodec "cors" .= _gargCorsSettings)
+  <*> (Toml.table  microServicesSettingsCodec "microservices" .= _gargMicroServicesSettings)
+
+-- | Extends the 'allowed-origins' in the CORSettings with the URLs embellished
+-- with the proxy port.
+addProxyToAllowedOrigins :: GargTomlSettings -> GargTomlSettings
+addProxyToAllowedOrigins stgs =
+  stgs & over gargCorsSettings (addProxies $ stgs ^. gargMicroServicesSettings . msProxyPort)
+  where
+    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 }
+      in cors { _corsAllowedOrigins = origins <> Prelude.map mkUrl origins }
+
+-- | Loads the 'CORSSettings' from the 'toml' file.
+loadGargTomlSettings :: IO GargTomlSettings
+loadGargTomlSettings = do
+  tomlFile <- getDataFileName "gargantext-settings.toml"
+  tomlRes <- Toml.decodeFileEither settingsCodec tomlFile
+  case tomlRes of
+      Left errs      -> do
+        withLogger () $ \ioLogger -> 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" :)

src/Gargantext/API/Admin/Types.hs

@@ -9,6 +9,7 @@ import Gargantext.API.Admin.Settings.CORS
 import Gargantext.Prelude
 import Servant.Auth.Server (JWTSettings, CookieSettings(..))
 import Servant.Client (BaseUrl)
+import Gargantext.API.Admin.Settings.MicroServices
 
 
 type PortNumber = Int
@@ -20,6 +21,7 @@ data SendEmailType = SendEmailViaAws
 
 data Settings = Settings
     { _corsSettings          :: !CORSSettings   -- CORS settings
+    , _microservicesSettings :: !MicroServicesSettings
     , _appPort               :: !PortNumber
     , _logLevelLimit         :: !LogLevel -- log level from the monad-logger package
 --    , _dbServer        :: Text

src/Gargantext/API/Node/Corpus/New.hs

@@ -150,7 +150,9 @@ type AddWithFile = Summary "Add with MultipartData to corpus endpoint"
 addToCorpusWithQuery :: ( FlowCmdM env err m
                         , MonadJobStatus m
                         , HasNodeStoryImmediateSaver env
-                        , HasNodeArchiveStoryImmediateSaver env )
+                        , HasNodeArchiveStoryImmediateSaver env
+                        , HasSettings env
+                        )
                        => User
                        -> CorpusId
                        -> WithQuery
@@ -222,7 +224,9 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
 addToCorpusWithForm :: ( FlowCmdM env err m
                        , MonadJobStatus m
                        , HasNodeStoryImmediateSaver env
-                       , HasNodeArchiveStoryImmediateSaver env )
+                       , HasNodeArchiveStoryImmediateSaver env
+                       , HasSettings env
+                       )
                     => User
                     -> CorpusId
                     -> NewWithForm

src/Gargantext/API/Node/Corpus/Searx.hs

@@ -48,6 +48,7 @@ import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
 import Network.HTTP.Client
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Prelude qualified
+import Gargantext.API.Admin.Types (HasSettings)
 
 langToSearx :: Lang -> Text
 langToSearx x   = Text.toLower acronym <> "-" <> acronym
@@ -120,7 +121,9 @@ insertSearxResponse :: ( MonadBase IO m
                        , HasNLPServer env
                        , HasNodeError err
                        , HasTreeError err
-                       , HasValidationError err )
+                       , HasValidationError err
+                       , HasSettings env
+                       )
                     => User
                     -> CorpusId
                     -> ListId
@@ -163,7 +166,9 @@ triggerSearxSearch :: ( MonadBase IO m
                       , HasNodeError err
                       , HasTreeError err
                       , HasValidationError err
-                      , MonadJobStatus m )
+                      , MonadJobStatus m
+                      , HasSettings env
+                      )
                    => User
                    -> CorpusId
                    -> Query.RawQuery

src/Gargantext/API/Node/DocumentUpload.hs

@@ -20,6 +20,7 @@ import Control.Lens (view)
 import Data.Text qualified as T
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Node.DocumentUpload.Types
 import Gargantext.API.Prelude ( GargM )
@@ -44,7 +45,7 @@ api nId = Named.DocumentUploadAPI $ AsyncJobs $
   serveJobsAPI UploadDocumentJob $ \jHandle q -> do
       documentUploadAsync nId q jHandle
 
-documentUploadAsync :: (FlowCmdM env err m, MonadJobStatus m)
+documentUploadAsync :: (FlowCmdM env err m, MonadJobStatus m, HasSettings env)
                => NodeId
                -> DocumentUpload
                -> JobHandle m
@@ -55,7 +56,7 @@ documentUploadAsync nId doc jobHandle = do
   -- printDebug "documentUploadAsync" docIds
   markComplete jobHandle
 
-documentUpload :: (FlowCmdM env err m)
+documentUpload :: (FlowCmdM env err m, HasSettings env)
                => NodeId
                -> DocumentUpload
                -> m [DocId]

src/Gargantext/API/Node/FrameCalcUpload.hs

@@ -41,6 +41,7 @@ import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..), markFailureNoErr
 import Network.HTTP.Client (newManager, httpLbs, parseRequest, responseBody)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Servant.Server.Generic (AsServerT)
+import Gargantext.API.Admin.Types (HasSettings)
 
 
 api :: AuthenticatedUser -> NodeId -> Named.FrameCalcAPI (AsServerT (GargM Env BackendInternalError))
@@ -53,7 +54,9 @@ api authenticatedUser nId = Named.FrameCalcAPI $ AsyncJobs $
 frameCalcUploadAsync :: ( HasConfig env
                         , FlowCmdM env err m
                         , MonadJobStatus m
-                        , HasNodeArchiveStoryImmediateSaver env )
+                        , HasNodeArchiveStoryImmediateSaver env
+                        , HasSettings env
+                        )
                      => AuthenticatedUser
                      -- ^ The logged-in user
                      -> NodeId

src/Gargantext/API/Node/New.hs

@@ -31,19 +31,20 @@ import Gargantext.API.Routes.Named.Node qualified as Named
 import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Action.Node
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (Cmd)
+import Gargantext.Database.Prelude (DBCmd')
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Prelude
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
 import Servant.Server.Generic (AsServerT)
+import Gargantext.API.Admin.Types (HasSettings)
 
 ------------------------------------------------------------------------
-postNode :: HasNodeError err
+postNode :: (HasNodeError err, HasSettings env)
          => AuthenticatedUser
          -- ^ The logged-in user
          -> NodeId
          -> PostNode
-         -> Cmd err [NodeId]
+         -> DBCmd' env err [NodeId]
 postNode authenticatedUser pId (PostNode nodeName nt) = do
   let userId = authenticatedUser ^. auth_user_id
   mkNodeWithParent nt (Just pId) userId nodeName
@@ -58,7 +59,7 @@ postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ AsyncJobs $
   serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync authenticatedUser nId p jHandle
 
 ------------------------------------------------------------------------
-postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m)
+postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m, HasSettings env)
     => AuthenticatedUser
     -- ^ The logged in user
     -> NodeId

src/Gargantext/API/Node/Share.hs

@@ -32,12 +32,13 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Tree (findNodesWithType)
 import Gargantext.Prelude
 import Servant.Server.Generic (AsServerT)
+import Gargantext.API.Admin.Types (HasSettings)
 
 ------------------------------------------------------------------------
 -- TODO permission
 -- TODO refactor userId which is used twice
 -- TODO change return type for better warning/info/success/error handling on the front
-api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m)
+api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m, HasSettings env)
     => User
     -> NodeId
     -> ShareNodeParams

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

@@ -13,11 +13,15 @@ module Gargantext.API.Routes.Named.Private (
   , NodeAPIEndpoint(..)
   , MembersAPI(..)
   , IsGenericNodeRoute(..)
+  , NotesProxy(..)
   ) where
 
 
+import Data.Kind
 import Data.Text (Text)
+import Data.Text qualified as T
 import GHC.Generics
+import GHC.TypeLits
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Auth.PolicyCheck
 import Gargantext.API.Routes.Named.Contact
@@ -25,19 +29,17 @@ import Gargantext.API.Routes.Named.Context
 import Gargantext.API.Routes.Named.Corpus
 import Gargantext.API.Routes.Named.Count
 import Gargantext.API.Routes.Named.Document
-import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.List qualified as List
+import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.Share
-import Gargantext.API.Routes.Named.Tree
 import Gargantext.API.Routes.Named.Table
+import Gargantext.API.Routes.Named.Tree
 import Gargantext.API.Routes.Named.Viz
 import Gargantext.Database.Admin.Types.Hyperdata.Any
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Admin.Types.Node
 import Servant.API
 import Servant.Auth qualified as SA
-import Data.Kind
-import GHC.TypeLits
 
 
 type MkProtectedAPI private = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser :> private
@@ -96,6 +98,12 @@ data GargPrivateAPI' mode = GargPrivateAPI'
   } deriving Generic
 
 
+data NotesProxy mode = NotesProxy
+  { noteProxyEp :: mode :- Capture "frameId" T.Text
+                        :> Raw
+  } deriving Generic
+
+
 data GargAdminAPI mode = GargAdminAPI
   { rootsEp       :: mode :- "user"  :> Summary "First user endpoint" :> NamedRoutes Roots
   , adminNodesAPI :: mode :- "nodes" :> Summary "Nodes endpoint"

src/Gargantext/API/Server/Named.hs

@@ -31,15 +31,15 @@ import Servant
 import Servant.Server.Generic
 import Servant.Swagger.UI (swaggerSchemaUIServer)
 
-serverGargAPI :: Text -> BackEndAPI (AsServerT (GargM Env BackendInternalError))
-serverGargAPI baseUrl
+serverGargAPI :: Env -> BackEndAPI (AsServerT (GargM Env BackendInternalError))
+serverGargAPI env
        =  BackEndAPI $ MkBackEndAPI $ GargAPIVersion $ GargAPI'
             { gargAuthAPI                = AuthAPI auth
             , gargForgotPasswordAPI      = forgotPassword
             , gargForgotPasswordAsyncAPI = forgotPasswordAsync
             , gargVersionAPI             = gargVersion
             , gargPrivateAPI             = serverPrivateGargAPI
-            , gargPublicAPI              = serverPublicGargAPI baseUrl
+            , gargPublicAPI              = serverPublicGargAPI (env ^. hasConfig . gc_url_backend_api)
             }
   where
     gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError))
@@ -54,7 +54,7 @@ server env =
                       (Proxy :: Proxy (NamedRoutes BackEndAPI))
                       (Proxy :: Proxy AuthContext)
                       (transformJSON errScheme)
-                      (serverGargAPI (env ^. hasConfig . gc_url_backend_api))
+                      (serverGargAPI env)
      , graphqlAPI = hoistServerWithContext
                       (Proxy :: Proxy (NamedRoutes GraphQLAPI))
                       (Proxy :: Proxy AuthContext)

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

-
+{-# OPTIONS_GHC -Wno-deprecations #-}
 module Gargantext.API.Server.Named.Private where
 
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
@@ -26,7 +26,6 @@ import Gargantext.Prelude
 import Servant.Auth.Swagger ()
 import Servant.Server.Generic (AsServerT)
 
-
 ---------------------------------------------------------------------
 -- | Server declarations
 

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

@@ -21,6 +21,7 @@ module Gargantext.Core.Viz.Graph.API
 import Control.Lens (set, _Just, (^?), at)
 import Data.HashMap.Strict qualified as HashMap
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
+import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Prelude (GargM)
@@ -36,7 +37,7 @@ import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOn
 import Gargantext.Database.Action.Node (mkNodeWithParent)
 import Gargantext.Database.Admin.Config ( userMaster )
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (DBCmd)
+import Gargantext.Database.Prelude (DBCmd, DBCmd')
 import Gargantext.Database.Query.Table.Node ( getOrMkList, getNodeWith, defaultList, getClosestParentIdByType )
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
@@ -266,11 +267,11 @@ recomputeVersions :: HasNodeStory env err m
 recomputeVersions nId = recomputeGraph nId Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
 
 ------------------------------------------------------------
-graphClone :: HasNodeError err
+graphClone :: (HasNodeError err, HasSettings env)
            => UserId
            -> NodeId
            -> HyperdataGraphAPI
-           -> DBCmd err NodeId
+           -> DBCmd' env err NodeId
 graphClone userId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
                                          , _hyperdataAPICamera = camera }) = do
   let nodeType = NodeGraph

src/Gargantext/Database/Action/Flow.hs

@@ -90,7 +90,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire, HyperdataCorpus(_hc_lang) )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(toHyperdataDocument) )
 import Gargantext.Database.Admin.Types.Node hiding (DEBUG) -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
-import Gargantext.Database.Prelude (DbCmd', DBCmd, hasConfig)
+import Gargantext.Database.Prelude (DbCmd', hasConfig, DBCmd')
 import Gargantext.Database.Query.Table.ContextNodeNgrams2 ( ContextNodeNgrams2Poly(..), insertContextNodeNgrams2 )
 import Gargantext.Database.Query.Table.Node ( MkCorpus, insertDefaultNodeIfNotExists, getOrMkList, getNodeWith )
 import Gargantext.Database.Query.Table.Node.Document.Add qualified as Doc (add)
@@ -110,6 +110,7 @@ import PUBMED.Types qualified as PUBMED
 ------------------------------------------------------------------------
 -- Imports for upgrade function
 import Gargantext.Database.Query.Tree.Error ( HasTreeError )
+import Gargantext.API.Admin.Types (HasSettings)
 
 ------------------------------------------------------------------------
 
@@ -126,14 +127,14 @@ printDataText (DataNew (maybeInt, conduitData)) = do
   putText $ show (maybeInt, res)
 
 -- TODO use the split parameter in config file
-getDataText :: (HasNodeError err)
+getDataText :: (HasNodeError err, HasSettings env)
             => DataOrigin
             -> TermType Lang
             -> API.RawQuery
             -> Maybe PUBMED.APIKey
             -> Maybe EPO.AuthKey
             -> Maybe API.Limit
-            -> DBCmd err (Either API.GetCorpusError DataText)
+            -> DBCmd' env err (Either API.GetCorpusError DataText)
 getDataText (ExternalOrigin api) la q mPubmedAPIKey mAuthKey li = do
   cfg <- view hasConfig
   eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey mAuthKey (_gc_epo_api_url cfg) li
@@ -143,12 +144,12 @@ getDataText (InternalOrigin _) la q _ _ _li = do
   ids <-  map fst <$> searchDocInDatabase cId (stem (_tt_lang la) GargPorterAlgorithm $ API.getRawQuery q)
   pure $ Right $ DataOld ids
 
-getDataText_Debug :: (HasNodeError err)
+getDataText_Debug :: (HasNodeError err, HasSettings env)
                   => DataOrigin
                   -> TermType Lang
                   -> API.RawQuery
                   -> Maybe API.Limit
-                  -> DBCmd err ()
+                  -> DBCmd' env err ()
 getDataText_Debug a l q li = do
   result <- getDataText a l q Nothing Nothing li
   case result of
@@ -165,6 +166,7 @@ flowDataText :: forall env err m.
                 , HasTreeError err
                 , HasValidationError err
                 , MonadJobStatus m
+                , HasSettings env
                 )
                 => User
                 -> DataText
@@ -193,7 +195,9 @@ flowAnnuaire :: ( DbCmd' env err m
                 , HasNLPServer env
                 , HasTreeError err
                 , HasValidationError err
-                , MonadJobStatus m )
+                , MonadJobStatus m
+                , HasSettings env
+                )
              => MkCorpusUser
              -> TermType Lang
              -> FilePath
@@ -211,7 +215,9 @@ flowCorpusFile :: ( DbCmd' env err m
                   , HasNLPServer env
                   , HasTreeError err
                   , HasValidationError err
-                  , MonadJobStatus m )
+                  , MonadJobStatus m
+                  , HasSettings env
+                  )
            => MkCorpusUser
            -> Limit -- Limit the number of docs (for dev purpose)
            -> TermType Lang
@@ -240,7 +246,9 @@ flowCorpus :: ( DbCmd' env err m
               , HasTreeError err
               , HasValidationError err
               , FlowCorpus a
-              , MonadJobStatus m )
+              , MonadJobStatus m
+              , HasSettings env
+              )
            => MkCorpusUser
            -> TermType Lang
            -> Maybe FlowSocialListWith
@@ -260,6 +268,7 @@ flow :: forall env err m a c.
         , FlowCorpus a
         , MkCorpus c
         , MonadJobStatus m
+        , HasSettings env
         )
         => Maybe c
         -> MkCorpusUser
@@ -296,6 +305,7 @@ addDocumentsToHyperCorpus :: ( DbCmd' env err m
                              , HasNodeError err
                              , FlowCorpus document
                              , MkCorpus corpus
+                             , HasSettings env
                              )
                              => NLPServerConfig
                              -> Maybe corpus
@@ -309,7 +319,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
   pure ids
 
 ------------------------------------------------------------------------
-createNodes :: ( DbCmd' env err m, HasNodeError err
+createNodes :: ( DbCmd' env err m, HasNodeError err, HasSettings env
                , MkCorpus c
                )
             => MkCorpusUser
@@ -338,6 +348,7 @@ flowCorpusUser :: ( HasNodeError err
                   , HasTreeError err
                   , HasNodeStory env err m
                   , MkCorpus c
+                  , HasSettings env
                   )
                => Lang
                -> User
@@ -367,6 +378,7 @@ buildSocialList :: ( HasNodeError err
                    , HasTreeError err
                    , HasNodeStory env err m
                    , MkCorpus c
+                   , HasSettings env
                    )
                 => Lang
                 -> User
@@ -402,6 +414,7 @@ insertMasterDocs :: ( DbCmd' env err m
                     , HasNodeError err
                     , FlowCorpus a
                     , MkCorpus   c
+                    , HasSettings env
                     )
                  => NLPServerConfig
                  -> Maybe c

src/Gargantext/Database/Action/Node.hs

@@ -21,27 +21,31 @@ module Gargantext.Database.Action.Node
   where
 
 import Control.Lens (view)
+import Data.Text qualified as T
+import Gargantext.API.Admin.Settings.MicroServices
+import Gargantext.API.Admin.Types (settings, _microservicesSettings, HasSettings)
 import Gargantext.Core
 import Gargantext.Core.Types (Name)
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Hyperdata.Default
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (DBCmd, HasConfig(..))
+import Gargantext.Database.Prelude (HasConfig(..), DBCmd')
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Prelude hiding (hash)
 import Gargantext.Prelude.Config (GargConfig(..))
 import Gargantext.Prelude.Crypto.Hash (hash)
+import Servant.Client.Core.BaseUrl
 
 ------------------------------------------------------------------------
 -- | TODO mk all others nodes
-mkNodeWithParent :: (HasNodeError err, HasDBid NodeType)
+mkNodeWithParent :: (HasNodeError err, HasDBid NodeType, HasSettings env)
                  => NodeType
                  -> Maybe ParentId
                  -> UserId
                  -> Name
-                 -> DBCmd err [NodeId]
+                 -> DBCmd' env err [NodeId]
 mkNodeWithParent NodeUser (Just pId) uid  _ = nodeError $ NodeCreationFailed $ UserParentAlreadyExists uid pId
 
 ------------------------------------------------------------------------
@@ -70,12 +74,12 @@ mkNodeWithParent nt (Just pId) uId name  = (:[]) <$> insertNode nt (Just name) N
 
 
 -- | Sugar to create a node, get its NodeId and update its Hyperdata after
-mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err, HasDBid NodeType)
+mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err, HasDBid NodeType, HasSettings env)
                                     => NodeType
                                     -> Maybe ParentId
                                     -> UserId
                                     -> Name
-                                    -> DBCmd err [NodeId]
+                                    -> DBCmd' env err [NodeId]
 mkNodeWithParent_ConfigureHyperdata Notes (Just i) uId name =
   mkNodeWithParent_ConfigureHyperdata' Notes (Just i) uId name
 
@@ -92,14 +96,16 @@ mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[])
 
 mkNodeWithParent_ConfigureHyperdata    _ _ _ _ = nodeError NotImplYet
 
+internalNotesProxy :: BaseUrl -> T.Text
+internalNotesProxy proxyUrl = T.pack $ showBaseUrl proxyUrl <> "/notes"
 
 -- | Function not exposed
-mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType)
+mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType, HasSettings env)
                                      => NodeType
                                      -> Maybe ParentId
                                      -> UserId
                                      -> Name
-                                    -> DBCmd err [NodeId]
+                                     -> DBCmd' env err [NodeId]
 mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
   nodeId <- case nt of
      Notes -> insertNode Notes (Just name)   Nothing i uId
@@ -108,8 +114,9 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
      _              -> nodeError NeedsConfiguration
 
   cfg <- view hasConfig
+  stt <- view settings
   u <- case nt of
-        Notes -> pure $ _gc_frame_write_url cfg
+        Notes -> pure $ internalNotesProxy (mkProxyUrl cfg $ _microservicesSettings stt)
         Calc  -> pure $ _gc_frame_calc_url  cfg
         NodeFrameVisio -> pure $ _gc_frame_visio_url  cfg
         _              -> nodeError NeedsConfiguration

src/Gargantext/Database/Action/User/New.hs

@@ -29,12 +29,13 @@ import Control.Lens (view)
 import Control.Monad.Random
 import Data.Text (splitOn)
 import Data.Text qualified as Text
+import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.Core.Mail
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.Flow (getOrMkRoot)
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (Cmd, DBCmd, CmdM)
+import Gargantext.Database.Prelude (Cmd, DBCmd, CmdM, DBCmd')
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
 import Gargantext.Database.Query.Table.User
 import Gargantext.Prelude
@@ -45,7 +46,7 @@ import qualified Data.List.NonEmpty as NE
 ------------------------------------------------------------------------
 -- | Creates a new 'User' from the input 'EmailAddress', which needs to
 -- be valid (i.e. a valid username needs to be inferred via 'guessUsername').
-newUser :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
+newUser :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env, HasSettings env)
         => EmailAddress
         -> m UserId
 newUser emailAddress = do
@@ -60,9 +61,9 @@ newUser emailAddress = do
 -- This is an internal function and as such it /doesn't/ send out any email
 -- notification, and thus lives in the 'DbCmd' effect stack. You may want to
 -- use 'newUser' instead for standard Gargantext code.
-new_user :: HasNodeError err
+new_user :: (HasNodeError err, HasSettings env)
          => NewUser GargPassword
-         -> DBCmd err UserId
+         -> DBCmd' env err UserId
 new_user rq = do
   (uid NE.:| _) <- new_users (rq NE.:| [])
   pure uid
@@ -72,17 +73,17 @@ new_user rq = do
 -- This is an internal function and as such it /doesn't/ send out any email
 -- notification, and thus lives in the 'DbCmd' effect stack. You may want to
 -- use 'newUsers' instead for standard Gargantext code.
-new_users :: HasNodeError err
+new_users :: (HasNodeError err, HasSettings env)
           => NonEmpty (NewUser GargPassword)
           -- ^ A list of users to create.
-          -> DBCmd err (NonEmpty UserId)
+          -> DBCmd' env err (NonEmpty UserId)
 new_users us = do
   us'   <- liftBase        $ mapM toUserHash us
   void  $ insertUsers      $ NE.map toUserWrite us'
   mapM (fmap fst . getOrMkRoot) $ NE.map  (\u -> UserName   (_nu_username u)) us
 
 ------------------------------------------------------------------------
-newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
+newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env, HasSettings env)
          => NonEmpty EmailAddress
          -> m (NonEmpty UserId)
 newUsers us = do
@@ -108,8 +109,8 @@ guessUserName n = case splitOn "@" n of
     _       -> Nothing
 
 ------------------------------------------------------------------------
-newUsers' :: HasNodeError err
-         => MailConfig -> NonEmpty (NewUser GargPassword) -> Cmd err (NonEmpty UserId)
+newUsers' :: (HasNodeError err, HasSettings env)
+         => MailConfig -> NonEmpty (NewUser GargPassword) -> DBCmd' env err (NonEmpty UserId)
 newUsers' cfg us = do
   us' <- liftBase         $ mapM toUserHash  us
   void $ insertUsers      $ NE.map  toUserWrite us'

src/Gargantext/Database/Prelude.hs

@@ -99,6 +99,7 @@ type Cmd'' env err a = forall m.     CmdM''    env err m => m a
 type Cmd'   env err a = forall m.     CmdM'     env err m => m a
 type Cmd        err a = forall m env. CmdM      env err m => m a
 type CmdR       err a = forall m env. CmdRandom env err m => m a
+type DBCmd' env err a = forall m.     DbCmd'    env err m => m a
 type DBCmd      err a = forall m env. DbCmd'    env err m => m a
 
 -- | Only the /minimum/ amount of class constraints required

src/Gargantext/Database/Query/Tree/Root.hs

@@ -22,7 +22,7 @@ import Gargantext.Database.Action.User (getUserId, getUsername)
 import Gargantext.Database.Admin.Config ( corpusMasterName, userMaster )
 import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser )
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (runOpaQuery, DBCmd)
+import Gargantext.Database.Prelude (runOpaQuery, DBCmd, DBCmd')
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
@@ -30,6 +30,7 @@ import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead, queryNodeTable)
 import Gargantext.Prelude
 import Opaleye (restrict, (.==), Select)
 import Opaleye.SqlTypes (sqlStrictText, sqlInt4)
+import Gargantext.API.Admin.Types (HasSettings)
 
 
 getRootId :: (HasNodeError err) => User -> DBCmd err NodeId
@@ -42,9 +43,9 @@ getRootId u = do
 getRoot :: User -> DBCmd err [Node HyperdataUser]
 getRoot = runOpaQuery . selectRoot
 
-getOrMkRoot :: (HasNodeError err)
+getOrMkRoot :: (HasNodeError err, HasSettings env)
             => User
-            -> DBCmd err (UserId, RootId)
+            -> DBCmd' env err (UserId, RootId)
 getOrMkRoot user = do
   userId <- getUserId user
 
@@ -77,10 +78,10 @@ userFromMkCorpusUser (MkCorpusUserNormalCorpusIds u _cids) = u
 userFromMkCorpusUser (MkCorpusUserNormalCorpusName u _cname) = u
 
 
-getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
+getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a, HasSettings env)
                       => MkCorpusUser
                       -> Maybe a
-                      -> DBCmd err (UserId, RootId, CorpusId)
+                      -> DBCmd' env err (UserId, RootId, CorpusId)
 getOrMkRootWithCorpus MkCorpusUserMaster c = do
   (userId, rootId) <- getOrMkRoot (UserName userMaster)
   corpusId'' <- do
@@ -119,9 +120,9 @@ mkCorpus cName c rootId userId = do
   pure (userId, rootId, corpusId)
 
 
-mkRoot :: HasNodeError err
+mkRoot :: (HasNodeError err, HasSettings env)
        => User
-       -> DBCmd err [RootId]
+       -> DBCmd' env err [RootId]
 mkRoot user = do
 
   -- TODO

src/Gargantext/MicroServices/ReverseProxy.hs

+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE QuasiQuotes        #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE TypeOperators      #-}
+
+module Gargantext.MicroServices.ReverseProxy (
+  microServicesProxyApp
+
+  -- * Internals
+  , removeFromReferer
+  ) where
+
+import Prelude
+
+import Conduit
+import Data.ByteString qualified as B
+import Data.ByteString.Builder
+import Data.ByteString.Char8 qualified as C8
+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.EnvTypes
+import Gargantext.API.Admin.Settings.MicroServices
+import Gargantext.API.Admin.Types
+import Gargantext.API.Types (HTML)
+import Gargantext.Database.Prelude (hasConfig)
+import Gargantext.Prelude
+import Gargantext.Prelude.Config (gc_frame_write_url)
+import Network.HTTP.ReverseProxy
+import Network.HTTP.Types (hCacheControl, RequestHeaders, hReferer, ResponseHeaders, Header)
+import Network.HTTP.Types.Header (hHost)
+import Network.Wai (Request, rawPathInfo, requestHeaders)
+import Servant hiding (Header)
+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)
+
+--
+-- Types
+--
+
+newtype FrameId = FrameId { _FrameId :: T.Text }
+  deriving (Show, Eq, Ord)
+
+-- | The service type that our microservices proxy will handle. At the moment
+-- we support only the \"notes\" one.
+data ServiceType
+  = ST_notes
+  deriving Generic
+
+-- | Renders a 'ServiceType' into a string.
+renderServiceType :: ServiceType -> String
+renderServiceType ST_notes = "notes"
+
+serviceTypeToProxyPath :: ServiceType -> String
+serviceTypeToProxyPath ST_notes = "/notes"
+
+instance FromHttpApiData ServiceType where
+  parseUrlPiece "notes" = Right ST_notes
+  parseUrlPiece x       = Left x
+
+instance FromHttpApiData FrameId where
+  parseUrlPiece txt
+    | T.all isHexDigit txt = Right (FrameId txt)
+    | otherwise            = Left "Invalid FrameId: must be a hexadecimal string"
+
+newtype ProxyDestination =
+  ProxyDestination { _ProxyDestination :: BaseUrl }
+
+fwdHost :: ProxyDestination -> C8.ByteString
+fwdHost = C8.pack . baseUrlHost . _ProxyDestination
+
+fwdPort :: ProxyDestination -> Int
+fwdPort = baseUrlPort . _ProxyDestination
+
+--
+-- The API
+--
+
+data ReverseProxyAPI mode = ReverseProxyAPI
+  { -- | The proxy routes for the \"notes\" microservice (e.g. \"write.frame.gargantext.org\").
+    notesServiceProxy :: mode :- "notes" :> NamedRoutes NotesProxy
+
+   -- | proxy everything else. CAREFUL! This has to be the last route, as it will always match.
+  , proxyPassAll      :: mode :- Raw
+  } deriving Generic
+
+data NotesProxy mode = NotesProxy
+  { -- | Turn the notes into slides
+    slideEp     :: mode :- Capture "frameId" FrameId :> "slide" :> Raw
+
+  , publishEp   :: mode :- Capture "frameId" FrameId :> "publish" :> Raw
+
+  -- | 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
+
+  -- | Once the connection has been established, this is the websocket endpoint to
+  -- poll edits.
+  , notesSocket :: mode :- "socket.io" :> NamedRoutes SocketIOProxy
+
+  -- | Called during the websocket connection
+  , 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
+
+  -- | The generic routes serving the assets.
+  , notesStaticAssets :: mode :- Raw
+  } deriving Generic
+
+data SocketIOProxy mode = SocketIOProxy
+  { socketIoEp  :: mode :- QueryParam' '[Required] "noteId" FrameId :> Raw
+  } deriving Generic
+
+--
+-- The Server
+--
+
+microServicesProxyApp :: Env -> Application
+microServicesProxyApp env = genericServe (server env)
+
+server :: Env -> ReverseProxyAPI AsServer
+server env = ReverseProxyAPI {
+    notesServiceProxy = notesProxyImplementation env
+  , proxyPassAll      = proxyPassServer ST_notes env
+  }
+
+-- | A customised 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'
+
+window.allowedUploadMimeTypes = ["image/jpeg","image/png","image/jpg","image/gif","image/svg+xml"]
+
+window.DROPBOX_APP_KEY = ''
+|]
+
+notesProxyImplementation :: Env -> NotesProxy AsServer
+notesProxyImplementation env = NotesProxy {
+    slideEp     = \frameId  -> slideProxyServer env frameId
+  , publishEp   = \frameId  -> publishProxyServer env frameId
+  , configFile  = pure $ configJS (proxyUrl env) sty
+  , notesSocket = socketIOProxyImplementation sty env
+  , meEndpoint  = proxyPassServer sty env
+  , notesEp     = \_frameId  -> defaultForwardServer sty id env
+  , notesStaticAssets = proxyPassServer sty env
+  }
+  where
+    sty :: ServiceType
+    sty = ST_notes
+
+socketIOProxyImplementation :: ServiceType -> Env -> SocketIOProxy AsServer
+socketIOProxyImplementation sty env = SocketIOProxy {
+    socketIoEp = \_noteId -> defaultForwardServer sty id env
+  }
+
+removeServiceFromPath :: ServiceType -> Request -> Request
+removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty)
+  where
+    removeProxyPath :: T.Text -> Request -> Request
+    removeProxyPath pth originalRequest =
+      originalRequest { rawPathInfo = removePath pth (rawPathInfo originalRequest) }
+
+slideProxyServer :: Env -> FrameId -> ServerT Raw m
+slideProxyServer env (FrameId frameId) =
+  defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) 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
+  where
+    changePath :: ByteString -> ByteString
+    changePath _ = TE.encodeUtf8 $ "/s/" <> frameId
+
+-- Generic server forwarder
+proxyPassServer :: ServiceType -> Env -> ServerT Raw m
+proxyPassServer sty env = defaultForwardServer sty id env
+
+mkProxyDestination :: Env -> ProxyDestination
+mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do
+  baseUrl <- parseBaseUrl (T.unpack $ env ^. hasConfig . gc_frame_write_url)
+  pure $ ProxyDestination baseUrl
+
+--
+-- Combinators over the input Request
+--
+
+removeFromReferer :: T.Text -> Request -> Request
+removeFromReferer pth originalRequest =
+  originalRequest { requestHeaders = (Prelude.map tweakReferer (requestHeaders originalRequest))
+  }
+  where
+    tweakReferer :: Header -> Header
+    tweakReferer (k,v)
+      | k == hReferer
+      = (hReferer, removePath pth v)
+      | otherwise
+      = (k,v)
+
+proxyUrl :: Env -> BaseUrl
+proxyUrl env = mkProxyUrl (env ^. hasConfig) (env ^. env_settings . microservicesSettings)
+
+
+defaultForwardServer :: ServiceType
+                     -> (Request -> Request)
+                     -> Env
+                     -> ServerT Raw m
+defaultForwardServer sty presendModifyRequest env =
+  Tagged $ waiProxyToSettings forwardRequest (proxySettings) (env ^. env_manager)
+  where
+
+    proxyDestination :: ProxyDestination
+    proxyDestination = mkProxyDestination 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
+
+    setReferer :: RequestHeaders -> RequestHeaders
+    setReferer hdrs =
+        let hd = (hReferer, C8.pack (proxyUrlStr <> serviceTypeToProxyPath sty))
+        in hd : filter ((/=) hReferer . fst) hdrs
+
+    -- | Forwards the request by substituting back the proxied address into the actual one.
+    forwardRequest :: Request -> IO WaiProxyResponse
+    forwardRequest originalRequest = do
+      let proxiedReq = presendModifyRequest . removeServiceFromPath sty $ originalRequest {
+                         requestHeaders = (setReferer $ setHost proxyDestination $ noCache $ (requestHeaders originalRequest))
+                         }
+      pure $ WPRModifiedRequest proxiedReq (ProxyDest (fwdHost proxyDestination) (fwdPort proxyDestination))
+
+--
+-- Utility functions
+--
+
+noCache :: RequestHeaders -> RequestHeaders
+noCache hdrs = (hCacheControl, fromString "no-cache") : filter ((/=) hCacheControl . fst) hdrs
+
+-- | Tweak the response headers so that they will have a bit more permissive
+-- 'Content-Security-Policy'.
+tweakResponseHeaders :: ResponseHeaders -> ResponseHeaders
+tweakResponseHeaders = Prelude.map tweakHeader
+  where
+    tweakHeader (k,v)
+      | k == "Content-Security-Policy"
+      = (k, fromString "default-src *; style-src * 'unsafe-inline'; script-src * 'unsafe-inline' 'unsafe-eval'; img-src * data: 'unsafe-inline'; connect-src * 'unsafe-inline'; frame-src *;")
+      | otherwise
+      = (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
+  where
+    --  Replaces the relative links in the proxied page content with proper urls.
+    flushReplace :: B.ByteString -> Flush Builder
+    flushReplace = Chunk . byteString . replaceIt
+
+    replaceIt :: B.ByteString -> B.ByteString
+    replaceIt htmlBlob =
+      replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~ [re|src="\/build\/|href="\/build\/|src="\/config|src="\/js\/|]
+      where
+        makeAbsolute _ _loc cap = case capturedText cap of
+          "src=\"/build/"  -> Just $ "src=\"" <> assetPath <> "/build/"
+          "href=\"/build/" -> Just $ "href=\"" <> assetPath <> "/build/"
+          "src=\"/config"  -> Just $ "src=\"" <> assetPath <> "/config"
+          "src=\"/js/"     -> Just $ "src=\"" <> assetPath <> "/js/"
+          _                -> Just $ assetPath <> capturedText cap
+
+removePath :: T.Text -> ByteString -> ByteString
+removePath pth = TE.encodeUtf8 . T.replace pth "" . TE.decodeUtf8

stack.yaml

@@ -62,6 +62,10 @@
   git: "https://github.com/MercuryTechnologies/ekg-json.git"
   subdirs:
   - .
+- commit: c90b7bc55b0e628d0b71ccee4e222833a19792f8
+  git: "https://github.com/adinapoli/http-reverse-proxy.git"
+  subdirs:
+  - .
 - commit: 7533a9ccd3bfe77141745f6b61039a26aaf5c83b
   git: "https://github.com/adinapoli/llvm-hs.git"
   subdirs:
@@ -308,7 +312,11 @@ flags:
   "full-text-search":
     "build-search-demo": false
   gargantext:
+<<<<<<< HEAD
     "no-phylo-debug-logs": false
+=======
+    "no-phylo-debug-logs": true
+>>>>>>> origin/adinapoli/issue-352
     "test-crypto": false
   "ghc-lib-parser":
     "threaded-rts": true

test/Test/Database/Setup.hs

@@ -15,6 +15,7 @@ import Database.PostgreSQL.Simple.Options qualified as Client
 import Database.PostgreSQL.Simple.Options qualified as Opts
 import Database.Postgres.Temp qualified as Tmp
 import Gargantext.API.Admin.EnvTypes (Mode(Mock))
+import Gargantext.API.Admin.Settings
 import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config
@@ -73,12 +74,15 @@ setup = do
       bootstrapDB db pool gargConfig
       ugen <- emptyCounter
       test_nodeStory <- fromDBNodeStoryEnv pool
+      stgs <- devSettings devJwkFile
       withLoggerHoisted Mock $ \logger -> do
         pure $ TestEnv { test_db = DBHandle pool db
                        , test_config = gargConfig
                        , test_nodeStory
                        , test_usernameGen = ugen
-                       , test_logger = logger }
+                       , test_logger = logger
+                       , test_settings = stgs
+                       }
 
 withTestDB :: (TestEnv -> IO ()) -> IO ()
 withTestDB = bracket setup teardown

test/Test/Database/Types.hs

@@ -28,6 +28,7 @@ import Database.Postgres.Temp qualified as Tmp
 import Gargantext hiding (to)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Admin.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.Mail.Types (HasMail(..))
@@ -61,6 +62,7 @@ data TestEnv = TestEnv {
   , test_nodeStory           :: !NodeStoryEnv
   , test_usernameGen         :: !Counter
   , test_logger              :: !(Logger (GargM TestEnv BackendInternalError))
+  , test_settings            :: !Settings
   }
 
 newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
@@ -104,6 +106,9 @@ instance HasConnectionPool TestEnv where
 instance HasConfig TestEnv where
   hasConfig = to test_config
 
+instance HasSettings TestEnv where
+  settings = to test_settings
+
 instance HasMail TestEnv where
   mailSettings = to $ const (MailConfig { _mc_mail_host       = "localhost"
                                         , _mc_mail_port       = 25