Guard the reverse proxy under the classic Garg Authentication scheme

While doing this, I have also fixed a bug in the current implementation
of ThrowAll (formerly named `throwAll'`).

bin/gargantext-cli/CLI/Admin.hs

@@ -4,6 +4,7 @@ module CLI.Admin (
   , adminCmd
   ) where
 
+import CLI.Parsers
 import CLI.Types
 import Data.List.NonEmpty qualified as NE
 import Data.Text qualified as T
@@ -18,8 +19,8 @@ import Options.Applicative
 import Prelude (String)
 
 adminCLI :: AdminArgs -> IO ()
-adminCLI (AdminArgs iniPath mails) = do
-  withDevEnv iniPath $ \env -> do
+adminCLI (AdminArgs iniPath settingsPath mails) = do
+  withDevEnv iniPath settingsPath $ \env -> do
     x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId))
     putStrLn (show x :: Text)
 
@@ -28,10 +29,7 @@ adminCmd = command "admin" (info (helper <*> fmap CLISub admin_p) (progDesc "Cre
 
 admin_p :: Parser CLICmd
 admin_p = fmap CCMD_admin $ AdminArgs
-  <$> ( strOption ( long "ini-path"
-                    <> metavar "FILEPATH"
-                    <> help "Location of the .ini path"
-                    ) )
+  <$> ini_p <*> settings_p
   <*> ( option (maybeReader emails_p) ( long "emails"
                       <> metavar "email1,email2,..."
                       <> help "A comma-separated list of emails."

bin/gargantext-cli/CLI/Import.hs

@@ -18,6 +18,7 @@ Import a corpus binary.
 
 module CLI.Import where
 
+import CLI.Parsers
 import CLI.Types
 import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
 import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
@@ -26,6 +27,7 @@ import Gargantext.API.Node () -- instances
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
 import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Core.Types.Query
 import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
@@ -33,13 +35,12 @@ import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpu
 import Gargantext.Prelude
 import Gargantext.Utils.Jobs.Monad ( MonadJobStatus, JobHandle )
 import Options.Applicative
-import qualified Data.Text as T
 import Prelude (String)
-import Gargantext.Core.Types.Query
+import qualified Data.Text as T
 
 
 importCLI :: ImportArgs -> IO ()
-importCLI (ImportArgs fun user name iniPath limit corpusPath) = do
+importCLI (ImportArgs fun user name iniPath settingsPath limit corpusPath) = do
   let
     tt     = Multi EN
     format = TsvGargV3
@@ -53,7 +54,7 @@ importCLI (ImportArgs fun user name iniPath limit corpusPath) = do
     annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
     annuaire = flowAnnuaire (MkCorpusUserNormalCorpusName (UserName $ cs user) "Annuaire") (Multi EN) corpusPath DevJobHandle
 
-  withDevEnv iniPath $ \env -> do
+  withDevEnv iniPath settingsPath $ \env -> do
     void $ case fun of
       IF_corpus
         -> runCmdGargDev env corpus
@@ -75,8 +76,9 @@ import_p = fmap CCMD_import $ ImportArgs
                     ) )
   <*> ( option str ( long "user") )
   <*> ( option str ( long "name") )
-  <*> ( option str ( long "ini" <> help "Path to the .ini file.") )
-  <*> (fmap Limit ( option auto ( long "ini" <> metavar "INT" <> help "The limit for the query") ))
+  <*> ini_p
+  <*> settings_p
+  <*> (fmap Limit ( option auto ( long "limit" <> metavar "INT" <> help "The limit for the query") ))
   <*> ( option str ( long "corpus-path" <> help "Path to corpus file") )
 
 function_p :: String -> Either String ImportFunction

bin/gargantext-cli/CLI/Init.hs

@@ -15,36 +15,38 @@ Initialise the Gargantext dataset.
 
 module CLI.Init where
 
+import CLI.Parsers
+import CLI.Types
 import Data.List.NonEmpty qualified as NE
+import Gargantext.API.Admin.Settings
+import Gargantext.API.Admin.Types
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Errors.Types
 import Gargantext.API.Node () -- instances only
+import Gargantext.Core.Config (GargConfig(..), readConfig)
 import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
 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 (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.Core.Config (GargConfig(..), readConfig)
-import Gargantext.API.Admin.Types
-import Gargantext.Database.Prelude (DBCmd')
-import CLI.Types
 import Options.Applicative
 
 
 initCLI :: InitArgs -> IO ()
-initCLI (InitArgs iniPath) = do
+initCLI (InitArgs iniPath settingsPath) = do
   putStrLn ("Enter master user (gargantua) _password_ :" :: Text)
   password  <- getLine
 
   putStrLn ("Enter master user (gargantua) _email_ :" :: Text)
   email     <- getLine
 
-  cfg       <- readConfig         iniPath
+  cfg       <- readConfig         (_IniFile iniPath)
   let secret = _gc_secretkey cfg
 
   let createUsers :: forall env. HasSettings env => DBCmd' env BackendInternalError Int64
@@ -67,7 +69,7 @@ initCLI (InitArgs iniPath) = do
       _triggers    <- initLastTriggers masterListId
       pure (masterUserId, masterRootId, masterCorpusId, masterListId)
 
-  withDevEnv iniPath $ \env -> do
+  withDevEnv iniPath settingsPath $ \env -> do
     _ <- runCmdDev env (initFirstTriggers secret :: DBCmd BackendInternalError [Int64])
     _ <- runCmdDev env createUsers
     x <- runCmdDev env initMaster
@@ -79,7 +81,4 @@ initCmd = command "init" (info (helper <*> fmap CLISub init_p) (progDesc "Initia
 
 init_p :: Parser CLICmd
 init_p = fmap CCMD_init $ InitArgs
-  <$> ( strOption ( long "ini-path"
-                    <> metavar "FILEPATH"
-                    <> help "Location of the .ini path"
-                    ) )
+  <$> ini_p <*> settings_p

bin/gargantext-cli/CLI/Invitations.hs

@@ -14,30 +14,32 @@ Portability : POSIX
 
 module CLI.Invitations where
 
+import CLI.Parsers
 import CLI.Types
+import Gargantext.API.Admin.Settings
 import Gargantext.API.Admin.Types
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Errors.Types
 import Gargantext.API.Node () -- instances only
 import Gargantext.API.Node.Share qualified as Share
 import Gargantext.API.Node.Share.Types qualified as Share
+import Gargantext.Core.Config (readConfig)
 import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Core.Types
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Prelude (CmdRandom)
 import Gargantext.Prelude
-import Gargantext.Core.Config (readConfig)
 import Options.Applicative
 import Prelude (String)
-import Gargantext.Core.Types
 
 invitationsCLI :: InvitationsArgs -> IO ()
-invitationsCLI (InvitationsArgs iniPath user node_id email) = do
-  _cfg       <- readConfig         iniPath
+invitationsCLI (InvitationsArgs iniPath settingsPath user node_id email) = do
+  _cfg       <- readConfig         (_IniFile iniPath)
 
   let invite :: (HasSettings env, CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
       invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
 
-  withDevEnv iniPath $ \env -> do
+  withDevEnv iniPath settingsPath $ \env -> do
     void $ runCmdDev env invite
 
 invitationsCmd :: HasCallStack => Mod CommandFields CLI
@@ -45,10 +47,8 @@ invitationsCmd = command "invitations" (info (helper <*> fmap CLISub invitations
 
 invitations_p :: Parser CLICmd
 invitations_p = fmap CCMD_invitations $ InvitationsArgs
-  <$> ( strOption ( long "ini-path"
-                    <> metavar "FILEPATH"
-                    <> help "Location of the .ini path"
-                    ) )
+  <$> ini_p
+  <*> settings_p
   <*> ( strOption ( long "user" ) )
   <*> ( option (eitherReader node_p)  ( long "node-id" <> metavar "POSITIVE-INT" <> help "The node ID.") )
   <*> ( strOption ( long "email" <> help "The email address.") )

bin/gargantext-cli/CLI/Parsers.hs

+
+{-| Common parsers for the CLI. -}
+
+module CLI.Parsers where
+
+import Prelude
+import Gargantext.API.Admin.Settings
+import Options.Applicative
+
+ini_p :: Parser IniFile
+ini_p = maybe (IniFile "gargantext.ini") IniFile <$>
+  optional ( strOption ( long "ini-path"
+                    <> metavar "FILEPATH"
+                    <> help "Location of the .ini file"
+                    ) )
+
+settings_p :: Parser SettingsFile
+settings_p = maybe (SettingsFile "gargantext-settings.toml") SettingsFile <$>
+  optional ( strOption ( long "settings-path"
+                    <> metavar "FILEPATH"
+                    <> help "Location of the gargantext-settings toml file"
+                    ) )

bin/gargantext-cli/CLI/Types.hs

@@ -3,9 +3,10 @@ module CLI.Types where
 
 import Data.String
 import Data.Text (Text)
+import Gargantext.API.Admin.Settings
+import Gargantext.Core.Types (NodeId)
 import Gargantext.Core.Types.Query
 import Prelude
-import Gargantext.Core.Types (NodeId)
 
 newtype CorpusFile = CorpusFile { _CorpusFile :: FilePath }
   deriving (Show, Eq, IsString)
@@ -25,8 +26,9 @@ data ObfuscateDBArgs = ObfuscateDBArgs {
   } deriving (Show, Eq)
 
 data AdminArgs = AdminArgs
-  { iniPath :: !FilePath
-  , emails  :: [String]
+  { iniPath      :: !IniFile
+  , settingsPath :: !SettingsFile
+  , emails       :: [String]
   } deriving (Show, Eq)
 
 data ImportFunction
@@ -39,17 +41,20 @@ data ImportArgs = ImportArgs
   { imp_function :: !ImportFunction
   , imp_user     :: !Text
   , imp_name     :: !Text
-  , imp_ini      :: !FilePath
+  , imp_ini      :: !IniFile
+  , imp_settings :: !SettingsFile
   , imp_limit    :: !Limit
   , imp_corpus_path :: !FilePath
   } deriving (Show, Eq)
 
 data InitArgs = InitArgs
-  { init_ini :: !FilePath
+  { init_ini      :: !IniFile
+  , init_settings :: !SettingsFile
   } deriving (Show, Eq)
 
 data InvitationsArgs = InvitationsArgs
-  { inv_path    :: !FilePath
+  { inv_path    :: !IniFile
+  , inv_settings :: !SettingsFile
   , inv_user    :: !Text
   , inv_node_id :: !NodeId
   , inv_email   :: !Text
@@ -60,7 +65,8 @@ data PhyloArgs = PhyloArgs
   } deriving (Show, Eq)
 
 data UpgradeArgs = UpgradeArgs
-  { upgrade_ini :: !FilePath
+  { upgrade_ini      :: !IniFile
+  , upgrade_settings :: !SettingsFile
   } deriving (Show, Eq)
 
 data GoldenFileDiffArgs = GoldenFileDiffArgs

bin/gargantext-cli/CLI/Upgrade.hs

@@ -17,16 +17,18 @@ Upgrade a gargantext node.
 module CLI.Upgrade where
 
 import CLI.Types
+import CLI.Parsers
 import Data.List qualified as List (cycle, concat, take, unlines)
+import Gargantext.API.Admin.Settings
 import Gargantext.API.Dev (withDevEnv)
 import Gargantext.API.Node () -- instances only
-import Gargantext.Prelude
 import Gargantext.Core.Config (GargConfig(..), readConfig)
-import Prelude qualified
+import Gargantext.Prelude
 import Options.Applicative
+import Prelude qualified
 
 upgradeCLI :: UpgradeArgs -> IO ()
-upgradeCLI (UpgradeArgs iniPath) = do
+upgradeCLI (UpgradeArgs iniPath settingsFile) = do
 
   let ___ = putStrLn ((List.concat
                        $ List.take 72
@@ -45,10 +47,10 @@ upgradeCLI (UpgradeArgs iniPath) = do
 
   _ok  <- getLine
 
-  cfg       <- readConfig         iniPath
+  cfg       <- readConfig (_IniFile iniPath)
   let _secret = _gc_secretkey cfg
 
-  withDevEnv iniPath $ \_env -> do
+  withDevEnv iniPath settingsFile $ \_env -> do
     -- _ <- runCmdDev env addIndex
     -- _ <- runCmdDev env refreshIndex
 
@@ -95,7 +97,5 @@ upgradeCmd = command "upgrade" (info (helper <*> fmap CLISub upgrade_p) (progDes
 
 upgrade_p :: Parser CLICmd
 upgrade_p = fmap CCMD_upgrade $ UpgradeArgs
-  <$> ( strOption ( long "ini-path"
-                    <> metavar "FILEPATH"
-                    <> help "Location of the .ini path"
-                    ) )
+  <$> ini_p
+  <*> settings_p

bin/gargantext-server/Main.hs

@@ -24,12 +24,14 @@ module Main where
 
 import Data.Text (unpack)
 import Data.Version (showVersion)
+import GHC.IO.Encoding
 import Gargantext.API (startGargantext) -- , startGargantextMock)
 import Gargantext.API.Admin.EnvTypes
+import Gargantext.API.Admin.Settings
 import Gargantext.Prelude
 import Gargantext.System.Logging
-import GHC.IO.Encoding
 import Options.Generic
+import Prelude (String)
 import System.Exit (exitSuccess)
 import qualified Paths_gargantext as PG -- cabal magic build module
 
@@ -45,6 +47,8 @@ data MyOptions w =
                         <?> "By default: 8008"
             , ini  :: w ::: Maybe Text
                         <?> "Ini-file path of gargantext.ini"
+            , settings :: w ::: Maybe String
+                        <?> "By default: gargantext-settings.toml"
             , version :: w ::: Bool
                         <?> "Show version number and exit"
             }
@@ -60,7 +64,7 @@ main = withLogger () $ \ioLogger -> do
   setLocaleEncoding utf8
   currentLocale <- getLocaleEncoding
 
-  MyOptions myMode myPort myIniFile myVersion  <- unwrapRecord
+  MyOptions myMode myPort myIniFile mb_settingsFile myVersion  <- unwrapRecord
           "Gargantext server"
   ---------------------------------------------------------------
   if myVersion then do
@@ -75,12 +79,16 @@ main = withLogger () $ \ioLogger -> do
 
       myIniFile' = case myIniFile of
           Nothing -> panicTrace "[ERROR] gargantext.ini needed"
+          Just i  -> IniFile $ unpack i
+
+      settingsFile = SettingsFile $ case mb_settingsFile of
+          Nothing -> "gargantext-settings.toml"
           Just i  -> i
 
   ---------------------------------------------------------------
   let start = case myMode of
         Mock -> panicTrace "[ERROR] Mock mode unsupported"
-        _ -> startGargantext myMode myPort' (unpack myIniFile')
+        _ -> startGargantext myMode myPort' myIniFile' settingsFile
   logMsg ioLogger INFO $ "Starting with "   <> show myMode <> " mode."
   logMsg ioLogger INFO $ "Machine locale: " <> show currentLocale
   start

gargantext.cabal

@@ -49,6 +49,7 @@ data-files:
     test-data/phylo/phylo2dot2json.golden.json
     test-data/stemming/lancaster.txt
     test-data/test_config.ini
+    test-data/gargantext-settings.toml
     gargantext-settings.toml
     .clippy.dhall
 
@@ -712,6 +713,7 @@ executable gargantext-cli
       CLI.Init
       CLI.Invitations
       CLI.ObfuscateDB
+      CLI.Parsers
       CLI.Phylo
       CLI.Phylo.Common
       CLI.Phylo.Profile
@@ -807,6 +809,7 @@ test-suite garg-test-tasty
       Test.Parsers.Date
       Test.Parsers.Types
       Test.Parsers.WOS
+      Test.Server.ReverseProxy
       Test.Types
       Test.Utils
       Test.Utils.Crypto
@@ -868,6 +871,7 @@ test-suite garg-test-tasty
     , servant-server
     , shelly >= 1.9 && < 2
     , stm ^>= 2.5.0.1
+    , streaming-commons
     , split
     , tasty ^>= 1.4.2.1
     , tasty-golden
@@ -882,6 +886,7 @@ test-suite garg-test-tasty
     , tree-diff
     , unordered-containers ^>= 0.2.16.0
     , unicode-collation >= 0.1.3.6
+    , unliftio
     , validity ^>= 0.11.0.1
     , vector ^>= 0.12.3.0
     , wai
@@ -894,6 +899,7 @@ test-suite garg-test-hspec
   type: exitcode-stdio-1.0
   main-is: drivers/hspec/Main.hs
   other-modules:
+      Paths_gargantext
       Test.API
       Test.API.Authentication
       Test.API.Errors
@@ -907,9 +913,9 @@ test-suite garg-test-hspec
       Test.Database.Operations.NodeStory
       Test.Database.Setup
       Test.Database.Types
-      Test.Utils
+      Test.Server.ReverseProxy
       Test.Types
-      Paths_gargantext
+      Test.Utils
   hs-source-dirs:
       test
   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
@@ -960,6 +966,7 @@ test-suite garg-test-hspec
     , servant-server
     , shelly >= 1.9 && < 2
     , stm ^>= 2.5.0.1
+    , streaming-commons
     , tasty ^>= 1.4.2.1
     , tasty-hspec
     , tasty-hunit
@@ -970,6 +977,7 @@ test-suite garg-test-hspec
     , 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

src/Gargantext/API.hs

@@ -44,7 +44,7 @@ import Data.Text.IO (putStrLn)
 import Data.Validity
 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 (newEnv, IniFile(..), SettingsFile)
 import Gargantext.API.Admin.Settings.CORS
 import Gargantext.API.Admin.Settings.MicroServices
 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microservicesSettings)
@@ -68,9 +68,9 @@ import System.Cron.Schedule qualified as Cron
 import System.FilePath
 
 -- | startGargantext takes as parameters port number and Ini file.
-startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
-startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
-  env <- newEnv logger port file
+startGargantext :: Mode -> PortNumber -> IniFile -> SettingsFile -> IO ()
+startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logger -> do
+  env <- newEnv logger port iniFile settingsFile
   let proxyPort = env ^. settings.microservicesSettings.msProxyPort
   runDbCheck env
   portRouteInfo port proxyPort
@@ -89,7 +89,7 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
           case r of
             Right True -> pure ()
             _ -> panicTrace $
-              "You must run 'gargantext-init " <> pack file <>
+              "You must run 'gargantext-init " <> pack (_IniFile iniFile) <>
               "' before running gargantext-server (only the first time)."
 
 portRouteInfo :: PortNumber -> PortNumber -> IO ()

src/Gargantext/API/Admin/Settings.hs

@@ -52,12 +52,21 @@ import System.IO (hClose)
 import System.IO.Temp (withTempFile)
 import qualified Data.Pool as Pool
 
-devSettings :: FilePath -> IO Settings
-devSettings jwkFile = do
+newtype JwkFile = JwkFile { _JwkFile :: FilePath }
+  deriving (Show, Eq, IsString)
+
+newtype SettingsFile = SettingsFile { _SettingsFile :: FilePath }
+  deriving (Show, Eq, IsString)
+
+newtype IniFile  = IniFile { _IniFile :: FilePath }
+  deriving (Show, Eq, IsString)
+
+devSettings :: JwkFile -> SettingsFile -> IO Settings
+devSettings (JwkFile jwkFile) (SettingsFile settingsFile) = do
   jwkExists <- doesFileExist jwkFile
   when (not jwkExists) $ writeKey jwkFile
   jwk       <- readKey jwkFile
-  GargTomlSettings{..} <- loadGargTomlSettings
+  GargTomlSettings{..} <- loadGargTomlSettings settingsFile
   pure $ Settings
     { _corsSettings = _gargCorsSettings
     , _microservicesSettings = _gargMicroServicesSettings
@@ -171,13 +180,13 @@ readRepoEnv repoDir = do
   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 --}
 
-devJwkFile :: FilePath
-devJwkFile = "dev.jwk"
+devJwkFile :: JwkFile
+devJwkFile = JwkFile "dev.jwk"
 
-newEnv :: Logger (GargM Env BackendInternalError) -> PortNumber -> FilePath -> IO Env
-newEnv logger port file = do
+newEnv :: Logger (GargM Env BackendInternalError) -> PortNumber -> IniFile -> SettingsFile -> IO Env
+newEnv logger port (IniFile file) settingsFile = do
   !manager_env  <- newTlsManager
-  !settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
+  !settings'    <- devSettings devJwkFile settingsFile <&> appPort .~ port -- TODO read from 'file'
   when (port /= settings' ^. appPort) $
     panicTrace "TODO: conflicting settings of port"
 

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

@@ -7,7 +7,6 @@ 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
@@ -40,9 +39,8 @@ addProxyToAllowedOrigins stgs =
       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"
+loadGargTomlSettings :: FilePath -> IO GargTomlSettings
+loadGargTomlSettings tomlFile = do
   tomlRes <- Toml.decodeFileEither settingsCodec tomlFile
   case tomlRes of
       Left errs      -> do

src/Gargantext/API/Dev.hs

@@ -17,7 +17,7 @@ import Control.Monad (fail)
 import Data.Pool (withResource)
 import Database.PostgreSQL.Simple qualified as PGS
 import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
-import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool )
+import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool, SettingsFile (..), IniFile (..) )
 import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Prelude ( GargM )
 import Gargantext.Core.NLP (nlpServerMap)
@@ -30,10 +30,9 @@ import Gargantext.Core.Config.NLP qualified as NLP
 import Gargantext.System.Logging ( withLoggerHoisted )
 import Servant ( ServerError )
 
-type IniPath  = FilePath
 -------------------------------------------------------------------
-withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
-withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
+withDevEnv :: IniFile -> SettingsFile -> (DevEnv -> IO a) -> IO a
+withDevEnv (IniFile iniPath) settingsFile k = withLoggerHoisted Dev $ \logger -> do
   env <- newDevEnv logger
   k env -- `finally` cleanEnv env
 
@@ -44,7 +43,7 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
       --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
       pool    <- newPool            dbParam
       nodeStory_env <- fromDBNodeStoryEnv pool
-      setts   <- devSettings devJwkFile
+      setts   <- devSettings devJwkFile settingsFile
       mail    <- Mail.readConfig iniPath
       nlp_config <- NLP.readConfig iniPath
       pure $ DevEnv
@@ -57,9 +56,15 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
         , _dev_env_nlp      = nlpServerMap nlp_config
         }
 
+defaultIniFile :: IniFile
+defaultIniFile = IniFile "gargantext.ini"
+
+defaultSettingsFile :: SettingsFile
+defaultSettingsFile = SettingsFile "gargantext-settings.toml"
+
 -- | Run Cmd Sugar for the Repl (GHCI)
 runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a
-runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
+runCmdRepl f = withDevEnv defaultIniFile defaultSettingsFile $ \env -> runCmdDev env f
 
 runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a
 runCmdReplServantErr = runCmdRepl
@@ -83,7 +88,7 @@ runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
 runCmdDevServantErr = runCmdDev
 
 runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a
-runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
+runCmdReplEasy f = withDevEnv defaultIniFile defaultSettingsFile $ \env -> runCmdDev env f
 
 -- | Execute a function that takes PSQL.Connection from the DB pool as
 --   first parameter.

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

@@ -13,13 +13,11 @@ 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
@@ -98,12 +96,6 @@ 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/ThrowAll.hs

@@ -9,19 +9,22 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE KindSignatures         #-}
 {-# LANGUAGE LambdaCase             #-}
 {-# LANGUAGE MonoLocalBinds         #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE PolyKinds #-}
 
-module Gargantext.API.ThrowAll where
+module Gargantext.API.ThrowAll (
+    throwAllRoutes
+  , serverPrivateGargAPI
+  ) where
 
 import Control.Lens ((#))
+import Data.ByteString.Char8 qualified as C8
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types
@@ -29,31 +32,60 @@ import Gargantext.API.Prelude
 import Gargantext.API.Routes.Named.Private qualified as Named
 import Gargantext.API.Server.Named.Private qualified as Named
 import Gargantext.Database.Admin.Types.Node (UserId (..))
-import Gargantext.Prelude
+import Gargantext.Prelude hiding (Handler)
+import Network.HTTP.Types.Status (Status(..))
+import Network.Wai (responseLBS)
 import Servant
+import Servant.API.Generic ()
 import Servant.Auth.Server (AuthResult(..))
 import Servant.Server.Generic (AsServerT)
-import Servant.API.Generic ()
 
+-- | Slightly more general version of the 'ThrowAll' typeclass from Servant,
+-- that works on a generic error.
+class ThrowAll' e a where
+  throwAll' :: e -> a -> a
+
+instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
+  throwAll' e (s1 :<|> s2) = throwAll' e s1 :<|> throwAll' e s2
+
+instance ThrowAll' e b => ThrowAll' e (a -> b) where
+  throwAll' e f = \x -> throwAll' e (f x)
 
-throwAll' :: forall err m routes. ( MonadError err m
-         , HasServerError err
+instance ( MonadError e m
+         , GenericServant routes (AsServerT m)
          , HasServer (NamedRoutes routes) '[]
          , Generic (routes (AsServerT m))
-         ) => err
-           -> routes (AsServerT m)
-           -> routes (AsServerT m)
-throwAll' errCode server =
-  hoistServer (Proxy @(NamedRoutes routes)) f server
-  where
-    f :: forall a. m a -> m a
-    f = const (throwError errCode)
+         ) => ThrowAll' e (routes (AsServerT m)) where
+  throwAll' errCode server = hoistServer (Proxy @(NamedRoutes routes)) f server
+    where
+      f :: forall a. m a -> m a
+      f = const (throwError errCode)
+
+-- Common instances
+
+instance (ThrowAll' ServerError (Handler a)) where
+  throwAll' e _ = throwError e
+instance (ThrowAll' ServerError (Tagged Handler Application)) where
+  throwAll' ServerError{..} (Tagged _) =
+    Tagged $ \_ mkResponse -> mkResponse (responseLBS (Status errHTTPCode (C8.pack errReasonPhrase)) errHeaders errBody)
+
+
+throwAllRoutes :: ( MonadError e m
+            , Generic (routes (AsServerT m))
+            , GenericServant routes (AsServerT m)
+            , ThrowAll' e (routes (AsServerT m))
+            , ThrowAll' e (ToServant routes (AsServerT m))
+            )
+         => e
+         -> routes (AsServerT m)
+         -> routes (AsServerT m)
+throwAllRoutes err = fromServant . throwAll' err . toServant
 
 serverPrivateGargAPI :: Named.GargPrivateAPI (AsServerT (GargM Env BackendInternalError))
 serverPrivateGargAPI = Named.GargPrivateAPI $ \case
   (Authenticated auser) -> Named.serverPrivateGargAPI' auser
   -- In the code below we just needed a mock 'AuthenticatedUser' to make the type check, but
   -- they will never be evaluated.
-  _                     -> throwAll' (_ServerError # err401)
+  _                     -> throwAllRoutes (_ServerError # err401)
                              $ Named.serverPrivateGargAPI' (AuthenticatedUser 0 (UnsafeMkUserId 0))
 -- Here throwAll' requires a concrete type for the monad.

src/Gargantext/MicroServices/ReverseProxy.hs

@@ -3,12 +3,19 @@
 {-# LANGUAGE QuasiQuotes        #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Gargantext.MicroServices.ReverseProxy (
   microServicesProxyApp
 
   -- * Internals
   , removeFromReferer
+  , ReverseProxyAPI(..)
+  , NotesProxy(..)
+  , FrameId(..)
   ) where
 
 import Prelude
@@ -25,21 +32,34 @@ import GHC.Generics
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Settings.MicroServices
 import Gargantext.API.Admin.Types
+import Gargantext.API.Routes.Named.Private
+import Gargantext.API.ThrowAll (throwAllRoutes)
 import Gargantext.API.Types (HTML)
-import Gargantext.Database.Prelude (hasConfig)
-import Gargantext.Prelude
 import Gargantext.Core.Config (gc_frame_write_url)
+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.Wai (Request, rawPathInfo, requestHeaders)
 import Servant hiding (Header)
+import Servant.Auth.Server
 import Servant.Auth.Swagger ()
 import Servant.Client.Core.BaseUrl
 import Servant.Server.Generic
 import Text.RE.Replace hiding (Capture)
 import Text.RE.TDFA.ByteString
 import Text.RawString.QQ (r)
+import Gargantext.API.Admin.Auth.Types (AuthContext)
+import Servant.Auth.Server.Internal.AddSetCookie
+import Network.Wai
+
+-- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
+instance {-# OVERLAPPING #-}
+  ( AddSetCookies ('S n) a a
+  , AddSetCookies ('S n) b b'
+  )
+  => AddSetCookies ('S n) (a :<|> b) (a :<|> b') where
+  addSetCookies cookies ( a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
 
 --
 -- Types
@@ -48,6 +68,9 @@ import Text.RawString.QQ (r)
 newtype FrameId = FrameId { _FrameId :: T.Text }
   deriving (Show, Eq, Ord)
 
+instance ToHttpApiData FrameId where
+  toUrlPiece = toUrlPiece . _FrameId
+
 -- | The service type that our microservices proxy will handle. At the moment
 -- we support only the \"notes\" one.
 data ServiceType
@@ -85,7 +108,7 @@ fwdPort = baseUrlPort . _ProxyDestination
 
 data ReverseProxyAPI mode = ReverseProxyAPI
   { -- | The proxy routes for the \"notes\" microservice (e.g. \"write.frame.gargantext.org\").
-    notesServiceProxy :: mode :- "notes" :> NamedRoutes NotesProxy
+    notesServiceProxy :: mode :- "notes" :> MkProtectedAPI (NamedRoutes NotesProxy)
 
    -- | proxy everything else. CAREFUL! This has to be the last route, as it will always match.
   , proxyPassAll      :: mode :- Raw
@@ -124,13 +147,20 @@ data SocketIOProxy mode = SocketIOProxy
 --
 
 microServicesProxyApp :: Env -> Application
-microServicesProxyApp env = genericServe (server env)
+microServicesProxyApp env = genericServeTWithContext id (server env) cfg
+  where
+    cfg :: Context AuthContext
+    cfg = env ^. settings . jwtSettings
+       :. env ^. settings . cookieSettings
+       :. EmptyContext
 
-server :: Env -> ReverseProxyAPI AsServer
+server :: Env -> ReverseProxyAPI (AsServerT Handler)
 server env = ReverseProxyAPI {
-    notesServiceProxy = notesProxyImplementation env
-  , proxyPassAll      = proxyPassServer ST_notes env
-  }
+    notesServiceProxy = \case
+      (Authenticated _autUser) -> notesProxyImplementation env
+      _ -> throwAllRoutes err401 $ 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

stack.yaml

@@ -312,7 +312,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-data/gargantext-settings.toml

+
+[cors]
+
+allowed-origins = [
+    "https://demo.gargantext.org"
+  , "https://formation.gargantext.org"
+  , "https://academia.sub.gargantext.org"
+  , "https://cnrs.gargantext.org"
+  , "https://imt.sub.gargantext.org"
+  , "https://helloword.gargantext.org"
+  , "https://complexsystems.gargantext.org"
+  , "https://europa.gargantext.org"
+  , "https://earth.sub.gargantext.org"
+  , "https://health.sub.gargantext.org"
+  , "https://msh.sub.gargantext.org"
+  , "https://dev.sub.gargantext.org"
+  , "http://localhost:8008"
+  ]
+
+use-origins-for-hosts = true
+
+[microservices]
+
+proxy-port = 8009

test/Test/API/Routes.hs

@@ -25,7 +25,7 @@ import Gargantext.API.Routes.Named.Node
 import qualified Servant.Auth.Client as S
 import qualified Data.Text.Encoding as TE
 
--- This is for requests made by http.client directly to hand-crafted URLs    
+-- This is for requests made by http.client directly to hand-crafted URLs
 curApi :: Builder
 curApi = "v1.0"
 
@@ -39,7 +39,6 @@ mkUrl _port urlPiece =
 clientRoutes :: API (AsClientT ClientM)
 clientRoutes = genericClient
 
-
 -- This is for Servant.Client requests
 auth_api :: AuthRequest -> ClientM AuthResponse
 auth_api = clientRoutes & apiWithCustomErrorScheme

test/Test/API/Setup.hs

@@ -3,7 +3,8 @@
 
 module Test.API.Setup where
 
--- import Gargantext.Prelude (printDebug)
+import Control.Concurrent.Async qualified as Async
+import Control.Concurrent.MVar
 import Control.Lens
 import Control.Monad.Reader
 import Gargantext.API (makeApp)
@@ -12,6 +13,9 @@ import Gargantext.API.Admin.Settings
 import Gargantext.API.Admin.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
+import Gargantext.Core.Config
+import Gargantext.Core.Config.Mail qualified as Mail
+import Gargantext.Core.Config.NLP qualified as NLP
 import Gargantext.Core.NLP
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Types.Individu
@@ -23,9 +27,7 @@ import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
-import Gargantext.Core.Config
-import Gargantext.Core.Config.Mail qualified as Mail
-import Gargantext.Core.Config.NLP qualified as NLP
+import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
 import Gargantext.System.Logging
 import Gargantext.Utils.Jobs qualified as Jobs
 import Gargantext.Utils.Jobs.Monad qualified as Jobs
@@ -33,20 +35,25 @@ import Gargantext.Utils.Jobs.Queue qualified as Jobs
 import Gargantext.Utils.Jobs.Settings qualified as Jobs
 import Network.HTTP.Client.TLS (newTlsManager)
 import Network.Wai (Application)
+import Network.Wai.Handler.Warp (runSettingsSocket)
 import Network.Wai.Handler.Warp qualified as Warp
+import Network.Wai.Handler.Warp.Internal
 import Prelude
 import Servant.Auth.Client ()
 import Servant.Client
 import Servant.Job.Async qualified as ServantAsync
-import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo)
+import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo, fakeSettingsPath)
 import Test.Database.Types
+import qualified UnliftIO
+import Data.Streaming.Network (bindPortTCP)
 
 
 newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
 newTestEnv testEnv logger port = do
   file          <- fakeIniPath
+  settingsP     <- SettingsFile <$> fakeSettingsPath
   !manager_env  <- newTlsManager
-  !settings'    <- devSettings devJwkFile <&> appPort .~ port
+  !settings'    <- devSettings devJwkFile settingsP <&> appPort .~ port
 
   !config_env    <- readConfig file
   prios          <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (file <> ".jobs")
@@ -80,18 +87,33 @@ newTestEnv testEnv logger port = do
     , _env_nlp       = nlp_env
     }
 
-withGargApp :: Application -> (Warp.Port -> IO ()) -> IO ()
-withGargApp app action = do
-  Warp.testWithApplication (pure app) action
-
+-- | Run the gargantext server on a random port, picked by Warp, which allows
+-- for concurrent tests to be executed in parallel, if we need to.
 withTestDBAndPort :: (((TestEnv, Warp.Port), Application) -> IO ()) -> IO ()
 withTestDBAndPort action =
   withTestDB $ \testEnv -> do
     app <- withLoggerHoisted Mock $ \ioLogger -> do
              env <- newTestEnv testEnv ioLogger 8080
              makeApp env
-    withGargApp app $ \port ->
-      action ((testEnv, port), app)
+    Warp.testWithApplication (pure app) $ \port -> action ((testEnv, port), app)
+
+-- | Starts the backend server /and/ the microservices proxy, the former at
+-- a random port, the latter at a predictable port.
+withBackendServerAndProxy :: (((TestEnv, Warp.Port, Warp.Port)) -> IO ()) -> IO ()
+withBackendServerAndProxy action =
+  withTestDB $ \testEnv -> do
+    gargApp <- withLoggerHoisted Mock $ \ioLogger -> do
+                 env <- newTestEnv testEnv ioLogger 8080
+                 makeApp env
+    proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do
+                  env <- newTestEnv testEnv ioLogger 8080
+                  pure $ microServicesProxyApp env
+
+    Warp.testWithApplication (pure gargApp) $ \serverPort ->
+      testWithApplicationOnPort (pure proxyApp) proxyPort $
+        action (testEnv, serverPort, proxyPort)
+  where
+    proxyPort = 8090
 
 setupEnvironment :: TestEnv -> IO ()
 setupEnvironment env = flip runReaderT env $ runTestMonad $ do
@@ -113,3 +135,40 @@ createAliceAndBob testEnv = do
 
     void $ new_user nur1
     void $ new_user nur2
+
+
+-- | A version of 'withApplication' that allows supplying a user-specified port
+-- so that we are sure that our garg apps will run on the same port as specified
+-- in the 'Env' settings.
+testWithApplicationOnPort :: IO Application -> Warp.Port -> IO a -> IO a
+testWithApplicationOnPort mkApp userPort action = do
+    app <- mkApp
+    started <- mkWaiter
+    let appSettings =
+            Warp.defaultSettings
+                { settingsBeforeMainLoop =
+                    notify started () >> settingsBeforeMainLoop Warp.defaultSettings
+                , settingsPort = userPort
+                }
+    sock <- bindPortTCP userPort "127.0.0.1"
+    result <-
+        Async.race
+            (runSettingsSocket appSettings sock app)
+            (waitFor started >> action)
+    case result of
+        Left () -> UnliftIO.throwString "Unexpected: runSettingsSocket exited"
+        Right x -> return x
+
+data Waiter a = Waiter
+    { notify :: a -> IO ()
+    , waitFor :: IO a
+    }
+
+mkWaiter :: IO (Waiter a)
+mkWaiter = do
+    mvar <- newEmptyMVar
+    return
+        Waiter
+            { notify = putMVar mvar
+            , waitFor = readMVar mvar
+            }

test/Test/Database/Setup.hs

@@ -2,6 +2,7 @@
 module Test.Database.Setup (
     withTestDB
   , fakeIniPath
+  , fakeSettingsPath
   , testEnvToPgConnectionInfo
   ) where
 
@@ -35,6 +36,9 @@ dbName = "gargandb_test"
 fakeIniPath :: IO FilePath
 fakeIniPath = getDataFileName "test-data/test_config.ini"
 
+fakeSettingsPath :: IO FilePath
+fakeSettingsPath = getDataFileName "test-data/gargantext-settings.toml"
+
 gargDBSchema :: IO FilePath
 gargDBSchema = getDataFileName "devops/postgres/schema.sql"
 
@@ -74,7 +78,7 @@ setup = do
       bootstrapDB db pool gargConfig
       ugen <- emptyCounter
       test_nodeStory <- fromDBNodeStoryEnv pool
-      stgs <- devSettings devJwkFile
+      stgs <- devSettings devJwkFile =<< (SettingsFile <$> fakeSettingsPath)
       withLoggerHoisted Mock $ \logger -> do
         pure $ TestEnv { test_db = DBHandle pool db
                        , test_config = gargConfig

test/Test/Server/ReverseProxy.hs

+
+module Test.Server.ReverseProxy where
+
+import Data.Function ((&))
+import Gargantext.MicroServices.ReverseProxy
+import Network.HTTP.Client
+import Network.HTTP.Types.Status
+import Prelude
+import Servant.Auth.Client (Token(..))
+import Servant.Client
+import Servant.Client.Generic (genericClient)
+import Test.API.Setup (setupEnvironment, withBackendServerAndProxy, createAliceAndBob)
+import Test.Hspec
+import Gargantext.Core.Types.Individu (GargPassword(..))
+import Gargantext.API.Admin.Auth.Types
+import Test.API.Authentication (auth_api)
+import Control.Lens ((^.))
+import Test.API.Routes (toServantToken)
+
+
+reverseProxyClient :: ReverseProxyAPI (AsClientT ClientM)
+reverseProxyClient = genericClient
+
+tests :: Spec
+tests = describe "Microservices proxy" $ do
+  writeFrameTests
+
+writeFrameTests :: Spec
+writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do
+  describe "Prelude" $ do
+    it "setup DB triggers" $ \(testEnv, _, _) -> setupEnvironment testEnv
+  describe "Write Frame Reverse Proxy" $ do
+    it "should disallow unauthenticated requests" $ \(_testEnv, _serverPort, proxyPort) -> do
+      baseUrl <- parseBaseUrl "http://localhost"
+      manager <- newManager defaultManagerSettings
+      let clientEnv prt = mkClientEnv manager (baseUrl { baseUrlPort = prt })
+      result <- runClientM (reverseProxyClient & notesServiceProxy
+                                               & ($ (Token "bogus"))
+                                               & notesEp
+                                               & ($ (FrameId "abcdef"))
+                                               & ($ "GET")
+                           ) (clientEnv proxyPort)
+
+      case result of
+        Right response
+          -> responseStatusCode response `shouldBe` status401
+        Left (FailureResponse _ response)
+          -> responseStatusCode response `shouldBe` status401
+        Left err
+          -> fail (show err)
+
+    it "should allow authenticated requests" $ \(testEnv, serverPort, proxyPort) -> do
+      -- Let's create the Alice user.
+      createAliceAndBob testEnv
+      baseUrl <- parseBaseUrl "http://localhost"
+      manager <- newManager defaultManagerSettings
+      let clientEnv prt = mkClientEnv manager (baseUrl { baseUrlPort = prt })
+
+      let authPayload = AuthRequest "alice@gargan.text" (GargPassword "alice")
+      result0 <- runClientM (auth_api authPayload) (clientEnv serverPort)
+
+      case result0 of
+        Left err -> fail (show err)
+        Right autRes -> do
+          result <- runClientM (reverseProxyClient & notesServiceProxy
+                                                   & ($ (toServantToken $ autRes ^. authRes_token))
+                                                   & notesEp
+                                                   & ($ (FrameId "abcdef"))
+                                                   & ($ "GET")
+                               ) (clientEnv proxyPort)
+
+          -- The actual request to the reverse proxy might fail (because our
+          -- environment is not setup correctly, for example) but crucially here
+          -- we want to test that with a valid authentication we don't hit the
+          -- 401 error.
+          case result of
+            Right response
+              -> responseStatusCode response `shouldNotBe` status401
+            Left (FailureResponse _ response)
+              -> responseStatusCode response `shouldNotBe` status401
+            Left err
+              -> fail (show err)

test/drivers/hspec/Main.hs

@@ -12,6 +12,7 @@ import System.Process
 import Test.Hspec
 import qualified Data.Text as T
 import qualified Test.API                     as API
+import qualified Test.Server.ReverseProxy     as ReverseProxy
 import qualified Test.Database.Operations     as DB
 
 
@@ -52,5 +53,6 @@ main = do
   hSetBuffering stdout NoBuffering
   bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
     API.tests
+    ReverseProxy.tests
     DB.tests
     DB.nodeStoryTests