Improve CORS support

gargantext-cors-settings.toml

+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

gargantext.cabal

@@ -36,6 +36,7 @@ data-files:
     test-data/phylo/open_science.json
     test-data/phylo/issue-290-small.golden.json
     test-data/test_config.ini
+    gargantext-cors-settings.toml
     .clippy.dhall
 
 -- When enabled, it swaps the hashing algorithm
@@ -56,6 +57,7 @@ library
       Gargantext.API.Admin.Auth.Types
       Gargantext.API.Admin.EnvTypes
       Gargantext.API.Admin.Settings
+      Gargantext.API.Admin.Settings.CORS
       Gargantext.API.Admin.Orchestrator.Types
       Gargantext.API.Admin.Types
       Gargantext.API.Auth.PolicyCheck
@@ -574,6 +576,7 @@ library
     , timezone-series ^>= 0.1.13
     , transformers ^>= 0.5.6.2
     , transformers-base ^>= 0.4.6
+    , tomland >= 1.3.3.2
     , tuple ^>= 0.3.0.2
     , unordered-containers ^>= 0.2.16.0
     , uri-encode ^>= 1.5.0.7

src/Gargantext/API.hs

@@ -38,12 +38,14 @@ import Control.Concurrent
 import Control.Lens hiding (Level)
 import Data.List (lookup)
 import Data.Text (pack)
+import Data.Text.Encoding qualified as TE
 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.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
+import Gargantext.API.Admin.Settings.CORS
+import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings)
 import Gargantext.API.EKG
 import Gargantext.API.Middleware (logStdoutDevSanitised)
 import Gargantext.API.Ngrams (saveNodeStoryImmediate)
@@ -70,7 +72,7 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
   runDbCheck env
   portRouteInfo port
   app <- makeApp env
-  mid <- makeGargMiddleware mode
+  mid <- makeGargMiddleware (env ^. settings.corsSettings) mode
   periodicActions <- schedulePeriodicActions env
   run port (mid app) `finally` stopGargantext env periodicActions
 
@@ -137,27 +139,25 @@ fireWall req fw = do
        then pure True
        else pure False
 
