Skip to content

haskell-gargantext
haskell-gargantext
Commit f246fa1c authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge

parents 0b2f43f2 9fa05bd7
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 587 additions and 120 deletions
bin/gargantext-init/Main.hs
View file @ f246fa1c
......@@ -24,12 +24,14 @@ import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus)
import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, DBCmd)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Table.User (insertNewUsers, )
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster))
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import Gargantext.API.Admin.Types
import Gargantext.Database.Prelude (DBCmd')
main :: IO ()
......@@ -49,18 +51,18 @@ main = do
cfg <- readConfig iniPath
let secret = _gc_secretkey cfg
let createUsers :: Cmd BackendInternalError Int64
let createUsers :: forall env. HasSettings env => DBCmd' env BackendInternalError Int64
createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
NE.:| arbitraryNewUsers
)
let
mkRoots :: Cmd BackendInternalError [(UserId, RootId)]
mkRoots :: forall env. HasSettings env => DBCmd' env BackendInternalError [(UserId, RootId)]
mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername)
-- TODO create all users roots
let
initMaster :: Cmd BackendInternalError (UserId, RootId, CorpusId, ListId)
initMaster :: forall env. HasSettings env => DBCmd' env BackendInternalError (UserId, RootId, CorpusId, ListId)
initMaster = do
(masterUserId, masterRootId, masterCorpusId)
<- getOrMkRootWithCorpus MkCorpusUserMaster
......
bin/gargantext-invitations/Main.hs
View file @ f246fa1c
......@@ -17,6 +17,7 @@ module Main where
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Node () -- instances only
import Gargantext.API.Errors.Types
import Gargantext.API.Admin.Types
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Admin.Types.Node
......@@ -37,7 +38,7 @@ main = do
_cfg <- readConfig iniPath
let invite :: (CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
let invite :: (HasSettings env, CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
invite = Share.api (UserName $ cs user) (UnsafeMkNodeId $ (read node_id :: Int)) (Share.ShareTeamParams $ cs email)
withDevEnv iniPath $ \env -> do
......
bin/update-project-dependencies
View file @ f246fa1c
......@@ -18,8 +18,8 @@ fi
# with the `sha256sum` result calculated on the `cabal.project` and
# `cabal.project.freeze`. This ensures the files stay deterministic so that CI
# cache can kick in.
expected_cabal_project_hash="3d88bb97cd394b645692343591ae3230d5393ee07b4e805251fffb9aed4a52dd"
expected_cabal_project_freeze_hash="09930a2fa36e4325d46e5d069595d300c6017472f405f8ac67158377816d132a"
expected_cabal_project_hash="22167800d98d4f204c85c49420eaee0618e749062b9ae9709719638e54319ae9"
expected_cabal_project_freeze_hash="7bb3ba71d0a1881a5c4fd420b9988155586e0cf51e9b6d55867bce3d311d59a5"
cabal --store-dir=$STORE_DIR v2-build --dry-run
cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml
......
cabal.project
View file @ f246fa1c
......@@ -165,7 +165,12 @@ source-repository-package
type: git
location: https://github.com/robstewart57/rdf4h.git
tag: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
source-repository-package
type: git
location: https://github.com/adinapoli/http-reverse-proxy.git
tag: c90b7bc55b0e628d0b71ccee4e222833a19792f8
allow-older: *
allow-newer: *
......
cabal.project.freeze
View file @ f246fa1c
......@@ -283,6 +283,7 @@ constraints: any.Cabal ==3.8.1.0,
http-conduit +aeson,
any.http-date ==0.0.11,
any.http-media ==0.8.1.1,
any.http-reverse-proxy ==0.6.1.0,
any.http-types ==0.12.3,
any.http2 ==4.1.4,
http2 -devel -h2spec,
......@@ -453,8 +454,10 @@ constraints: any.Cabal ==3.8.1.0,
any.refact ==0.3.0.2,
any.reflection ==2.1.7,
reflection -slow +template-haskell,
any.regex ==1.1.0.2,
any.regex-base ==0.94.0.2,
any.regex-compat ==0.95.2.1,
any.regex-pcre-builtin ==0.95.2.3.8.44,
any.regex-posix ==0.96.0.1,
regex-posix -_regex-posix-clib,
any.regex-tdfa ==1.3.2.2,
......
gargantext-cors-settings.toml → gargantext-settings.toml
View file @ f246fa1c
[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 @ f246fa1c
......@@ -49,7 +49,7 @@ data-files:
test-data/phylo/phylo2dot2json.golden.json
test-data/stemming/lancaster.txt
test-data/test_config.ini
gargantext-cors-settings.toml
gargantext-settings.toml
.clippy.dhall
-- common options
......@@ -107,6 +107,8 @@ library
Gargantext.API.Admin.Orchestrator.Types
Gargantext.API.Admin.Settings
Gargantext.API.Admin.Settings.CORS
Gargantext.API.Admin.Settings.MicroServices
Gargantext.API.Admin.Settings.TOML
Gargantext.API.Admin.Types
Gargantext.API.Auth.PolicyCheck
Gargantext.API.Count.Types
......@@ -249,6 +251,7 @@ library
Gargantext.Database.Schema.Node
Gargantext.Database.Schema.User
Gargantext.Defaults
Gargantext.MicroServices.ReverseProxy
Gargantext.System.Logging
Gargantext.Utils.Dict
Gargantext.Utils.Jobs
......@@ -561,6 +564,7 @@ library
, http-conduit ^>= 2.3.8
, http-media ^>= 0.8.0.0
, http-types ^>= 0.12.3
, http-reverse-proxy >= 0.6.1.0
, hxt ^>= 9.3.1.22
, ihaskell >= 0.11.0.0
-- necessary for ihaskell to build
......@@ -613,7 +617,10 @@ library
, quickcheck-instances ^>= 0.3.25.2
, rake ^>= 0.0.1
, random ^>= 1.2.1
, raw-strings-qq
, rdf4h ^>= 3.1.1
, recover-rtti >= 0.4 && < 0.5
, regex
, regex-compat ^>= 0.95.2.1
, regex-tdfa ^>= 1.3.1.2
, replace-attoparsec ^>= 1.4.5.0
......
src/Gargantext/API.hs
View file @ f246fa1c
......@@ -35,6 +35,7 @@ module Gargantext.API
where
import Control.Concurrent
import Control.Concurrent.Async qualified as Async
import Control.Lens hiding (Level)
import Data.List (lookup)
import Data.Text (pack)
......@@ -45,13 +46,15 @@ import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes (Env, Mode(..))
import Gargantext.API.Admin.Settings (newEnv)
import Gargantext.API.Admin.Settings.CORS
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings)
import Gargantext.API.Routes.Named.EKG
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microservicesSettings)
import Gargantext.API.Middleware (logStdoutDevSanitised)
import Gargantext.API.Routes.Named (API)
import Gargantext.API.Routes.Named.EKG
import Gargantext.API.Server.Named (server)
import Gargantext.API.Server.Named.EKG
import Gargantext.Database.Prelude qualified as DB
import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.Prelude hiding (putStrLn)
import Gargantext.System.Logging
import Network.HTTP.Types hiding (Query)
......@@ -68,12 +71,17 @@ import System.FilePath
startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
env <- newEnv logger port file
let proxyPort = env ^. settings.microservicesSettings.msProxyPort
runDbCheck env
portRouteInfo port
portRouteInfo port proxyPort
app <- makeApp env
mid <- makeGargMiddleware (env ^. settings.corsSettings) mode
periodicActions <- schedulePeriodicActions env
run port (mid app) `finally` stopGargantext periodicActions
let runServer = run port (mid app) `finally` stopGargantext periodicActions
let runProxy = run proxyPort (mid (microServicesProxyApp env))
Async.race_ runServer runProxy
where runDbCheck env = do
r <- runExceptT (runReaderT DB.dbCheck env) `catch`
......@@ -84,14 +92,15 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
"You must run 'gargantext-init " <> pack file <>
"' before running gargantext-server (only the first time)."
portRouteInfo :: PortNumber -> IO ()
portRouteInfo port = do
portRouteInfo :: PortNumber -> PortNumber -> IO ()
portRouteInfo mainPort proxyPort = do
putStrLn "=========================================================================================================="
putStrLn " GarganText Main Routes"
putStrLn "=========================================================================================================="
putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece port <> "/index.html"
putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece port <> "/gql"
putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece mainPort <> "/index.html"
putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
putStrLn $ " - Microservices proxy .....................: " <> "http://localhost:" <> toUrlPiece proxyPort
putStrLn "=========================================================================================================="
-- | Stops the gargantext server and cancels all the periodic actions
......
src/Gargantext/API/Admin/EnvTypes.hs
View file @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Settings.MicroServices where
import Prelude
import Control.Lens.TH
import Data.Text qualified as T
import Gargantext.Prelude.Config
import Servant.Client.Core.BaseUrl
import Toml
data MicroServicesSettings =
MicroServicesSettings {
-- | The port where the microservices proxy will be listening on.
_msProxyPort :: Int
} deriving (Show, Eq)
microServicesSettingsCodec :: TomlCodec MicroServicesSettings
microServicesSettingsCodec = MicroServicesSettings
<$> Toml.int "proxy-port" .= _msProxyPort
mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl
mkProxyUrl GargConfig{..} MicroServicesSettings{..} =
case parseBaseUrl (T.unpack _gc_url) of
Nothing -> BaseUrl Http "localhost" 80 ""
Just bh -> bh { baseUrlPort = _msProxyPort }
makeLenses ''MicroServicesSettings
src/Gargantext/API/Admin/Settings/TOML.hs 0 → 100644
View file @ f246fa1c
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Settings.TOML where
import Control.Lens hiding ((.=))
import Data.Text qualified as T
import Gargantext.API.Admin.Settings.CORS
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.Prelude (panicTrace)
import Gargantext.System.Logging
import Paths_gargantext
import Prelude
import Toml
import Servant.Client.Core.BaseUrl
-- | Compatibility bridge until we fix #304 (move to Toml)
data GargTomlSettings = GargTomlSettings
{ _gargCorsSettings :: !CORSSettings
, _gargMicroServicesSettings :: !MicroServicesSettings
}
makeLenses ''GargTomlSettings
settingsCodec :: TomlCodec GargTomlSettings
settingsCodec = GargTomlSettings
<$> (Toml.table corsSettingsCodec "cors" .= _gargCorsSettings)
<*> (Toml.table microServicesSettingsCodec "microservices" .= _gargMicroServicesSettings)
-- | Extends the 'allowed-origins' in the CORSettings with the URLs embellished
-- with the proxy port.
addProxyToAllowedOrigins :: GargTomlSettings -> GargTomlSettings
addProxyToAllowedOrigins stgs =
stgs & over gargCorsSettings (addProxies $ stgs ^. gargMicroServicesSettings . msProxyPort)
where
addProxies :: Int -> CORSSettings -> CORSSettings
addProxies port cors =
let origins = _corsAllowedOrigins cors
mkUrl (CORSOrigin u) = case parseBaseUrl (T.unpack u) of
Nothing -> CORSOrigin u
Just bh -> CORSOrigin $ T.pack $ showBaseUrl $ bh { baseUrlPort = port }
in cors { _corsAllowedOrigins = origins <> Prelude.map mkUrl origins }
-- | Loads the 'CORSSettings' from the 'toml' file.
loadGargTomlSettings :: IO GargTomlSettings
loadGargTomlSettings = do
tomlFile <- getDataFileName "gargantext-settings.toml"
tomlRes <- Toml.decodeFileEither settingsCodec tomlFile
case tomlRes of
Left errs -> do
withLogger () $ \ioLogger -> do
logMsg ioLogger ERROR $ T.unpack $ "Error, gargantext-settings.toml parsing failed: " <> Toml.prettyTomlDecodeErrors errs
panicTrace "Please fix the errors in your gargantext-settings.toml file."
Right settings0 -> case settings0 ^. gargCorsSettings . corsUseOriginsForHosts of
True -> pure $ addProxyToAllowedOrigins $ settings0 & over (gargCorsSettings . corsAllowedHosts) (\_ -> "http://localhost:3000" : (settings0 ^. gargCorsSettings . corsAllowedOrigins))
False -> pure $ addProxyToAllowedOrigins $ settings0 & over (gargCorsSettings . corsAllowedHosts) ("http://localhost:3000" :)
src/Gargantext/API/Admin/Types.hs
View file @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -32,12 +32,13 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Tree (findNodesWithType)
import Gargantext.Prelude
import Servant.Server.Generic (AsServerT)
import Gargantext.API.Admin.Types (HasSettings)
------------------------------------------------------------------------
-- TODO permission
-- TODO refactor userId which is used twice
-- TODO change return type for better warning/info/success/error handling on the front
api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m)
api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m, HasSettings env)
=> User
-> NodeId
-> ShareNodeParams
......
src/Gargantext/API/Routes/Named/Private.hs
View file @ f246fa1c
......@@ -13,11 +13,15 @@ module Gargantext.API.Routes.Named.Private (
, NodeAPIEndpoint(..)
, MembersAPI(..)
, IsGenericNodeRoute(..)
, NotesProxy(..)
) where
import Data.Kind
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics
import GHC.TypeLits
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Routes.Named.Contact
......@@ -25,19 +29,17 @@ import Gargantext.API.Routes.Named.Context
import Gargantext.API.Routes.Named.Corpus
import Gargantext.API.Routes.Named.Count
import Gargantext.API.Routes.Named.Document
import Gargantext.API.Routes.Named.Node
import Gargantext.API.Routes.Named.List qualified as List
import Gargantext.API.Routes.Named.Node
import Gargantext.API.Routes.Named.Share
import Gargantext.API.Routes.Named.Tree
import Gargantext.API.Routes.Named.Table
import Gargantext.API.Routes.Named.Tree
import Gargantext.API.Routes.Named.Viz
import Gargantext.Database.Admin.Types.Hyperdata.Any
import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Admin.Types.Node
import Servant.API
import Servant.Auth qualified as SA
import Data.Kind
import GHC.TypeLits
type MkProtectedAPI private = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser :> private
......@@ -96,6 +98,12 @@ data GargPrivateAPI' mode = GargPrivateAPI'
} deriving Generic
data NotesProxy mode = NotesProxy
{ noteProxyEp :: mode :- Capture "frameId" T.Text
:> Raw
} deriving Generic
data GargAdminAPI mode = GargAdminAPI
{ rootsEp :: mode :- "user" :> Summary "First user endpoint" :> NamedRoutes Roots
, adminNodesAPI :: mode :- "nodes" :> Summary "Nodes endpoint"
......
src/Gargantext/API/Server/Named.hs
View file @ f246fa1c
......@@ -31,15 +31,15 @@ import Servant
import Servant.Server.Generic
import Servant.Swagger.UI (swaggerSchemaUIServer)
serverGargAPI :: Text -> BackEndAPI (AsServerT (GargM Env BackendInternalError))
serverGargAPI baseUrl
serverGargAPI :: Env -> BackEndAPI (AsServerT (GargM Env BackendInternalError))
serverGargAPI env
= BackEndAPI $ MkBackEndAPI $ GargAPIVersion $ GargAPI'
{ gargAuthAPI = AuthAPI auth
, gargForgotPasswordAPI = forgotPassword
, gargForgotPasswordAsyncAPI = forgotPasswordAsync
, gargVersionAPI = gargVersion
, gargPrivateAPI = serverPrivateGargAPI
, gargPublicAPI = serverPublicGargAPI baseUrl
, gargPublicAPI = serverPublicGargAPI (env ^. hasConfig . gc_url_backend_api)
}
where
gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError))
......@@ -54,7 +54,7 @@ server env =
(Proxy :: Proxy (NamedRoutes BackEndAPI))
(Proxy :: Proxy AuthContext)
(transformJSON errScheme)
(serverGargAPI (env ^. hasConfig . gc_url_backend_api))
(serverGargAPI env)
, graphqlAPI = hoistServerWithContext
(Proxy :: Proxy (NamedRoutes GraphQLAPI))
(Proxy :: Proxy AuthContext)
......
src/Gargantext/API/Server/Named/Private.hs
View file @ f246fa1c
{-# OPTIONS_GHC -Wno-deprecations #-}
module Gargantext.API.Server.Named.Private where
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
......@@ -26,7 +26,6 @@ import Gargantext.Prelude
import Servant.Auth.Swagger ()
import Servant.Server.Generic (AsServerT)
---------------------------------------------------------------------
-- | Server declarations
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -21,27 +21,31 @@ module Gargantext.Database.Action.Node
where
import Control.Lens (view)
import Data.Text qualified as T
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types (settings, _microservicesSettings, HasSettings)
import Gargantext.Core
import Gargantext.Core.Types (Name)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Hyperdata.Default
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (DBCmd, HasConfig(..))
import Gargantext.Database.Prelude (HasConfig(..), DBCmd')
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Prelude hiding (hash)
import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Prelude.Crypto.Hash (hash)
import Servant.Client.Core.BaseUrl
------------------------------------------------------------------------
-- | TODO mk all others nodes
mkNodeWithParent :: (HasNodeError err, HasDBid NodeType)
mkNodeWithParent :: (HasNodeError err, HasDBid NodeType, HasSettings env)
=> NodeType
-> Maybe ParentId
-> UserId
-> Name
-> DBCmd err [NodeId]
-> DBCmd' env err [NodeId]
mkNodeWithParent NodeUser (Just pId) uid _ = nodeError $ NodeCreationFailed $ UserParentAlreadyExists uid pId
------------------------------------------------------------------------
......@@ -70,12 +74,12 @@ mkNodeWithParent nt (Just pId) uId name = (:[]) <$> insertNode nt (Just name) N
-- | Sugar to create a node, get its NodeId and update its Hyperdata after
mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err, HasDBid NodeType)
mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err, HasDBid NodeType, HasSettings env)
=> NodeType
-> Maybe ParentId
-> UserId
-> Name
-> DBCmd err [NodeId]
-> DBCmd' env err [NodeId]
mkNodeWithParent_ConfigureHyperdata Notes (Just i) uId name =
mkNodeWithParent_ConfigureHyperdata' Notes (Just i) uId name
......@@ -92,14 +96,16 @@ mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[])
mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
internalNotesProxy :: BaseUrl -> T.Text
internalNotesProxy proxyUrl = T.pack $ showBaseUrl proxyUrl <> "/notes"
-- | Function not exposed
mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType)
=> 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
......@@ -108,8 +114,9 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
_ -> nodeError NeedsConfiguration
cfg <- view hasConfig
stt <- view settings
u <- case nt of
Notes -> pure $ _gc_frame_write_url cfg
Notes -> pure $ internalNotesProxy (mkProxyUrl cfg $ _microservicesSettings stt)
Calc -> pure $ _gc_frame_calc_url cfg
NodeFrameVisio -> pure $ _gc_frame_visio_url cfg
_ -> nodeError NeedsConfiguration
......
src/Gargantext/Database/Action/User/New.hs
View file @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 @ f246fa1c
......@@ -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 0 → 100644
View file @ f246fa1c
This diff is collapsed.
stack.yaml
View file @ f246fa1c
......@@ -62,6 +62,10 @@
git: "https://github.com/MercuryTechnologies/ekg-json.git"
subdirs:
- .
- commit: c90b7bc55b0e628d0b71ccee4e222833a19792f8
git: "https://github.com/adinapoli/http-reverse-proxy.git"
subdirs:
- .
- commit: 7533a9ccd3bfe77141745f6b61039a26aaf5c83b
git: "https://github.com/adinapoli/llvm-hs.git"
subdirs:
......@@ -308,7 +312,11 @@ flags:
"full-text-search":
"build-search-demo": false
gargantext:
<<<<<<< HEAD
"no-phylo-debug-logs": false
=======
"no-phylo-debug-logs": true
>>>>>>> origin/adinapoli/issue-352
"test-crypto": false
"ghc-lib-parser":
"threaded-rts": true
......
test/Test/Database/Setup.hs
View file @ f246fa1c
......@@ -15,6 +15,7 @@ import Database.PostgreSQL.Simple.Options qualified as Client
import Database.PostgreSQL.Simple.Options qualified as Opts
import Database.Postgres.Temp qualified as Tmp
import Gargantext.API.Admin.EnvTypes (Mode(Mock))
import Gargantext.API.Admin.Settings
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Prelude
import Gargantext.Prelude.Config
......@@ -73,12 +74,15 @@ setup = do
bootstrapDB db pool gargConfig
ugen <- emptyCounter
test_nodeStory <- fromDBNodeStoryEnv pool
stgs <- devSettings devJwkFile
withLoggerHoisted Mock $ \logger -> do
pure $ TestEnv { test_db = DBHandle pool db
, test_config = gargConfig
, test_nodeStory
, test_usernameGen = ugen
, test_logger = logger }
, test_logger = logger
, test_settings = stgs
}
withTestDB :: (TestEnv -> IO ()) -> IO ()
withTestDB = bracket setup teardown
......
test/Test/Database/Types.hs
View file @ f246fa1c
......@@ -28,6 +28,7 @@ import Database.Postgres.Temp qualified as Tmp
import Gargantext hiding (to)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.Mail.Types (HasMail(..))
......@@ -61,6 +62,7 @@ data TestEnv = TestEnv {
, test_nodeStory :: !NodeStoryEnv
, test_usernameGen :: !Counter
, test_logger :: !(Logger (GargM TestEnv BackendInternalError))
, test_settings :: !Settings
}
newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
......@@ -104,6 +106,9 @@ instance HasConnectionPool TestEnv where
instance HasConfig TestEnv where
hasConfig = to test_config
instance HasSettings TestEnv where
settings = to test_settings
instance HasMail TestEnv where
mailSettings = to $ const (MailConfig { _mc_mail_host = "localhost"
, _mc_mail_port = 25
......
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