Merge remote-tracking branch 'origin/adinapoli/issue-302' into dev

bin/update-project-dependencies

@@ -13,7 +13,7 @@ INDEX_STATE="2023-12-10T10:34:46Z"
 # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
 # cache can kick in.
 expected_cabal_project_hash="1e4d40d48546606fba0ce0eaae9f2799c57d8ce97c4425940f3a535c4f628a8a"
-expected_cabal_project_freeze_hash="2c13034bdeaeaece6c81362ef047c3102782b4fbf4fd7670bb677bd1ac3b0151"
+expected_cabal_project_freeze_hash="745c65c246998cfda4d2a7a22df44a9f1f7fb0927e2afc2f16712861bf552c76"
 
 cabal --store-dir=$STORE_DIR v2-update "hackage.haskell.org,${INDEX_STATE}"
 

cabal.project.freeze

@@ -497,6 +497,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.scientific ==0.3.7.0,
              scientific -bytestring-builder -integer-simple,
              any.securemem ==0.1.10,
+             any.selective ==0.7,
              any.semialign ==1.3,
              semialign +semigroupoids,
              any.semigroupoids ==5.3.7,
@@ -627,6 +628,8 @@ constraints: any.Cabal ==3.8.1.0,
              any.tls ==1.6.0,
              tls +compat -hans +network,
              any.tmp-postgres ==1.34.1.0,
+             any.tomland ==1.3.3.2,
+             tomland -build-play-tomland -build-readme,
              any.transformers ==0.5.6.2,
              any.transformers-base ==0.4.6,
              transformers-base +orphaninstances,
@@ -662,6 +665,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.utility-ht ==0.0.17,
              any.uuid ==1.3.15,
              any.uuid-types ==1.0.5.1,
+             any.validation-selective ==0.2.0.0,
              any.validity ==0.12.0.2,
              any.vault ==0.3.1.5,
              vault +useghc,

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 <- makeDevMiddleware mode
+  mid <- makeGargMiddleware (env ^. settings.corsSettings) mode
   periodicActions <- schedulePeriodicActions env
   run port (mid app) `finally` stopGargantext env periodicActions
 
@@ -98,14 +100,6 @@ stopGargantext env scheduledPeriodicActions = do
   putStrLn "----- Stopping gargantext -----"
   runReaderT saveNodeStoryImmediate env
 
-{-
-startGargantextMock :: PortNumber -> IO ()
-startGargantextMock port = do
-  portRouteInfo port
-  application <- makeMockApp . MockEnv $ FireWall False
-  run port application
--}
-
 -- | Schedules all sorts of useful periodic actions to be run while
 -- the server is alive accepting requests.
 schedulePeriodicActions :: DB.CmdCommon env => env -> IO [ThreadId]
@@ -145,97 +139,30 @@ fireWall req fw = do
        then pure True
        else pure False
 
-{-
--- makeMockApp :: Env -> IO (Warp.Settings, Application)
-makeMockApp :: MockEnv -> IO Application
-makeMockApp env = do
-    let serverApp = appMock
-
-    -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
-    --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
-    let checkOriginAndHost app req resp = do
-            blocking <- fireWall req (env ^. menv_firewall)
-            case blocking  of
-                True  -> app req resp
-                False -> resp ( responseLBS status401 []
-                              "Invalid Origin or Host header")
-
-    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
-            }
-
-    --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
-    --          $ Warp.defaultSettings
-
-    --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
-    pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
--}
-
-
-makeDevMiddleware :: Mode -> IO Middleware
-makeDevMiddleware mode = do
--- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
--- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
---    let checkOriginAndHost app req resp = do
---            blocking <- fireWall req (env ^. menv_firewall)
---            case blocking  of
---                True  -> app req resp
---                False -> resp ( responseLBS status401 []
---                              "Invalid Origin or Host header")
---
-    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
+            , corsRequestHeaders = ["authorization", "content-type", "x-garg-error-scheme"]
             , corsMaxAge         = Just ( 60*60*24 ) -- one day
-            , corsVaryOrigin     = False
-            , corsRequireOrigin  = False
-            , corsIgnoreFailures = False
             }
-
-    --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
-    --          $ Warp.defaultSettings
-
-    --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
     case mode of
       Prod -> pure $ logStdout . corsMiddleware
       _    -> do
         loggerMiddleware <- logStdoutDevSanitised
         pure $ loggerMiddleware . corsMiddleware
-
+  where
+    mkCorsOrigin :: CORSOrigin -> Origin
+    mkCorsOrigin = TE.encodeUtf8 . _CORSOrigin
 
 ---------------------------------------------------------------------
 -- | API Global
 ---------------------------------------------------------------------
 
----------------------------
-
-
--- TODO-SECURITY admin only: withAdmin
--- Question: How do we mark admins?
-{-
-serverGargAdminAPI :: GargServer GargAdminAPI
-serverGargAdminAPI =  roots
-                 :<|> nodesAPI
--}
-
----------------------------------------------------------------------
---gargMock :: Server GargAPI
---gargMock = mock apiGarg Proxy
----------------------------------------------------------------------
-
 makeApp :: Env -> IO Application
 makeApp env = do
   serv <- server env
@@ -247,11 +174,8 @@ makeApp env = do
     cfg :: Servant.Context AuthContext
     cfg = env ^. settings . jwtSettings
        :. env ^. settings . cookieSettings
-    -- :. authCheck env
        :. EmptyContext
 
---appMock :: Application
---appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 ---------------------------------------------------------------------
 api :: Proxy API
 api  = Proxy
@@ -262,19 +186,3 @@ apiWithEkg = Proxy
 apiGarg :: Proxy GargAPI
 apiGarg  = Proxy
 ---------------------------------------------------------------------
-
-{- UNUSED
---import GHC.Generics (D1, Meta (..), Rep, Generic)
---import GHC.TypeLits (AppendSymbol, Symbol)
----------------------------------------------------------------------
--- Type Family for the Documentation
-type family TypeName (x :: *) :: Symbol where
-    TypeName Int  = "Int"
-    TypeName Text = "Text"
-    TypeName x    = GenericTypeName x (Rep x ())
-
-type family GenericTypeName t (r :: *) :: Symbol where
-    GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
-
-type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
--}

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"
 

stack.yaml

@@ -43,6 +43,8 @@
 - "stemmer-0.5.2"
 - "taggy-0.2.1"
 - "taggy-lens-0.1.2"
+- "tomland-1.3.3.2"
+- "validation-selective-0.2.0.0"
 - "vector-0.12.3.0"
 - "wai-3.2.4"
 - commit: 2b5d69448557e89002c0179ea1aaf59bb757a6e3
@@ -583,6 +585,9 @@ flags:
     compat: true
     hans: false
     network: true
+  tomland:
+    "build-play-tomland": false
+    "build-readme": false
   "transformers-base":
     orphaninstances: true
   "transformers-compat":