-makeGargMiddleware :: Mode -> IO Middleware
-makeGargMiddleware mode = do
-    let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
---          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
-            { corsOrigins        = Nothing --  == /*
-            , corsMethods        = [ methodGet   , methodPost   , methodPut
-                                   , methodDelete, methodOptions, methodHead]
-            , corsRequestHeaders = ["authorization", "content-type"]
-            , corsExposedHeaders = Nothing
-            , corsMaxAge         = Just ( 60*60*24 ) -- one day
-            , corsVaryOrigin     = False
-            , corsRequireOrigin  = False
+makeGargMiddleware :: CORSSettings -> Mode -> IO Middleware
+makeGargMiddleware crsSettings mode = do
+    let corsMiddleware = cors $ \_incomingRq -> Just
+          simpleCorsResourcePolicy
+            { corsOrigins = Just (map mkCorsOrigin (crsSettings ^. corsAllowedOrigins), True)
+            , corsMethods = [ methodGet   , methodPost   , methodPut
+                            , methodDelete, methodOptions, methodHead]
             , corsIgnoreFailures = False
+            , corsRequestHeaders = ["authorization", "content-type", "x-garg-error-scheme"]
+            , corsMaxAge         = Just ( 60*60*24 ) -- one day
             }
-
     case mode of
       Prod -> pure $ logStdout . corsMiddleware
       _    -> do
         loggerMiddleware <- logStdoutDevSanitised
         pure $ loggerMiddleware . corsMiddleware
-
+  where
+    mkCorsOrigin :: CORSOrigin -> Origin
+    mkCorsOrigin = TE.encodeUtf8 . _CORSOrigin
 
 ---------------------------------------------------------------------
 -- | API Global

src/Gargantext/API/Admin/Settings.hs

@@ -28,6 +28,7 @@ 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.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
@@ -57,9 +58,9 @@ devSettings jwkFile = do
   jwkExists <- doesFileExist jwkFile
   when (not jwkExists) $ writeKey jwkFile
   jwk       <- readKey jwkFile
+  gargCorsSettings <- loadGargCorsSettings
   pure $ Settings
-    { _allowedOrigin = "http://localhost:8008"
-    , _allowedHost = "localhost:3000"
+    { _corsSettings = gargCorsSettings
     , _appPort = 3000
     , _logLevelLimit = LevelDebug
 --    , _dbServer = "localhost"

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

+{--| Support in Gargantext for CORS (Cross-origin resource sharing) --}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Gargantext.API.Admin.Settings.CORS where
+
+import Prelude
+
+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
+
+newtype CORSOrigin = CORSOrigin { _CORSOrigin :: T.Text }
+  deriving (Show, Eq, IsString)
+
+data CORSSettings =
+  CORSSettings {
+    _corsAllowedOrigins :: [CORSOrigin]
+  , _corsAllowedHosts   :: [CORSOrigin]
+  -- | If 'True', we will reuse the origin whitelist
+  -- as the allowed hosts as well. This allows, for example,
+  -- to connect from \"demo.gargantext.org\" to \"dev.sub.gargantext.org\"
+  -- and vice-versa.
+  , _corsUseOriginsForHosts :: !Bool
+  } deriving (Show, Eq)
+
+corsOriginCodec :: TomlBiMap CORSOrigin AnyValue
+corsOriginCodec = _Orig >>> _Text
+  where
+   _Orig :: BiMap e CORSOrigin T.Text
+   _Orig = iso _CORSOrigin CORSOrigin
+
+corsSettingsCodec :: TomlCodec CORSSettings
+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/Types.hs

--- |
-
 {-# LANGUAGE TemplateHaskell     #-}
 
 module Gargantext.API.Admin.Types where
@@ -7,6 +5,7 @@ module Gargantext.API.Admin.Types where
 import Control.Lens
 import Control.Monad.Logger (LogLevel)
 import GHC.Enum
+import Gargantext.API.Admin.Settings.CORS
 import Gargantext.Prelude
 import Servant.Auth.Server (JWTSettings, CookieSettings(..))
 import Servant.Client (BaseUrl)
@@ -20,8 +19,7 @@ data SendEmailType = SendEmailViaAws
     deriving (Show, Read, Enum, Bounded, Generic)
 
 data Settings = Settings
-    { _allowedOrigin   :: !ByteString   -- allowed origin for CORS
-    , _allowedHost     :: !ByteString   -- allowed host for CORS
+    { _corsSettings    :: !CORSSettings   -- CORS settings
     , _appPort         :: !PortNumber
     , _logLevelLimit   :: !LogLevel -- log level from the monad-logger package
 --    , _dbServer        :: Text

src/Gargantext/API/Middleware.hs

@@ -12,7 +12,9 @@ import Data.Aeson qualified as A
 import Data.Aeson.Lens qualified as L
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
+import Data.ByteString.Builder qualified as BS
 import Data.ByteString.Char8 qualified as C8
+import Data.ByteString.Lazy qualified as B
 import Data.CaseInsensitive qualified as CI
 import Data.List qualified as L
 import Data.String
@@ -43,7 +45,7 @@ atKey i = L._Object . at (fromString $ T.unpack i)
 {-# INLINE atKey #-}
 
 customOutput :: OutputFormatterWithDetailsAndHeaders
-customOutput _zonedDate rq status _mb_response_size request_dur (sanitiseBody . mconcat -> reqbody) _raw_response (map sanitiseHeader -> headers) =
+customOutput _zonedDate rq status _mb_response_size request_dur (sanitiseBody . mconcat -> reqbody) raw_response (map sanitiseHeader -> headers) =
   let params = map sanitiseQueryItem (queryString rq)
   in mkRequestLog params reqbody <> mkResponseLog
 
@@ -66,6 +68,8 @@ customOutput _zonedDate rq status _mb_response_size request_dur (sanitiseBody .
       foldMap toLogStr (ansiColor' White "  Status: ")
           <> foldMap toLogStr (ansiStatusCode' status (C8.pack (show $ statusCode status) <> " " <> statusMessage status))
           <> " "
+          <> (toLogStr . B.toStrict $ (BS.toLazyByteString raw_response))
+          <> " "
           <> "Served in " <> toLogStr (C8.pack $ show $ request_dur)
           <> "\n"