Skip to content

haskell-gargantext
haskell-gargantext
Commit 11e497c2 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli
Browse files
Options

Make microservices proxy settings configurable

parent 78687085
Hide whitespace changes
Inline Side-by-side
Showing with 207 additions and 104 deletions
gargantext-cors-settings.toml → gargantext-settings.toml
View file @ 11e497c2
[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
View file @ 11e497c2
......@@ -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
......
src/Gargantext/API.hs
View file @ 11e497c2
......@@ -46,7 +46,8 @@ 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.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
......@@ -70,14 +71,15 @@ 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
let runServer = run port (mid app) `finally` stopGargantext periodicActions
let runProxy = run (port + 1) (microServicesProxyApp env)
let runProxy = run proxyPort (microServicesProxyApp env)
Async.race_ runServer runProxy
......@@ -90,15 +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 $ " - Microservices proxy .....................: " <> "http://localhost:" <> toUrlPiece (port +1)
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
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -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)
<*> 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) }
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
makeLenses ''CORSSettings
src/Gargantext/API/Admin/Settings/MicroServices.hs 0 → 100644
View file @ 11e497c2
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Settings.MicroServices where
import Prelude
import Toml
import Control.Lens.TH
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
makeLenses ''MicroServicesSettings
src/Gargantext/API/Admin/Settings/TOML.hs 0 → 100644
View file @ 11e497c2
{-# 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
-- | 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)
-- | 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 $ settings0 & over (gargCorsSettings . corsAllowedHosts) (\_ -> "http://localhost:3000" : (settings0 ^. gargCorsSettings . corsAllowedOrigins))
False -> pure $ settings0 & over (gargCorsSettings . corsAllowedHosts) ("http://localhost:3000" :)
src/Gargantext/API/Admin/Types.hs
View file @ 11e497c2
......@@ -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
......@@ -19,15 +20,16 @@ data SendEmailType = SendEmailViaAws
deriving (Show, Read, Enum, Bounded, Generic)
data Settings = Settings
{ _corsSettings :: !CORSSettings -- CORS settings
, _appPort :: !PortNumber
, _logLevelLimit :: !LogLevel -- log level from the monad-logger package
{ _corsSettings :: !CORSSettings -- CORS settings
, _microservicesSettings :: !MicroServicesSettings
, _appPort :: !PortNumber
, _logLevelLimit :: !LogLevel -- log level from the monad-logger package
-- , _dbServer :: Text
-- ^ this is not used yet
, _jwtSettings :: !JWTSettings
, _cookieSettings :: !CookieSettings
, _sendLoginEmails :: !SendEmailType
, _scrapydUrl :: !BaseUrl
, _jwtSettings :: !JWTSettings
, _cookieSettings :: !CookieSettings
, _sendLoginEmails :: !SendEmailType
, _scrapydUrl :: !BaseUrl
}
makeLenses ''Settings
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -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/Core/Viz/Graph/API.hs
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -22,12 +22,14 @@ module Gargantext.Database.Action.Node
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)
......@@ -37,12 +39,12 @@ import Gargantext.Prelude.Crypto.Hash (hash)
------------------------------------------------------------------------
-- | 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
------------------------------------------------------------------------
......@@ -71,12 +73,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
......@@ -93,16 +95,17 @@ mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[])
mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
internalNotesProxy :: GargConfig -> T.Text
internalNotesProxy cfg = "http://localhost:8009/notes-proxy"
internalNotesProxy :: MicroServicesSettings -> T.Text
internalNotesProxy MicroServicesSettings{..} =
"http://localhost:" <> T.pack (show _msProxyPort) <> "/notes-proxy"
-- | Function not exposed
mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType)
=> NodeType
-> Maybe ParentId
-> UserId
-> Name
-> DBCmd err [NodeId]
mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType, HasSettings env)
=> NodeType
-> Maybe ParentId
-> UserId
-> Name
-> DBCmd' env err [NodeId]
mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
nodeId <- case nt of
Notes -> insertNode Notes (Just name) Nothing i uId
......@@ -111,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 $ internalNotesProxy cfg
Notes -> pure $ internalNotesProxy (_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
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -95,11 +95,12 @@ type CmdRandom env err m =
, HasMail env
)
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 err a = forall m env. DbCmd' env err m => m a
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
-- to use the Gargantext Database. It's important, to ease testability,
......
src/Gargantext/Database/Query/Tree/Root.hs
View file @ 11e497c2
......@@ -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
View file @ 11e497c2
......@@ -18,6 +18,8 @@ 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.Database.Prelude (hasConfig)
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_frame_write_url)
......@@ -77,6 +79,13 @@ forwardServer :: Env -> ServerT Raw m
forwardServer env =
Tagged $ waiProxyToSettings forwardRequest proxySettings (env ^. env_manager)
where
microSrvSettings :: MicroServicesSettings
microSrvSettings = env ^. env_settings . microservicesSettings
pxyPort :: Int
pxyPort = microSrvSettings ^. msProxyPort
writeFrameURL :: T.Text
writeFrameURL = env ^. hasConfig . gc_frame_write_url
......@@ -122,7 +131,7 @@ forwardServer env =
newReferer :: RequestHeaders -> RequestHeaders
newReferer hdrs =
(hReferer, "http://localhost:8009") :
(hReferer, fromString $ "http://localhost:" <> Prelude.show pxyPort) :
filter ((/=) hHost . fst) hdrs
forwardedHost :: (String, Int)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment