Skip to content

haskell-gargantext
haskell-gargantext
Verified Commit 1f747d2e authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

Merge branch 'dev' into 341-dev-websockets

parents 260ab012 020b6819
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1803 additions and 727 deletions
.gitlab-ci.yml
View file @ 1f747d2e
......@@ -37,7 +37,7 @@ cabal:
- .cabal/
policy: pull-push
script:
- nix-shell --run "./bin/update-project-dependencies $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-build --flags 'test-crypto no-phylo-debug-logs' --ghc-options='-O0 -fclear-plugins'"
- nix-shell --run "./bin/update-project-dependencies $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-build all --flags 'test-crypto no-phylo-debug-logs' --ghc-options='-O0 -fclear-plugins'"
allow_failure: false
bench:
......
CHANGELOG.md
View file @ 1f747d2e
## Version 0.0.7.1.8
* [BACK][FEAT][[Graph explorer] Search and associated documents (#262)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/262) (Backend Part).
## Version 0.0.7.1.7.4
* [FRONT][FEAT][[Graph explorer] Search and associated documents (#262)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/262)
* [FRONT][FEAT][Info list in top bar: use purescript only (#242)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/242)
* [BACK][DOC][[DOCS]: Describe frontend's build step (#363)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/363)
* [BACK][INSTALL] Removing unused docker dependency
## Version 0.0.7.1.7.3
* [BACK][ADM][Consider moving `GargConfig` & co outside of `gargantext-prelude` (#356)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/356)
* [BACK][DOC] Readme updated
## Version 0.0.7.1.7.2
* [FEAT][Calc] Enabling Node calc url sharing
* [BACK][REFACT][We have too many executables (#355)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/355)
## Version 0.0.7.1.7.1
* [CI-TESTS][OK]
## Version 0.0.7.1.7
* [BACK][SECURITU] Node Notes Right managements
## Version 0.0.7.1.6.5
* [BACK][FIX] TSV/CSV hot fix
## Version 0.0.7.1.6.4
* [FRONT][FIX][[Corpus] Import docs from selected list is broken (#679)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/679)
* [BACK][FIX][[Node terms] institutes missing with HAL request (#330)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/330)
## Version 0.0.7.1.6.3
* [BACK][FIX][CSV; TSV in all codebase (#348)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/348)
......
CONTRIBUTING.md deleted 100644 → 0
View file @ 260ab012
# Contributing
## Code contribution
We use Git to share and merge our code.
## Style
We are using the common Haskell Style:
https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md
## Code Of Conduct
Be constructive as sharing our code of conduct
## Chat with us
We are on IRC: [irc.oftc.net, channel #gargantext](ircs://irc.oftc.net:6697/#gargantext)
You can join via Matrix, just search for: #_oftc_#gargantext:matrix.org
You can also join via XMPP: <xmpp://#gargantext%irc.oftc.net@irc.jabberfr.org?join>
DEVELOPER_GUIDELINES.md
View file @ 1f747d2e
......@@ -39,6 +39,7 @@ all developers about how to:
The rest of the document try to answer all those questions.
## Glossary
- GIT: _Git_ is a distributed version control system
......@@ -57,7 +58,29 @@ The rest of the document try to answer all those questions.
The following is a non-exhaustive list of the development guidelines.
### Main working Branches
### Style
When we code, we try to use the [common Haskell Style guide](https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md).
1. For new files, use the referenced style guide;
2. For older files, which might have been written using a different code style, try to respect whichever style guide was used to write the file (to ensure consistency and minimise unwanted changes);
3. Resist the urge of making style modifications mixed to general refactoring; rather separate those into independent commits, so that they are easy to revert if unwanted / not needed
### Code Of Conduct
Please be constructive as sharing our [code of conduct](https://gitlab.iscpif.fr/gargantext/main/blob/master/CODE_OF_CONDUCT.md).
### Chat with us !
We are on IRC: [irc.oftc.net, channel #gargantext](ircs://irc.oftc.net:6697/#gargantext)
You can join via Matrix, just search for: #_oftc_#gargantext:matrix.org
You can also join via XMPP: <xmpp://#gargantext%irc.oftc.net@irc.jabberfr.org?join>
## Git Collaboration Guidelines
### Git Main working Branches
3 main branches are used in the distributed version control system (Git) of GarganText:
- _dev_ branch for latest development
......
README.md
View file @ 1f747d2e
......@@ -30,8 +30,8 @@ Disclaimer: since this project is still in development, this document remains in
#### Prerequisites
- Install:
- git (https://git-scm.com/book/en/v2/Getting-Started-Installing-Git)
- curl (https://everything.curl.dev/get)
- [git](https://git-scm.com/book/en/v2/Getting-Started-Installing-Git)
- [curl](https://everything.curl.dev/index.html)
- Clone the project.
```shell
git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
......@@ -184,10 +184,8 @@ The good news is that you don't have to do all of this manually; during developm
#### 1. Docker-compose will configure your database and some NLP bricks (such as CoreNLP):
First install docker-compose on your system and then:
``` sh
# If docker is not installed:
# curl -sSL https://gitlab.iscpif.fr/gargantext/haskell-gargantext/raw/dev/devops/docker/install_docker | sh
cd devops/docker
docker compose up
```
Initialization schema should be loaded automatically (from `devops/postgres/schema.sql`).
......@@ -204,8 +202,10 @@ cp gargantext.ini_toModify gargantext.ini
> Do not worry, `.gitignore` avoids adding this file to the repository by mistake, then you can change the passwords in gargantext.ini safely.
#### 3. A user have to be created first as instance:
In your nix-shell
``` sh
~/.local/bin/gargantext-init "gargantext.ini"
gargantext-cli init --ini-path "gargantext.ini"
```
Now, `user1` is created with password `1resu`
......@@ -214,7 +214,9 @@ Now, `user1` is created with password `1resu`
From the Backend root folder (haskell-gargantext):
```shell
git clone ssh://git@gitlab.iscpif.fr:20022/gargantext/purescript-gargantext.git
git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext.git
cd purescript-gargantext
./install
```
&nbsp;
......
bin/gargantext-admin/Main.hs deleted 100644 → 0
View file @ 260ab012
{-|
Module : Main.hs
Description : Gargantext Admin tools
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE Strict #-}
module Main where
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Errors.Types
import Gargantext.Database.Action.User.New (newUsers)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd'')
import Gargantext.Prelude
import Gargantext.API.Admin.EnvTypes (DevEnv)
import qualified Data.List.NonEmpty as NE
main :: IO ()
main = do
(iniPath:mails) <- getArgs
withDevEnv iniPath $ \env -> do
x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId))
putStrLn (show x :: Text)
pure ()
bin/gargantext-cli/CLI/Admin.hs 0 → 100644
View file @ 1f747d2e
module CLI.Admin (
adminCLI
, adminCmd
) where
import CLI.Types
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Dev
import Gargantext.API.Errors
import Gargantext.Core.Types
import Gargantext.Database.Action.User.New
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Options.Applicative
import Prelude (String)
adminCLI :: AdminArgs -> IO ()
adminCLI (AdminArgs iniPath mails) = do
withDevEnv iniPath $ \env -> do
x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId))
putStrLn (show x :: Text)
adminCmd :: HasCallStack => Mod CommandFields CLI
adminCmd = command "admin" (info (helper <*> fmap CLISub admin_p) (progDesc "Create users."))
admin_p :: Parser CLICmd
admin_p = fmap CCMD_admin $ AdminArgs
<$> ( strOption ( long "ini-path"
<> metavar "FILEPATH"
<> help "Location of the .ini path"
) )
<*> ( option (maybeReader emails_p) ( long "emails"
<> metavar "email1,email2,..."
<> help "A comma-separated list of emails."
) )
emails_p :: String -> Maybe [String]
emails_p s = case T.splitOn "," (T.pack s) of
[] -> Nothing
xs -> pure $ map T.unpack xs
bin/gargantext-cli/CleanCsvCorpus.hs → bin/gargantext-cli/CLI/CleanCsvCorpus.hs
View file @ 1f747d2e
......@@ -12,7 +12,7 @@ compress the contexts around the main terms of the query.
-}
module CleanCsvCorpus where
module CLI.CleanCsvCorpus where
import Data.SearchEngine qualified as S
import Data.Set qualified as S
......
bin/gargantext-golden-file-diff/Main.hs → bin/gargantext-cli/CLI/FileDiff.hs
View file @ 1f747d2e
module Main where
module CLI.FileDiff where
import Prelude
import CLI.Types
import Data.List qualified as L
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.TreeDiff.Class
import Data.TreeDiff.Pretty
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import System.Environment (getArgs)
import System.Exit (exitFailure)
import Control.Monad (unless)
import qualified Data.List as L
import Gargantext.Prelude (HasCallStack, unless, exitFailure)
import Options.Applicative
import Prelude
-- | Renders in a pretty way the content of two golden files. The
-- first file should contain the expected output, the second the
-- actual data generated by the test suite.
main :: IO ()
main = do
(refPath:newPath:_) <- getArgs
fileDiffCLI :: GoldenFileDiffArgs -> IO ()
fileDiffCLI (GoldenFileDiffArgs refPath newPath) = do
ref <- T.lines <$> TIO.readFile refPath
new <- T.lines <$> TIO.readFile newPath
......@@ -25,3 +24,17 @@ main = do
unless (L.null differences) $ do
putStrLn $ show $ ansiWlEditExpr $ ediff' (map fst differences) (map snd differences)
exitFailure
fileDiffCmd :: HasCallStack => Mod CommandFields CLI
fileDiffCmd = command "golden-file-diff" (info (helper <*> fmap CLISub filediff_p) (progDesc "Compare the output of two golden files."))
filediff_p :: Parser CLICmd
filediff_p = fmap CCMD_golden_file_diff $ GoldenFileDiffArgs
<$> ( strOption ( long "expected"
<> metavar "FILEPATH"
<> help "Path to the file containing the expected output."
) )
<*> ( strOption ( long "actual"
<> metavar "FILEPATH"
<> help "Path to the file containing the actual output."
) )
bin/gargantext-cli/CLI/FilterTermsAndCooc.hs 0 → 100644
View file @ 1f747d2e
module CLI.FilterTermsAndCooc (
filterTermsAndCoocCmd
, filterTermsAndCoocCLI
-- * Testing functions
, testCorpus
, testTermList
) where
import CLI.Types
import Control.Concurrent.Async as CCA (mapConcurrently)
import Data.Aeson ( encode )
import Data.Map.Strict qualified as DM
import Data.Text (pack)
import Data.Text qualified as DT
import Data.Text.Lazy qualified as DTL
import Data.Text.Lazy.Encoding qualified as TLE
import Data.Tuple.Extra (both)
import Data.Vector qualified as DV
import GHC.Generics
import Gargantext.Core.Text.Context (TermList)
import Gargantext.Core.Text.Corpus.Parsers.TSV (readTSVFile, tsv_title, tsv_abstract, tsv_publication_year, fromMIntOrDec, defaultYear)
import Gargantext.Core.Text.List.Formats.TSV (tsvMapTermList)
import Gargantext.Core.Text.Metrics.Count (coocOnContexts, Coocs)
import Gargantext.Core.Text.Terms.WithList ( Patterns, buildPatterns, extractTermsWithList )
import Gargantext.Prelude
import Options.Applicative
------------------------------------------------------------------------
-- OUTPUT format
data CoocByYear = CoocByYear { year :: Int
, nbContexts :: NbContexts
, coocurrences :: Map (Text, Text) Coocs
} deriving (Show, Generic)
data CoocByYears = CoocByYears { years :: [CoocByYear] }
deriving (Show, Generic)
type NbContexts = Int
instance ToJSON CoocByYear
instance ToJSON CoocByYears
------------------------------------------------------------------------
filterTermsAndCoocCLI :: CorpusFile -> TermListFile -> OutputFile -> IO ()
filterTermsAndCoocCLI (CorpusFile corpusFile) (TermListFile termListFile) (OutputFile outputFile) = do
--corpus :: IO (DM.IntMap [[Text]])
eCorpusFile <- readTSVFile corpusFile
case eCorpusFile of
Right cf -> do
let corpus = DM.fromListWith (<>)
. DV.toList
. DV.map (\n -> (fromMIntOrDec defaultYear $ tsv_publication_year n, [(tsv_title n) <> " " <> (tsv_abstract n)]))
. snd $ cf
-- termListMap :: [Text]
termList <- tsvMapTermList termListFile
putText $ show $ length termList
let patterns = buildPatterns termList
-- r <- mapConcurrentlyChunked (filterTermsAndCooc patterns) (DM.toList corpus)
r <- mapConcurrently (filterTermsAndCooc patterns) (DM.toList corpus)
writeFile outputFile $ DTL.toStrict $ TLE.decodeUtf8 $ encode (CoocByYears r)
Left e -> panicTrace $ "Error: " <> e
filterTermsAndCooc
:: Patterns
-> (Int, [Text])
-> IO CoocByYear -- (Int, (Map (Text, Text) Coocs))
filterTermsAndCooc patterns (year, ts) = do
logWork "start"
r <- coocOnContexts identity <$> mapM (\x -> {-log "work" >>-} terms' patterns x) ts
logWork "stop"
pure $ CoocByYear year (length ts) (DM.mapKeys (both DT.unwords) r)
where
logWork m = do
tid <- myThreadId
(p, _) <- threadCapability tid
putText . unwords $
["filterTermsAndCooc:", m, show year, "on proc", show p]
--terms' :: Patterns -> Text -> Corpus [[Text]]
terms' :: Applicative f => Patterns -> Text -> f [[Text]]
terms' pats txt = pure $ concat $ extractTermsWithList pats txt
-- | TODO Minimal Example
--testCooc = do
-- let patterns = buildPatterns testTermList
-- mapM (\x -> {-log "work" >>-} terms' patterns x) $ catMaybes $ map (head . snd) testCorpus
-- --mapConcurrently (filterTermsAndCooc patterns) testCorpus
testCorpus :: [(Int, [Text])]
testCorpus = [ (1998, [pack "The beees"])
, (1999, [ pack "The bees and the flowers"
--, pack "The bees and the flowers"
])
]
testTermList :: TermList
testTermList = [ ([pack "bee"], [[pack "bees"]])
, ([pack "flower"], [[pack "flowers"]])
]
--
-- CLI API
--
filterTermsAndCoocCmd :: HasCallStack => Mod CommandFields CLI
filterTermsAndCoocCmd = command "filter-terms" (info (helper <*> fmap CLISub filterTerms) (progDesc "Filter Terms and Cooc."))
filterTerms :: Parser CLICmd
filterTerms = CCMD_filter_terms_and_cooc
<$> (option str (long "corpus-file" <> metavar "FILE"))
<*> (option str (long "terms-list-file" <> metavar "FILE"))
<*> (option str (long "output-file" <> metavar "FILE"))
bin/gargantext-import/Main.hs → bin/gargantext-cli/CLI/Import.hs
View file @ 1f747d2e
{-|
Module : Main.hs
Module : Import.hs
Description : Gargantext Import Corpus
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -12,10 +12,13 @@ Import a corpus binary.
-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
module Main where
module CLI.Import where
import Data.Text qualified as Text
import CLI.Types
import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
import Gargantext.API.Errors.Types ( BackendInternalError )
......@@ -23,66 +26,62 @@ import Gargantext.API.Node () -- instances
import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Query (Limit)
import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Node (CorpusId)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusName))
import Gargantext.Prelude
import Gargantext.Utils.Jobs.Monad ( MonadJobStatus, JobHandle )
import Options.Applicative
import qualified Data.Text as T
import Prelude (String)
import Gargantext.Core.Types.Query
main :: IO ()
main = do
[fun, user, name, iniPath, limit, corpusPath] <- getArgs
--{-
importCLI :: ImportArgs -> IO ()
importCLI (ImportArgs fun user name iniPath limit corpusPath) = do
let
--tt = (Unsupervised EN 6 0 Nothing)
tt = (Multi EN)
format = TsvGargV3 -- TsvHal --WOS
limit' = case (readMaybe limit :: Maybe Limit) of
Nothing -> panicTrace $ "Cannot read limit: " <> (Text.pack limit)
Just l -> l
tt = Multi EN
format = TsvGargV3
corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
mkCorpusUser = MkCorpusUserNormalCorpusName (UserName $ cs user) (cs name :: Text)
corpus = flowCorpusFile mkCorpusUser limit' tt format Plain corpusPath Nothing DevJobHandle
corpus = flowCorpusFile mkCorpusUser limit tt format Plain corpusPath Nothing DevJobHandle
corpusTsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
corpusTsvHal = flowCorpusFile mkCorpusUser limit' tt TsvHal Plain corpusPath Nothing DevJobHandle
corpusTsvHal = flowCorpusFile mkCorpusUser limit tt TsvHal Plain corpusPath Nothing DevJobHandle
annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
annuaire = flowAnnuaire (MkCorpusUserNormalCorpusName (UserName $ cs user) "Annuaire") (Multi EN) corpusPath DevJobHandle
{-
let debatCorpus :: forall m. FlowCmdM DevEnv BackendInternalError m => m CorpusId
debatCorpus = do
docs <- liftIO ( splitEvery 500
<$> take (read limit :: Int)
<$> readFile corpusPath
:: IO [[GrandDebatReference ]]
)
flowCorpus (Text.pack user) (Text.pack name) (Multi FR) (map (map toHyperdataDocument) docs)
--}
withDevEnv iniPath $ \env -> do
_ <- if fun == "corpus"
then runCmdGargDev env corpus
else pure 0 --(cs "false")
void $ case fun of
IF_corpus
-> runCmdGargDev env corpus
IF_corpusTsvHal
-> runCmdGargDev env corpusTsvHal
IF_annuaire
-> runCmdGargDev env annuaire
importCmd :: HasCallStack => Mod CommandFields CLI
importCmd = command "import" (info (helper <*> fmap CLISub import_p) (progDesc "Import CLI."))
renderImportFunction :: ImportFunction -> T.Text
renderImportFunction = T.drop 3 . T.pack . show
_ <- if fun == "corpusTsvHal"
then runCmdGargDev env corpusTsvHal
else pure 0 --(cs "false")
import_p :: Parser CLICmd
import_p = fmap CCMD_import $ ImportArgs
<$> ( option (eitherReader function_p) ( long "function"
<> help ("The function to use, one between: " <> (T.unpack $ T.intercalate "," $ map renderImportFunction [minBound .. maxBound]))
) )
<*> ( option str ( long "user") )
<*> ( option str ( long "name") )
<*> ( option str ( long "ini" <> help "Path to the .ini file.") )
<*> (fmap Limit ( option auto ( long "ini" <> metavar "INT" <> help "The limit for the query") ))
<*> ( option str ( long "corpus-path" <> help "Path to corpus file") )
_ <- if fun == "annuaire"
then runCmdGargDev env annuaire
else pure 0
{-
_ <- if corpusType == "csv"
then runCmdDev env csvCorpus
else if corpusType == "debat"
then runCmdDev env debatCorpus
else panic "corpusType unknown: try \"csv\" or \"debat\""
-}
pure ()
function_p :: String -> Either String ImportFunction
function_p = \case
"corpus" -> Right IF_corpus
"corpusTsvHal" -> Right IF_corpusTsvHal
"annuaire" -> Right IF_annuaire
xs -> Left $ "Unrecognised function: " <> xs
bin/gargantext-init/Main.hs → bin/gargantext-cli/CLI/Init.hs
View file @ 1f747d2e
{-|
Module : Main.hs
Description : Gargantext Import Corpus
Module : Init.hs
Description : Gargantext Init Script
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Import a corpus binary.
Initialise the Gargantext dataset.
-}
{-# LANGUAGE Strict #-}
module Main where
module CLI.Init where
import Data.List.NonEmpty qualified as NE
import Gargantext.API.Dev (withDevEnv, runCmdDev)
......@@ -24,22 +24,20 @@ 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.Core.Config (GargConfig(..), readConfig)
import Gargantext.API.Admin.Types
import Gargantext.Database.Prelude (DBCmd')
import CLI.Types
import Options.Applicative
main :: IO ()
main = do
params@[iniPath] <- getArgs
_ <- if length params /= 1
then panicTrace "USAGE: ./gargantext-init gargantext.ini"
else pure ()
initCLI :: InitArgs -> IO ()
initCLI (InitArgs iniPath) = do
putStrLn ("Enter master user (gargantua) _password_ :" :: Text)
password <- getLine
......@@ -49,18 +47,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
......@@ -75,4 +73,13 @@ main = do
x <- runCmdDev env initMaster
_ <- runCmdDev env mkRoots
putStrLn (show x :: Text)
pure ()
initCmd :: HasCallStack => Mod CommandFields CLI
initCmd = command "init" (info (helper <*> fmap CLISub init_p) (progDesc "Initialise this Gargantext instance."))
init_p :: Parser CLICmd
init_p = fmap CCMD_init $ InitArgs
<$> ( strOption ( long "ini-path"
<> metavar "FILEPATH"
<> help "Location of the .ini path"
) )
bin/gargantext-invitations/Main.hs → bin/gargantext-cli/CLI/Invitations.hs
View file @ 1f747d2e
{-|
Module : Main.hs
Module : Invitations.hs
Description : GarganText Mailing Invitations
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -12,34 +12,55 @@ Portability : POSIX
{-# LANGUAGE Strict #-}
module Main where
module CLI.Invitations where
import CLI.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Node () -- instances only
import Gargantext.API.Errors.Types
import Gargantext.API.Node () -- instances only
import Gargantext.API.Node.Share qualified as Share
import Gargantext.API.Node.Share.Types qualified as Share
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (CmdRandom)
import Gargantext.Prelude
import Gargantext.Prelude.Config (readConfig)
import Prelude (read)
import Gargantext.API.Node.Share.Types qualified as Share
import Gargantext.API.Node.Share qualified as Share
main :: IO ()
main = do
params@[iniPath,user,node_id,email] <- getArgs
_ <- if length params /= 4
then panicTrace "USAGE: ./gargantext-init gargantext.ini username node_id student@university.edu"
else pure ()
import Gargantext.Core.Config (readConfig)
import Options.Applicative
import Prelude (String)
import Gargantext.Core.Types
invitationsCLI :: InvitationsArgs -> IO ()
invitationsCLI (InvitationsArgs iniPath user node_id email) = do
_cfg <- readConfig iniPath
let invite :: (CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
invite = Share.api (UserName $ cs user) (UnsafeMkNodeId $ (read node_id :: Int)) (Share.ShareTeamParams $ cs email)
let invite :: ( HasSettings env
, CmdRandom env BackendInternalError m
, HasNLPServer env
, CET.HasCentralExchangeNotification env ) => m Int
invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
withDevEnv iniPath $ \env -> do
_ <- runCmdDev env invite
pure ()
void $ runCmdDev env invite
invitationsCmd :: HasCallStack => Mod CommandFields CLI
invitationsCmd = command "invitations" (info (helper <*> fmap CLISub invitations_p) (progDesc "Mailing invitations."))
invitations_p :: Parser CLICmd
invitations_p = fmap CCMD_invitations $ InvitationsArgs
<$> ( strOption ( long "ini-path"
<> metavar "FILEPATH"
<> help "Location of the .ini path"
) )
<*> ( strOption ( long "user" ) )
<*> ( option (eitherReader node_p) ( long "node-id" <> metavar "POSITIVE-INT" <> help "The node ID.") )
<*> ( strOption ( long "email" <> help "The email address.") )
node_p :: String -> Either String NodeId
node_p i = case readMaybe i of
Nothing -> Left $ i <> " is not a valid integer."
Just xs
| xs < 0 -> Left $ "The node id needs to be a positive integer."
| otherwise
-> Right $ UnsafeMkNodeId xs
bin/gargantext-db-obfuscation/Main.hs → bin/gargantext-cli/CLI/ObfuscateDB.hs
View file @ 1f747d2e
......@@ -28,8 +28,10 @@ https://stackoverflow.com/questions/876522/creating-a-copy-of-a-database-in-post
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Strict #-}
module Main where
module CLI.ObfuscateDB (
obfuscateDB
, obfuscateDBCmd
) where
import Data.Text qualified as T
import Database.PostgreSQL.Simple qualified as PSQL
......@@ -37,23 +39,16 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core (toDBid)
import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node (NodeType(..))
import Gargantext.Prelude hiding (option)
import Gargantext.Prelude
import Gargantext.Prelude.Database (runPGSExecute, runPGSQuery)
import Options.Applicative.Simple
import CLI.Types
import Options.Applicative
data Args = Args {
dbHost :: Text
, dbPort :: Int
, dbName :: Text
, dbUser :: Text
, dbPassword :: Text
} deriving (Show, Eq)
obfuscateDBCmd :: HasCallStack => Mod CommandFields CLI
obfuscateDBCmd = command "obfuscate-db" (info (helper <*> fmap CLISub obfuscateDB_p) (progDesc "Obfuscate a cloned Gargantext DB."))
args :: Parser Args
args = Args
obfuscateDB_p :: Parser CLICmd
obfuscateDB_p = fmap CCMD_obfuscate_db $ ObfuscateDBArgs
<$> ( strOption ( long "db-host"
<> metavar "db-host"
<> help "Location of the DB server"
......@@ -71,17 +66,9 @@ args = Args
<*> ( strOption ( long "db-password"
<> metavar "db-password"
<> value "" ))
main :: IO ()
main = do
(opts, ()) <-
simpleOptions "0.0.1"
"gargantext DB obfuscation"
"Obfuscates a cloned Gargantext DB"
args
empty
obfuscateDB :: ObfuscateDBArgs -> IO ()
obfuscateDB opts = do
putText $ show opts
let ci = PSQL.ConnectInfo { connectHost = T.unpack $ dbHost opts
......@@ -101,7 +88,7 @@ main = do
obfuscateNotes :: PSQL.Connection -> IO ()
obfuscateNotes c = do
let nt = toDBid Notes
_ <- runPGSExecute c [sql|UPDATE nodes SET name = concat('notes-', id) WHERE typename = ?;|] (PSQL.Only nt)
nsNew <- runPGSQuery c [sql|SELECT id, name FROM nodes WHERE typename = ?|] (PSQL.Only nt) :: IO [(Int, Text)]
......
bin/gargantext-cli/CLI/Phylo.hs 0 → 100644
View file @ 1f747d2e
{-|
Module : Phylo.hs
Description : Gargantext starter binary with Adaptative Phylo
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Adaptative Phylo binaries
-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Strict #-}
module CLI.Phylo where
import CLI.Phylo.Common
import CLI.Types
import Data.Aeson (eitherDecodeFileStrict')
import Data.List (nub)
import Data.Text qualified as T
import GHC.IO.Encoding
import Gargantext.Core.Viz.Phylo
import Gargantext.Core.Viz.Phylo.API.Tools
import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
import Gargantext.Core.Viz.Phylo.PhyloTools (printIOMsg, printIOComment, setConfig)
import Gargantext.Prelude hiding (hash, replace)
import Options.Applicative
import System.Directory (doesFileExist)
phyloCLI :: PhyloArgs -> IO ()
phyloCLI (PhyloArgs configPath) = do
setLocaleEncoding utf8
config_e <- eitherDecodeFileStrict' configPath
case config_e of
Left err -> panicTrace $ T.pack err
Right config -> do
currentLocale <- getLocaleEncoding
printIOMsg $ "Machine locale: " <> show currentLocale
printIOMsg "Starting the reconstruction"
printIOMsg "Parse the corpus"
mapList <- fileToList (listParser config) (listPath config)
corpus <- if (defaultMode config)
then fileToDocsDefault (corpusParser config) (corpusPath config) [Year 3 1 5,Month 3 1 5,Week 4 2 5] mapList
else fileToDocsAdvanced (corpusParser config) (corpusPath config) (timeUnit config) mapList
printIOComment (show (length corpus) <> " parsed docs from the corpus")
printIOComment (show (length $ nub $ concat $ map text corpus) <> " Size ngs_coterms")
printIOComment (show (length mapList) <> " Size ngs_terms List Map Ngrams")
printIOMsg "Reconstruct the phylo"
-- check the existing backup files
let backupPhyloWithoutLink = (outputPath config) <> "backupPhyloWithoutLink_" <> (configToSha BackupPhyloWithoutLink config) <> ".json"
let backupPhylo = (outputPath config) <> "backupPhylo_" <> (configToSha BackupPhylo config) <> ".json"
phyloWithoutLinkExists <- doesFileExist backupPhyloWithoutLink
phyloExists <- doesFileExist backupPhylo
-- reconstruct the phylo
phylo <- if phyloExists
then do
printIOMsg "Reconstruct the phylo from an existing file"
readPhylo backupPhylo
else do
if phyloWithoutLinkExists
then do
printIOMsg "Reconstruct the phylo from an existing file without links"
phyloWithoutLink <- readPhylo backupPhyloWithoutLink
writePhylo backupPhyloWithoutLink phyloWithoutLink
pure $ toPhylo (setConfig config phyloWithoutLink)
else do
printIOMsg "Reconstruct the phylo from scratch"
phyloWithoutLink <- pure $ toPhyloWithoutLink corpus config
writePhylo backupPhyloWithoutLink phyloWithoutLink
pure $ toPhylo (setConfig config phyloWithoutLink)
writePhylo backupPhylo phylo
printIOMsg "End of reconstruction, start the export"
let dot = toPhyloExport (setConfig config phylo)
let output = configToLabel config
dotToFile output dot
phyloCmd :: HasCallStack => Mod CommandFields CLI
phyloCmd = command "phylo" (info (helper <*> fmap CLISub phylo_p) (progDesc "Phylo toolkit."))
phylo_p :: Parser CLICmd
phylo_p = fmap CCMD_phylo $ PhyloArgs
<$> ( strOption ( long "config"
<> metavar "FILEPATH"
<> help "Path to a file containing a JSON to be parsed into a PhyloConfig"
) )
bin/gargantext-phylo/Phylo/Common.hs → bin/gargantext-cli/CLI/Phylo/Common.hs
View file @ 1f747d2e
{-# LANGUAGE OverloadedStrings #-}
module Common where
module CLI.Phylo.Common where
import Control.Concurrent.Async (mapConcurrently)
import Crypto.Hash.SHA256 (hash)
......@@ -99,6 +99,8 @@ tsvToDocs parser patterns time path =
(map (T.strip . pack) $ splitOn ";" (unpack $ (tsv'_source row)))
time
) <$> snd <$> Tsv.readWeightedTsv path
Csv _ -> panicTrace "CSV is currently not supported."
Csv' _ -> panicTrace "CSV is currently not supported."
-- To parse a file into a list of Document
......@@ -109,6 +111,8 @@ fileToDocsAdvanced parser path time lst = do
Wos limit -> wosToDocs limit patterns time path
Tsv _ -> tsvToDocs parser patterns time path
Tsv' _ -> tsvToDocs parser patterns time path
Csv _ -> panicTrace "CSV is currently not supported."
Csv' _ -> panicTrace "CSV is currently not supported."
fileToDocsDefault :: CorpusParser -> FilePath -> [TimeUnit] -> TermList -> IO [Document]
fileToDocsDefault parser path timeUnits lst =
......
bin/gargantext-phylo-profile/Main.hs → bin/gargantext-cli/CLI/Phylo/Profile.hs
View file @ 1f747d2e
{-# LANGUAGE OverloadedStrings #-}
module Main where
module CLI.Phylo.Profile where
import Common
import CLI.Phylo.Common
import Data.Aeson
import Data.List (nub)
import Gargantext.Core.Viz.Phylo
import Gargantext.Core.Viz.Phylo.API.Tools
import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
import Gargantext.Core.Viz.Phylo.PhyloTools (printIOMsg, printIOComment, setConfig, toPeriods, getTimePeriod, getTimeStep)
import Gargantext.Core.Viz.Phylo.PhyloTools
import GHC.IO.Encoding
import GHC.Stack
import Paths_gargantext
import Prelude
import qualified Data.Text as T
import Shelly
import Shelly hiding (command)
import System.Directory
import Options.Applicative
import CLI.Types
--------------
-- | Main | --
......@@ -46,8 +47,8 @@ phyloConfig outdir = PhyloConfig {
}
main :: HasCallStack => IO ()
main = do
phyloProfileCLI :: HasCallStack => IO ()
phyloProfileCLI = do
shelly $ escaping False $ withTmpDir $ \tdir -> do
curDir <- pwd
......@@ -110,3 +111,8 @@ main = do
dotToFile output dot
echo "Done."
phyloProfileCmd :: HasCallStack => Mod CommandFields CLI
phyloProfileCmd =
command "phylo-profile" (info (helper <*> fmap CLISub (pure CCMD_phylo_profile))
(progDesc "Helper to profile phylo code."))
bin/gargantext-cli/CLI/Types.hs 0 → 100644
View file @ 1f747d2e
module CLI.Types where
import Data.String
import Data.Text (Text)
import Gargantext.Core.Types.Query
import Prelude
import Gargantext.Core.Types (NodeId)
newtype CorpusFile = CorpusFile { _CorpusFile :: FilePath }
deriving (Show, Eq, IsString)
newtype TermListFile = TermListFile { _TermsListFile :: FilePath }
deriving (Show, Eq, IsString)
newtype OutputFile = OutputFile { _OutputFile :: FilePath }
deriving (Show, Eq, IsString)
data ObfuscateDBArgs = ObfuscateDBArgs {
dbHost :: !Text
, dbPort :: !Int
, dbName :: !Text
, dbUser :: !Text
, dbPassword :: !Text
} deriving (Show, Eq)
data AdminArgs = AdminArgs
{ iniPath :: !FilePath
, emails :: [String]
} deriving (Show, Eq)
data ImportFunction
= IF_corpus
| IF_corpusTsvHal
| IF_annuaire
deriving (Show, Eq, Enum, Bounded)
data ImportArgs = ImportArgs
{ imp_function :: !ImportFunction
, imp_user :: !Text
, imp_name :: !Text
, imp_ini :: !FilePath
, imp_limit :: !Limit
, imp_corpus_path :: !FilePath
} deriving (Show, Eq)
data InitArgs = InitArgs
{ init_ini :: !FilePath
} deriving (Show, Eq)
data InvitationsArgs = InvitationsArgs
{ inv_path :: !FilePath
, inv_user :: !Text
, inv_node_id :: !NodeId
, inv_email :: !Text
} deriving (Show, Eq)
data PhyloArgs = PhyloArgs
{ phylo_config :: !FilePath
} deriving (Show, Eq)
data UpgradeArgs = UpgradeArgs
{ upgrade_ini :: !FilePath
} deriving (Show, Eq)
data GoldenFileDiffArgs = GoldenFileDiffArgs
{ gdf_expected :: !FilePath
, gdf_actual :: !FilePath
} deriving (Show, Eq)
data CLICmd
= CCMD_clean_csv_corpus
| CCMD_filter_terms_and_cooc !CorpusFile !TermListFile !OutputFile
| CCMD_obfuscate_db !ObfuscateDBArgs
| CCMD_admin !AdminArgs
| CCMD_import !ImportArgs
| CCMD_init !InitArgs
| CCMD_invitations !InvitationsArgs
| CCMD_phylo !PhyloArgs
| CCMD_phylo_profile
| CCMD_upgrade !UpgradeArgs
| CCMD_golden_file_diff !GoldenFileDiffArgs
deriving (Show, Eq)
data CLI =
CLISub CLICmd
deriving (Show, Eq)
bin/gargantext-upgrade/Main.hs → bin/gargantext-cli/CLI/Upgrade.hs
View file @ 1f747d2e
{-|
Module : Main.hs
Module : Upgrade.hs
Description : Gargantext Import Corpus
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -7,24 +7,26 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Import a corpus binary.
Upgrade a gargantext node.
-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE QuasiQuotes #-}
module Main where
module CLI.Upgrade where
import CLI.Types
import Data.List qualified as List (cycle, concat, take, unlines)
import Gargantext.API.Dev (withDevEnv)
import Gargantext.API.Node () -- instances only
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import Gargantext.Core.Config (GargConfig(..), readConfig)
import Prelude qualified
import Options.Applicative
main :: IO ()
main = do
upgradeCLI :: UpgradeArgs -> IO ()
upgradeCLI (UpgradeArgs iniPath) = do
let ___ = putStrLn ((List.concat
$ List.take 72
......@@ -34,11 +36,6 @@ main = do
putStrLn ("GarganText upgrade to version 0.0.6.9.9.4.4" :: Text)
___
params@[iniPath] <- getArgs
_ <- if length params /= 1
then panicTrace "Usage: ./gargantext-upgrade gargantext.ini"
else pure ()
putStrLn $ List.unlines
[ "Your Database defined in gargantext.ini will be upgraded."
, "We stronlgy recommend you to make a backup using pg_dump."
......@@ -92,3 +89,13 @@ main = do
-- CREATE INDEX IF NOT EXISTS node_stories_ngrams_id_idx
-- ON node_stories(ngrams_id);
-- |]
upgradeCmd :: HasCallStack => Mod CommandFields CLI
upgradeCmd = command "upgrade" (info (helper <*> fmap CLISub upgrade_p) (progDesc "Upgrade a Gargantext node."))
upgrade_p :: Parser CLICmd
upgrade_p = fmap CCMD_upgrade $ UpgradeArgs
<$> ( strOption ( long "ini-path"
<> metavar "FILEPATH"
<> help "Location of the .ini path"
) )
bin/gargantext-cli/CLI/Utils.hs 0 → 100644
View file @ 1f747d2e
module CLI.Utils (
mapMP
, mapConcurrentlyChunked
) where
import Control.Concurrent.Async as CCA (mapConcurrently)
import Data.List.Split (chunksOf)
import Gargantext.Prelude
import System.IO (hFlush)
------------------------------------------------------------------------
-- | Tools
mapMP :: MonadIO m => (a -> m b) -> [a] -> m [b]
mapMP f xs = do
bs <- zipWithM g (cycle "-\\|/") xs
liftIO $ hPutStr stderr ("\rDone\n" :: Text)
pure bs
where
g c x = do
liftIO $ hPutStr stderr ['\r',c]
liftIO $ hFlush stderr
f x
-- | Optimi that need further developments (not used yet)
mapConcurrentlyChunked :: (a -> IO b) -> [a] -> IO [b]
mapConcurrentlyChunked f ts = do
caps <- getNumCapabilities
let n = 1 `max` (length ts `div` caps)
concat <$> mapConcurrently (mapM f) (chunksOf n ts)
bin/gargantext-cli/Main.hs
View file @ 1f747d2e
......@@ -12,129 +12,69 @@ Main specifications to index a corpus with a term list
-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import Control.Concurrent.Async as CCA (mapConcurrently)
import Data.Aeson ( ToJSON, encode )
import Data.List.Split (chunksOf)
import Data.Map.Strict qualified as DM
import Data.Text (pack)
import Data.Text qualified as DT
import Data.Text.Lazy qualified as DTL
import Data.Text.Lazy.Encoding qualified as TLE
import Data.Tuple.Extra (both)
import Data.Vector qualified as DV
import Gargantext.Core.Text.Context (TermList)
import Gargantext.Core.Text.Corpus.Parsers.TSV (readTSVFile, tsv_title, tsv_abstract, tsv_publication_year, fromMIntOrDec, defaultYear)
import Gargantext.Core.Text.List.Formats.TSV (tsvMapTermList)
import Gargantext.Core.Text.Metrics.Count (coocOnContexts, Coocs)
import Gargantext.Core.Text.Terms.WithList ( Patterns, buildPatterns, extractTermsWithList )
import Gargantext.Prelude
import System.IO (hFlush)
------------------------------------------------------------------------
-- OUTPUT format
data CoocByYear = CoocByYear { year :: Int
, nbContexts :: NbContexts
, coocurrences :: Map (Text, Text) Coocs
} deriving (Show, Generic)
data CoocByYears = CoocByYears { years :: [CoocByYear] }
deriving (Show, Generic)
type NbContexts = Int
instance ToJSON CoocByYear
instance ToJSON CoocByYears
------------------------------------------------------------------------
filterTermsAndCooc
:: Patterns
-> (Int, [Text])
-> IO CoocByYear -- (Int, (Map (Text, Text) Coocs))
filterTermsAndCooc patterns (year, ts) = do
logWork "start"
r <- coocOnContexts identity <$> mapM (\x -> {-log "work" >>-} terms' patterns x) ts
logWork "stop"
pure $ CoocByYear year (length ts) (DM.mapKeys (both DT.unwords) r)
where
logWork m = do
tid <- myThreadId
(p, _) <- threadCapability tid
putText . unwords $
["filterTermsAndCooc:", m, show year, "on proc", show p]
import Prelude
import CLI.FilterTermsAndCooc
import CLI.ObfuscateDB (obfuscateDB, obfuscateDBCmd)
import CLI.Types
import Options.Applicative
import CLI.Admin (adminCLI, adminCmd)
import CLI.Import (importCLI, importCmd)
import CLI.Init (initCLI, initCmd)
import CLI.Invitations (invitationsCLI, invitationsCmd)
import CLI.Phylo (phyloCLI, phyloCmd)
import CLI.Phylo.Profile (phyloProfileCLI, phyloProfileCmd)
import CLI.Upgrade (upgradeCLI, upgradeCmd)
import CLI.FileDiff (fileDiffCLI, fileDiffCmd)
runCLI :: CLI -> IO ()
runCLI = \case
CLISub CCMD_clean_csv_corpus
-> putStrLn "TODO."
CLISub (CCMD_filter_terms_and_cooc corpusFile termListFile outputFile)
-> filterTermsAndCoocCLI corpusFile termListFile outputFile
CLISub (CCMD_obfuscate_db args)
-> obfuscateDB args
CLISub (CCMD_admin args)
-> adminCLI args
CLISub (CCMD_import args)
-> importCLI args
CLISub (CCMD_init args)
-> initCLI args
CLISub (CCMD_invitations args)
-> invitationsCLI args
CLISub (CCMD_phylo args)
-> phyloCLI args
CLISub CCMD_phylo_profile
-> phyloProfileCLI
CLISub (CCMD_upgrade args)
-> upgradeCLI args
CLISub (CCMD_golden_file_diff args)
-> fileDiffCLI args
main :: IO ()
main = do
[corpusFile, termListFile, outputFile] <- getArgs
--corpus :: IO (DM.IntMap [[Text]])
eCorpusFile <- readTSVFile corpusFile
case eCorpusFile of
Right cf -> do
let corpus = DM.fromListWith (<>)
. DV.toList
. DV.map (\n -> (fromMIntOrDec defaultYear $ tsv_publication_year n, [(tsv_title n) <> " " <> (tsv_abstract n)]))
. snd $ cf
-- termListMap :: [Text]
termList <- tsvMapTermList termListFile
putText $ show $ length termList
let patterns = buildPatterns termList
-- r <- mapConcurrentlyChunked (filterTermsAndCooc patterns) (DM.toList corpus)
r <- mapConcurrently (filterTermsAndCooc patterns) (DM.toList corpus)
writeFile outputFile $ DTL.toStrict $ TLE.decodeUtf8 $ encode (CoocByYears r)
Left e -> panicTrace $ "Error: " <> e
------------------------------------------------------------------------
-- | Tools
mapMP :: MonadIO m => (a -> m b) -> [a] -> m [b]
mapMP f xs = do
bs <- zipWithM g (cycle "-\\|/") xs
liftIO $ hPutStr stderr ("\rDone\n" :: Text)
pure bs
main = runCLI =<< execParser opts
where
g c x = do
liftIO $ hPutStr stderr ['\r',c]
liftIO $ hFlush stderr
f x
-- | Optimi that need further developments (not used yet)
mapConcurrentlyChunked :: (a -> IO b) -> [a] -> IO [b]
mapConcurrentlyChunked f ts = do
caps <- getNumCapabilities
let n = 1 `max` (length ts `div` caps)
concat <$> mapConcurrently (mapM f) (chunksOf n ts)
--terms' :: Patterns -> Text -> Corpus [[Text]]
terms' :: Applicative f => Patterns -> Text -> f [[Text]]
terms' pats txt = pure $ concat $ extractTermsWithList pats txt
-- | TODO Minimal Example
--testCooc = do
-- let patterns = buildPatterns testTermList
-- mapM (\x -> {-log "work" >>-} terms' patterns x) $ catMaybes $ map (head . snd) testCorpus
-- --mapConcurrently (filterTermsAndCooc patterns) testCorpus
testCorpus :: [(Int, [Text])]
testCorpus = [ (1998, [pack "The beees"])
, (1999, [ pack "The bees and the flowers"
--, pack "The bees and the flowers"
])
]
testTermList :: TermList
testTermList = [ ([pack "bee"], [[pack "bees"]])
, ([pack "flower"], [[pack "flowers"]])
]
opts = info (helper <*> allOptions)
( fullDesc
<> progDesc "CLI for the gargantext-server. Type --help for all the commands."
<> header "gargantext-cli tools" )
allOptions :: Parser CLI
allOptions = subparser (
filterTermsAndCoocCmd <>
obfuscateDBCmd <>
adminCmd <>
importCmd <>
initCmd <>
invitationsCmd <>
phyloCmd <>
phyloProfileCmd <>
upgradeCmd <>
fileDiffCmd
)
bin/gargantext-phylo/Main.hs deleted 100644 → 0
View file @ 260ab012
{-|
Module : Main.hs
Description : Gargantext starter binary with Adaptative Phylo
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Adaptative Phylo binaries
-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Strict #-}
module Main where
import Control.Concurrent.Async (mapConcurrently)
import Crypto.Hash.SHA256 (hash)
import Data.Aeson
import Data.ByteString.Char8 qualified as C8
import Data.List (nub, isSuffixOf, tail)
import Data.List.Split
import Data.Maybe (fromJust)
import Data.Text (unpack, replace, pack)
import Data.Text qualified as T
import Data.Vector qualified as Vector
import GHC.IO.Encoding
import Gargantext.API.Ngrams.Prelude (toTermList)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Text.Context (TermList)
import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..), parseFile)
import Gargantext.Core.Text.Corpus.Parsers.TSV (tsv_title, tsv_abstract, tsv_publication_year, tsv_publication_month, tsv_publication_day, tsv'_source, tsv'_title, tsv'_abstract, tsv'_publication_year, tsv'_publication_month, tsv'_publication_day, tsv'_weight)
import Gargantext.Core.Text.Corpus.Parsers.TSV qualified as Tsv
import Gargantext.Core.Text.List.Formats.TSV (tsvMapTermList)
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, extractTermsWithList)
import Gargantext.Core.Types.Main (ListType(..))
import Gargantext.Core.Viz.Phylo
import Gargantext.Core.Viz.Phylo.API.Tools
import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
import Gargantext.Core.Viz.Phylo.PhyloTools (printIOMsg, printIOComment, setConfig, toPeriods, getTimePeriod, getTimeStep)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
import Gargantext.Prelude hiding (hash, replace)
import Prelude qualified
import System.Directory (listDirectory,doesFileExist)
import Common
main :: IO ()
main = do
setLocaleEncoding utf8
currentLocale <- getLocaleEncoding
printIOMsg $ "Machine locale: " <> show currentLocale
printIOMsg "Starting the reconstruction"
printIOMsg "Read the configuration file"
[args] <- getArgs
jsonArgs <- (eitherDecode <$> readJson args) :: IO (Either Prelude.String PhyloConfig)
case jsonArgs of
Left err -> putStrLn err
Right config -> do
printIOMsg "Parse the corpus"
mapList <- fileToList (listParser config) (listPath config)
corpus <- if (defaultMode config)
then fileToDocsDefault (corpusParser config) (corpusPath config) [Year 3 1 5,Month 3 1 5,Week 4 2 5] mapList
else fileToDocsAdvanced (corpusParser config) (corpusPath config) (timeUnit config) mapList
printIOComment (show (length corpus) <> " parsed docs from the corpus")
printIOComment (show (length $ nub $ concat $ map text corpus) <> " Size ngs_coterms")
printIOComment (show (length mapList) <> " Size ngs_terms List Map Ngrams")
printIOMsg "Reconstruct the phylo"
-- check the existing backup files
let backupPhyloWithoutLink = (outputPath config) <> "backupPhyloWithoutLink_" <> (configToSha BackupPhyloWithoutLink config) <> ".json"
let backupPhylo = (outputPath config) <> "backupPhylo_" <> (configToSha BackupPhylo config) <> ".json"
phyloWithoutLinkExists <- doesFileExist backupPhyloWithoutLink
phyloExists <- doesFileExist backupPhylo
-- reconstruct the phylo
phylo <- if phyloExists
then do
printIOMsg "Reconstruct the phylo from an existing file"
readPhylo backupPhylo
else do
if phyloWithoutLinkExists
then do
printIOMsg "Reconstruct the phylo from an existing file without links"
phyloWithoutLink <- readPhylo backupPhyloWithoutLink
writePhylo backupPhyloWithoutLink phyloWithoutLink
pure $ toPhylo (setConfig config phyloWithoutLink)
else do
printIOMsg "Reconstruct the phylo from scratch"
phyloWithoutLink <- pure $ toPhyloWithoutLink corpus config
writePhylo backupPhyloWithoutLink phyloWithoutLink
pure $ toPhylo (setConfig config phyloWithoutLink)
writePhylo backupPhylo phylo
printIOMsg "End of reconstruction, start the export"
let dot = toPhyloExport (setConfig config phylo)
let output = configToLabel config
dotToFile output dot
bin/metrics/histo/users.sql
View file @ 1f747d2e
\COPY (select count(*), date_trunc('month', a.date_joined) from auth_user a group by 2) TO '/tmp/users.csv' (FORMAT csv);
\COPY (select count(*), date_trunc('month', a.date_joined) from auth_user a group by 2 ORDER BY 2) TO '/tmp/users.csv' (FORMAT csv);
......
bin/update-project-dependencies
View file @ 1f747d2e
......@@ -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="bdb72fb347348798c9eeebc280edb8664a8ecb380d5e8f51dafd0ad647a77087"
expected_cabal_project_freeze_hash="6fbf60b219a4f2ea760f47e5430d3954402d5dde88662d77e224cb0a6d87a274"
expected_cabal_project_hash="e1739caac7fc663496c2cd55f9068a7c52c3cbaae389a49aa961f962ed8439f4"
expected_cabal_project_freeze_hash="6a2e5baca97c36d2ed2f398de43df393763ee01bbd676a50da89067b8f830fe9"
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 @ 1f747d2e
......@@ -93,7 +93,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/hal.git
tag: b99b9e568c8bdc73af2b8016ed03ba5ee83c2030
tag: 3a7d039e07c8564e8ff84ef88480924d18aa5018
source-repository-package
type: git
......@@ -123,8 +123,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude
-- tag: 618f711a530df56caefbb1577c4bf3d5ff45e214
tag: d4f9bee483d41bbdf8ab4e09efb5a5a8216edff4
tag: bb15d828d5ef36eeaa84cccb00598b585048c88e
source-repository-package
type: git
......@@ -176,6 +175,11 @@ source-repository-package
-- location: https://github.com/jimenezrick/nng-haskell
-- tag: 31e52d7bc720e5fb9daf1c1e8bc1fd156d577af2
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 @ 1f747d2e
......@@ -286,6 +286,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,
......@@ -460,8 +461,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,
......
devops/docker/install_docker
View file @ 1f747d2e
......@@ -19,8 +19,8 @@ echo \
sudo apt-get update
sudo apt-get install docker-ce docker-ce-cli containerd.io
sudo apt-get install docker-compose
# specific to our LAL config
sudo adduser debian docker
#sudo adduser debian docker
gargantext-cors-settings.toml → gargantext-settings.toml
View file @ 1f747d2e
[cors]
allowed-origins = [
"https://demo.gargantext.org"
, "https://formation.gargantext.org"
......@@ -16,3 +19,7 @@ allowed-origins = [
]
use-origins-for-hosts = true
[microservices]
proxy-port = 8009
gargantext.cabal
View file @ 1f747d2e
......@@ -5,7 +5,7 @@ cabal-version: 3.4
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.7.1.6.3
version: 0.0.7.1.8
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -34,7 +34,7 @@ data-files:
ekg-assets/cross.png
test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json
test-data/ngrams/simple.json
test-data/ngrams/simple.csv
test-data/ngrams/simple.tsv
test-data/phylo/bpa_phylo_test.json
test-data/phylo/cleopatre.golden.json
test-data/phylo/nadal.golden.json
......@@ -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
......@@ -81,7 +81,7 @@ common optimized
-rtsopts
-with-rtsopts=-N
-Wmissing-signatures
-- When enabled, it swaps the hashing algorithm
-- with a quicker (and less secure) version, which
-- runs faster in tests.
......@@ -89,10 +89,6 @@ flag test-crypto
default: False
manual: True
flag disable-db-obfuscation-executable
default: False
manual: True
-- When enabled, it suppresses at compile time the
-- debug output for the phylo code, so that it doesn't
-- hinder its performance.
......@@ -111,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
......@@ -175,6 +173,9 @@ library
Gargantext.Core.AsyncUpdates.Dispatcher.Types
Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket
Gargantext.Core.AsyncUpdates.Nanomsg
Gargantext.Core.Config
Gargantext.Core.Config.Mail
Gargantext.Core.Config.NLP
Gargantext.Core.Mail.Types
Gargantext.Core.Methods.Similarities
Gargantext.Core.Methods.Similarities.Conditional
......@@ -262,6 +263,7 @@ library
Gargantext.Database.Schema.Node
Gargantext.Database.Schema.User
Gargantext.Defaults
Gargantext.MicroServices.ReverseProxy
Gargantext.System.Logging
Gargantext.Utils.Dict
Gargantext.Utils.Jobs
......@@ -576,6 +578,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
......@@ -593,6 +596,7 @@ library
, located-base ^>= 0.1.1.1
, logging-effect ^>= 1.3.12
, matrix ^>= 0.3.6.1
, mime-mail >= 0.5.1
, monad-control ^>= 1.0.3.1
, monad-logger ^>= 0.3.36
, morpheus-graphql >= 0.17.0 && < 0.25
......@@ -607,6 +611,7 @@ library
, mtl ^>= 2.2.2
, nanomsg-haskell >= 0.2.4 && < 0.3
, natural-transformation ^>= 0.4
, network >= 3.1.4.0
, network-uri ^>= 2.6.4.1
, opaleye ^>= 0.9.6.1
, opaleye-textsearch >= 0.1.0.0
......@@ -629,7 +634,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
......@@ -661,6 +669,7 @@ library
, simple-reflect ^>= 0.3.3
, singletons ^>= 2.7
, singletons-th >= 3.1
, smtp-mail >= 0.3.0.0
, split ^>= 0.2.3.4
, stemmer ^>= 0.5.2
, stm ^>= 2.5.0.1
......@@ -703,144 +712,29 @@ library
, zip-archive ^>= 0.4.3
, zlib ^>= 0.6.2.3
executable gargantext-admin
import:
defaults
, optimized
main-is: Main.hs
other-modules:
Paths_gargantext
hs-source-dirs:
bin/gargantext-admin
build-depends:
extra
, gargantext
, gargantext-prelude
, text
executable gargantext-cli
import:
defaults
, optimized
main-is: Main.hs
other-modules:
CleanCsvCorpus
CLI.Admin
CLI.CleanCsvCorpus
CLI.FileDiff
CLI.FilterTermsAndCooc
CLI.Import
CLI.Init
CLI.Invitations
CLI.ObfuscateDB
CLI.Phylo
CLI.Phylo.Common
CLI.Phylo.Profile
CLI.Types
CLI.Upgrade
CLI.Utils
Paths_gargantext
hs-source-dirs:
bin/gargantext-cli
build-depends:
aeson ^>= 1.5.6.0
, async ^>= 2.2.4
, bytestring ^>= 0.10.12.0
, cassava ^>= 0.5.2.0
, containers ^>= 0.6.5.1
, extra ^>= 1.7.9
, full-text-search ^>= 0.2.1.4
, gargantext
, gargantext-prelude
, ini ^>= 0.4.1
, optparse-generic ^>= 1.4.7
, protolude ^>= 0.3.3
, split ^>= 0.2.3.4
, text ^>= 1.2.4.1
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.12.3.0
executable gargantext-db-obfuscation
import:
defaults
, optimized
main-is: Main.hs
other-modules:
Paths_gargantext
hs-source-dirs:
bin/gargantext-db-obfuscation
if flag(disable-db-obfuscation-executable)
buildable: False
else
build-depends:
extra
, gargantext
, gargantext-prelude
, optparse-simple
, postgresql-simple ^>= 0.6.4
, text
executable gargantext-import
import:
defaults
, optimized
main-is: Main.hs
default-extensions:
TypeOperators
other-modules:
Paths_gargantext
hs-source-dirs:
bin/gargantext-import
build-depends:
extra ^>= 1.7.9
, gargantext
, gargantext-prelude
, servant-server ^>= 0.18.3
, text ^>= 1.2.4.1
executable gargantext-init
import:
defaults
, optimized
main-is: Main.hs
other-modules:
Paths_gargantext
hs-source-dirs:
bin/gargantext-init
build-depends:
cron ^>= 0.7.0
, extra ^>= 1.7.9
, gargantext
, gargantext-prelude
, text ^>= 1.2.4.1
executable gargantext-invitations
import:
defaults
, optimized
main-is: Main.hs
other-modules:
Paths_gargantext
hs-source-dirs:
bin/gargantext-invitations
build-depends:
extra ^>= 1.7.9
, gargantext
, gargantext-prelude
, text ^>= 1.2.4.1
executable gargantext-phylo
import:
defaults
, optimized
main-is: Main.hs
other-modules:
Paths_gargantext
Common
hs-source-dirs:
bin/gargantext-phylo bin/gargantext-phylo/Phylo
default-extensions:
DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances
GADTs
GeneralizedNewtypeDeriving
ImportQualifiedPost
MultiParamTypeClasses
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
RankNTypes
RecordWildCards
StrictData
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -Wmissing-signatures
build-depends:
aeson ^>= 1.5.6.0
, async ^>= 2.2.4
......@@ -850,14 +744,20 @@ executable gargantext-phylo
, cryptohash ^>= 0.11.9
, directory ^>= 1.3.6.0
, extra ^>= 1.7.9
, full-text-search ^>= 0.2.1.4
, gargantext
, gargantext-prelude
, ini ^>= 0.4.1
, optparse-applicative
, optparse-generic ^>= 1.4.7
, parallel ^>= 3.2.2.0
, postgresql-simple ^>= 0.6.4
, protolude ^>= 0.3.3
, shelly
, split ^>= 0.2.3.4
, text ^>= 1.2.4.1
, time ^>= 1.9.3
, tree-diff
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3
......@@ -883,23 +783,6 @@ executable gargantext-server
, text ^>= 1.2.4.1
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3
executable gargantext-upgrade
import:
defaults
, optimized
main-is: Main.hs
other-modules:
Paths_gargantext
hs-source-dirs:
bin/gargantext-upgrade
build-depends:
cron ^>= 0.7.0
, extra ^>= 1.7.9
, gargantext
, gargantext-prelude
, postgresql-simple ^>= 0.6.4
, text ^>= 1.2.4.1
executable gargantext-central-exchange
import:
......@@ -929,7 +812,7 @@ test-suite garg-test-tasty
main-is: drivers/tasty/Main.hs
other-modules:
Test.API.Routes
Common
CLI.Phylo.Common
Test.API.Setup
Test.Core.AsyncUpdates
Test.Core.Similarity
......@@ -966,7 +849,7 @@ test-suite garg-test-tasty
Test.Utils.Jobs
Paths_gargantext
hs-source-dirs:
test bin/gargantext-phylo/Phylo
test bin/gargantext-cli
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends:
QuickCheck ^>= 2.14.2
......@@ -1150,39 +1033,3 @@ benchmark garg-bench
ghc-options: "-with-rtsopts=-T -A32m"
if impl(ghc >= 8.6)
ghc-options: "-with-rtsopts=--nonmoving-gc"
executable gargantext-phylo-profile
main-is: Main.hs
other-modules:
Paths_gargantext
Common
hs-source-dirs:
bin/gargantext-phylo-profile bin/gargantext-phylo/Phylo
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -Wmissing-signatures
build-depends:
base
, bytestring
, gargantext
, gargantext-prelude
, shelly
, text
, async
, cryptohash
, aeson
, split
, vector
, directory
default-language: GHC2021
executable garg-golden-file-diff
import:
defaults
, optimized
main-is: Main.hs
hs-source-dirs:
bin/gargantext-golden-file-diff
build-depends:
base
, text
, tree-diff
default-language: Haskell2010
src/Gargantext/API.hs
View file @ 1f747d2e
......@@ -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,14 +46,16 @@ 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.Core.AsyncUpdates.Constants qualified as AUConstants
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)
......@@ -69,12 +72,17 @@ import System.Cron.Schedule qualified as Cron
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`
......@@ -85,17 +93,18 @@ 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 $ " - Central exchange.........................: " <> "nanomsg: " <> pack AUConstants.ceBind
putStrLn $ " - Dispatcher internal......................: " <> "nanomsg: " <> pack AUConstants.dispatcherBind
putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece port <> "/ws"
putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
putStrLn "=========================================================================================================="
-- | Stops the gargantext server and cancels all the periodic actions
......
src/Gargantext/API/Admin/EnvTypes.hs
View file @ 1f747d2e
......@@ -12,6 +12,7 @@ module Gargantext.API.Admin.EnvTypes (
, mkJobHandle
, env_logger
, env_manager
, env_settings
, env_self_url
, env_central_exchange
, env_dispatcher
......@@ -45,8 +46,8 @@ import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Prelude.Mail.Types (MailConfig)
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config.Mail (MailConfig)
import Gargantext.System.Logging
import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
import Gargantext.Utils.Jobs.Monad qualified as Jobs
......@@ -289,6 +290,9 @@ data DevEnv = DevEnv
makeLenses ''DevEnv
instance CET.HasCentralExchangeNotification DevEnv where
ce_notify m = liftBase $ CE.notify m
-- | Our /mock/ job handle.
data DevJobHandle = DevJobHandle
......
src/Gargantext/API/Admin/Settings.hs
View file @ 1f747d2e
......@@ -27,19 +27,19 @@ import Data.Pool (Pool)
import Data.Pool qualified 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
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D
import Gargantext.Core.Config (gc_js_job_timeout, gc_js_id_timeout, readConfig)
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.Core.NLP (nlpServerMap)
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (databaseParameters, hasConfig)
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_js_job_timeout, gc_js_id_timeout, readConfig)
import Gargantext.Prelude.Mail qualified as Mail
import Gargantext.Prelude.NLP qualified as NLP
import Gargantext.System.Logging
import Gargantext.Utils.Jobs qualified as Jobs
import Gargantext.Utils.Jobs.Monad qualified as Jobs
......@@ -59,9 +59,10 @@ 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 @ 1f747d2e
......@@ -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 @ 1f747d2e
{-# 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.Core.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 @ 1f747d2e
{-# 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 @ 1f747d2e
......@@ -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/Auth/PolicyCheck.hs
View file @ 1f747d2e
......@@ -31,7 +31,7 @@ import Gargantext.Database.Prelude (DBCmd, HasConfig (..))
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Tree
import Gargantext.Database.Query.Tree.Root
import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Core.Config (GargConfig(..))
import Prelude
import Servant
import Servant.Auth.Server.Internal.AddSetCookie
......
src/Gargantext/API/Dev.hs
View file @ 1f747d2e
......@@ -24,9 +24,9 @@ import Gargantext.Core.NLP (nlpServerMap)
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Database.Prelude (Cmd', Cmd'', connPool, databaseParameters, runCmd)
import Gargantext.Prelude
import Gargantext.Prelude.Config (readConfig)
import Gargantext.Prelude.Mail qualified as Mail
import Gargantext.Prelude.NLP qualified as NLP
import Gargantext.Core.Config (readConfig)
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.System.Logging ( withLoggerHoisted )
import Servant ( ServerError )
......
src/Gargantext/API/GraphQL/Context.hs
View file @ 1f747d2e
......@@ -22,7 +22,8 @@ import Data.Morpheus.Types
, ResolverM
, QUERY
)
import Data.Text (pack)
import Data.Text (pack, unpack)
import qualified Data.Text as Text
import Data.Time.Format.ISO8601 (iso8601Show)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Errors.Types ( BackendInternalError )
......@@ -94,6 +95,7 @@ data ContextsForNgramsArgs
= ContextsForNgramsArgs
{ corpus_id :: Int
, ngrams_terms :: [Text]
, and_logic :: Text
} deriving (Generic, GQLType)
data NodeContextCategoryMArgs = NodeContextCategoryMArgs
......@@ -123,8 +125,8 @@ resolveNodeContext NodeContextArgs { context_id, node_id } =
resolveContextsForNgrams
:: (CmdCommon env)
=> ContextsForNgramsArgs -> GqlM e env [ContextGQL]
resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms } =
dbContextForNgrams corpus_id ngrams_terms
resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms, and_logic } =
dbContextForNgrams corpus_id ngrams_terms and_logic
resolveContextNgrams
:: (CmdCommon env)
......@@ -149,9 +151,9 @@ dbNodeContext context_id node_id = do
-- | Returns list of `ContextGQL` for given ngrams in given corpus id.
dbContextForNgrams
:: (CmdCommon env)
=> Int -> [Text] -> GqlM e env [ContextGQL]
dbContextForNgrams node_id ngrams_terms = do
contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms
=> Int -> [Text] -> Text -> GqlM e env [ContextGQL]
dbContextForNgrams node_id ngrams_terms and_logic = do
contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms ( readMaybe $ unpack $ Text.toTitle and_logic )
--lift $ printDebug "[dbContextForNgrams] contextsForNgramsTerms" contextsForNgramsTerms
pure $ toContextGQL <$> contextsForNgramsTerms
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ 1f747d2e
......@@ -57,7 +57,7 @@ import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusIds))
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_max_docs_parsers)
import Gargantext.Core.Config (gc_max_docs_parsers)
import Gargantext.System.Logging ( logLocM, LogLevel(..) )
import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
import Test.QuickCheck.Arbitrary (Arbitrary(..))
......@@ -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 @ 1f747d2e
......@@ -43,11 +43,12 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Tree.Error (HasTreeError)
import Gargantext.Database.Query.Tree.Root (getOrMkRootWithCorpus, MkCorpusUser (MkCorpusUserMaster))
import Gargantext.Prelude hiding (All)
import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Core.Config (GargConfig(..))
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 @ 1f747d2e
......@@ -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 @ 1f747d2e
......@@ -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 @ 1f747d2e
......@@ -32,19 +32,20 @@ import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CE
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, CE.HasCentralExchangeNotification 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
nodeIds <- mkNodeWithParent nt (Just pId) userId nodeName
......@@ -64,7 +65,7 @@ postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ AsyncJobs $
serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync authenticatedUser nId p jHandle
------------------------------------------------------------------------
postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m, CE.HasCentralExchangeNotification env)
postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m, HasSettings env, CE.HasCentralExchangeNotification env)
=> AuthenticatedUser
-- ^ The logged in user
-> NodeId
......
src/Gargantext/API/Node/Share.hs
View file @ 1f747d2e
......@@ -33,6 +33,7 @@ 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
......@@ -41,6 +42,7 @@ import Servant.Server.Generic (AsServerT)
api :: ( HasNodeError err
, HasNLPServer env
, CmdRandom env err m
, HasSettings env
, HasCentralExchangeNotification env )
=> User
-> NodeId
......
src/Gargantext/API/Node/ShareURL.hs
View file @ 1f747d2e
......@@ -9,7 +9,7 @@ import Gargantext.API.Prelude
import Gargantext.Core.Types (NodeType, NodeId, unNodeId)
import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
import Control.Lens.Getter (view)
import Gargantext.Prelude.Config (gc_url)
import Gargantext.Core.Config (gc_url)
import Gargantext.API.Routes.Named.Share qualified as Named
import Servant.Server.Generic (AsServerT)
......
src/Gargantext/API/Routes.hs
View file @ 1f747d2e
......@@ -34,7 +34,7 @@ import Gargantext.API.Routes.Named.Corpus qualified as Named
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_max_docs_scrapers)
import Gargantext.Core.Config (gc_max_docs_scrapers)
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Servant
import Servant.Auth.Swagger ()
......
src/Gargantext/API/Routes/Named/Private.hs
View file @ 1f747d2e
......@@ -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 @ 1f747d2e
......@@ -25,22 +25,22 @@ import Gargantext.API.ThrowAll (serverPrivateGargAPI)
import Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket qualified as Dispatcher
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude hiding (Handler, catch)
import Gargantext.Prelude.Config (gc_url_backend_api)
import Gargantext.Core.Config (gc_url_backend_api)
import Gargantext.System.Logging (logLocM, LogLevel(..))
import Paths_gargantext qualified as PG -- cabal magic build module
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))
......@@ -55,7 +55,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 @ 1f747d2e
{-# 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/Config.hs 0 → 100644
View file @ 1f747d2e
{-|
Module : Gargantext.Core.Config
Description : Textmining Collaborative Platform
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Configuration for the gargantext server
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Config (
-- * Types
GargConfig(..)
-- * Lenses
, gc_backend_name
, gc_datafilepath
, gc_epo_api_url
, gc_frame_calc_url
, gc_frame_istex_url
, gc_frame_searx_url
, gc_frame_visio_url
, gc_frame_write_url
, gc_js_id_timeout
, gc_js_job_timeout
, gc_masteruser
, gc_max_docs_parsers
, gc_max_docs_scrapers
, gc_pubmed_api_key
, gc_repofilepath
, gc_secretkey
, gc_url
, gc_url_backend_api
-- * Utility functions
, readIniFile'
, readConfig
, val
) where
import Data.Ini (readIniFile, lookupValue, Ini)
import Data.Text as T
import Prelude (read)
import Gargantext.Prelude
-- | strip a given character from end of string
stripRight :: Char -> T.Text -> T.Text
stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s
data GargConfig = GargConfig { _gc_backend_name :: !T.Text
, _gc_url :: !T.Text
, _gc_url_backend_api :: !T.Text
, _gc_masteruser :: !T.Text
, _gc_secretkey :: !T.Text
, _gc_datafilepath :: !FilePath
, _gc_repofilepath :: !FilePath
, _gc_frame_write_url :: !T.Text
, _gc_frame_calc_url :: !T.Text
, _gc_frame_visio_url :: !T.Text
, _gc_frame_searx_url :: !T.Text
, _gc_frame_istex_url :: !T.Text
, _gc_max_docs_parsers :: !Integer
, _gc_max_docs_scrapers :: !Integer
, _gc_pubmed_api_key :: !T.Text
, _gc_js_job_timeout :: !Integer
, _gc_js_id_timeout :: !Integer
, _gc_epo_api_url :: !T.Text
}
deriving (Generic, Show)
makeLenses ''GargConfig
readIniFile' :: FilePath -> IO Ini
readIniFile' fp = do
ini <- readIniFile fp
case ini of
Left e -> panicTrace $ T.pack $ "ini file not found " <> show e
Right ini' -> pure ini'
val :: Ini -> Text -> Text -> Text
val ini section key = do
case (lookupValue section key ini) of
Left e -> panicTrace $ "ERROR: add " <> key <> " in section \"" <> section <> "\" to your gargantext.ini. " <> show e
Right p' -> p'
readConfig :: FilePath -> IO GargConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini "gargantext"
pure $ GargConfig
{ _gc_backend_name = cs $ val' "BACKEND_NAME"
, _gc_url = stripRight '/' $ val' "URL"
, _gc_url_backend_api = stripRight '/' $ val' "URL_BACKEND_API"
, _gc_masteruser = val' "MASTER_USER"
, _gc_secretkey = val' "SECRET_KEY"
, _gc_datafilepath = cs $ val' "DATA_FILEPATH"
, _gc_repofilepath = cs $ val' "REPO_FILEPATH"
, _gc_frame_write_url = stripRight '/' $ val' "FRAME_WRITE_URL"
, _gc_frame_calc_url = stripRight '/' $ val' "FRAME_CALC_URL"
, _gc_frame_visio_url = stripRight '/' $ val' "FRAME_VISIO_URL"
, _gc_frame_searx_url = stripRight '/' $ val' "FRAME_SEARX_URL"
, _gc_frame_istex_url = stripRight '/' $ val' "FRAME_ISTEX_URL"
, _gc_max_docs_parsers = read $ cs $ val' "MAX_DOCS_PARSERS"
, _gc_max_docs_scrapers = read $ cs $ val' "MAX_DOCS_SCRAPERS"
, _gc_pubmed_api_key = val' "PUBMED_API_KEY"
, _gc_js_job_timeout = read $ cs $ val' "JS_JOB_TIMEOUT"
, _gc_js_id_timeout = read $ cs $ val' "JS_ID_TIMEOUT"
, _gc_epo_api_url = cs $ val' "EPO_API_URL"
}
src/Gargantext/Core/Config/Mail.hs 0 → 100644
View file @ 1f747d2e
{-|
Module : Gargantext.Core.Config.Mail
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Config.Mail (
-- * Types
GargMail(..)
, LoginType(..)
, MailConfig(..)
-- * Utility functions
, gargMail
, readConfig
-- * Lenses
, mc_mail_from
, mc_mail_host
, mc_mail_login_type
, mc_mail_password
, mc_mail_port
, mc_mail_user
)
where
import Data.Maybe
import Data.Text (unpack)
import Data.Text qualified as T
import Gargantext.Core.Config (readIniFile', val)
import Gargantext.Prelude
import Network.Mail.Mime (plainPart)
import Network.Mail.SMTP hiding (htmlPart, STARTTLS)
import Network.Socket (PortNumber)
import Prelude (read)
type Email = Text
type Name = Text
data LoginType = NoAuth | Normal | SSL | TLS | STARTTLS
deriving (Generic, Eq, Show, Read)
data MailConfig = MailConfig { _mc_mail_host :: !T.Text
, _mc_mail_port :: !PortNumber
, _mc_mail_user :: !T.Text
, _mc_mail_password :: !T.Text
, _mc_mail_login_type :: !LoginType
, _mc_mail_from :: !T.Text
}
deriving (Generic, Show)
readConfig :: FilePath -> IO MailConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini "mail"
pure $ MailConfig { _mc_mail_host = cs $ val' "MAIL_HOST"
, _mc_mail_port = read $ cs $ val' "MAIL_PORT"
, _mc_mail_user = cs $ val' "MAIL_USER"
, _mc_mail_from = cs $ val' "MAIL_FROM"
, _mc_mail_password = cs $ val' "MAIL_PASSWORD"
, _mc_mail_login_type = read $ cs $ val' "MAIL_LOGIN_TYPE"
}
data GargMail = GargMail { gm_to :: Email
, gm_name :: Maybe Name
, gm_subject :: Text
, gm_body :: Text
}
-- | TODO add parameters to gargantext.ini
gargMail :: MailConfig -> GargMail -> IO ()
gargMail (MailConfig {..}) (GargMail { .. }) = do
let host = unpack _mc_mail_host
user = unpack _mc_mail_user
password = unpack _mc_mail_password
case _mc_mail_login_type of
NoAuth -> sendMail host mail
Normal -> sendMailWithLogin' host _mc_mail_port user password mail
SSL -> sendMailWithLoginTLS' host _mc_mail_port user password mail
TLS -> sendMailWithLoginTLS' host _mc_mail_port user password mail
STARTTLS -> sendMailWithLoginSTARTTLS' host _mc_mail_port user password mail
where
mail = simpleMail sender receiver cc bcc gm_subject [plainPart $ cs gm_body]
sender = Address (Just "GarganText Email") _mc_mail_from
receiver = [Address gm_name gm_to]
cc = []
bcc = []
makeLenses ''MailConfig
src/Gargantext/Core/Config/NLP.hs 0 → 100644
View file @ 1f747d2e
{-|
Module : Gargantext.Core.Config.NLP
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Config.NLP (
-- * Types
NLPConfig(..)
-- * Utility functions
, readConfig
-- * Lenses
, nlp_default
, nlp_languages
)
where
import Data.Ini qualified as Ini
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Text qualified as T
import Gargantext.Core.Config (readIniFile', val)
import Gargantext.Prelude
import Gargantext.Prelude.Utils (listToMaybeAll)
import Network.URI (URI)
import Network.URI (parseURI)
data NLPConfig = NLPConfig { _nlp_default :: URI
, _nlp_languages :: (Map.Map T.Text URI) }
deriving (Generic, Show)
iniSection :: Text
iniSection = "nlp"
readConfig :: FilePath -> IO NLPConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini iniSection
let lang_default_text = "EN" -- Change this value by one of your choice: "All", "FR", or "EN"
let m_nlp_default = parseURI $ cs $ val' lang_default_text
let m_nlp_keys = filter (\k -> k `notElem` [lang_default_text]) $ fromRight [] $ Ini.keys iniSection ini
let m_nlp_other = listToMaybeAll $ (\k -> (,) k <$> (parseURI $ cs $ val' k)) <$> m_nlp_keys
let mRet = NLPConfig <$> m_nlp_default <*> (Map.fromList <$> m_nlp_other)
case mRet of
Nothing -> panicTrace $ T.concat [ "Cannot read config file: _nlp_default = "
, T.pack $ show m_nlp_default
, ", _nlp_other = "
, T.pack $ show m_nlp_other ]
Just ret -> pure ret
makeLenses ''NLPConfig
src/Gargantext/Core/Mail.hs
View file @ 1f747d2e
......@@ -19,9 +19,8 @@ import Gargantext.Core.Types.Individu
import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Database.Schema.User (UserLight(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_url, gc_backend_name)
import Gargantext.Prelude.Mail (gargMail, GargMail(..))
import Gargantext.Prelude.Mail.Types (MailConfig)
import Gargantext.Core.Config (gc_url, gc_backend_name)
import Gargantext.Core.Config.Mail (gargMail, GargMail(..), MailConfig)
import Network.URI.Encode (encodeText)
......
src/Gargantext/Core/Mail/Types.hs
View file @ 1f747d2e
......@@ -12,7 +12,7 @@ Portability : POSIX
module Gargantext.Core.Mail.Types where
import Control.Lens (Getter)
import Gargantext.Prelude.Mail.Types (MailConfig)
import Gargantext.Core.Config.Mail (MailConfig)
class HasMail env where
mailSettings :: Getter env MailConfig
src/Gargantext/Core/NLP.hs
View file @ 1f747d2e
......@@ -11,12 +11,12 @@ Portability : POSIX
module Gargantext.Core.NLP where
import Control.Lens (Getter, at, non)
import qualified Data.Map.Strict as Map
import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust)
import Network.URI (URI(..), parseURI)
import Gargantext.Core (Lang(..), NLPServerConfig(..), PosTagAlgo(..), allLangs)
import Gargantext.Prelude.NLP.Types (NLPConfig(..))
import Gargantext.Core.Config.NLP (NLPConfig(..))
import Gargantext.Utils.Tuple (uncurryMaybeSecond)
import Network.URI (URI(..), parseURI)
import Protolude hiding (All)
......
src/Gargantext/Core/NodeStoryFile.hs.old
View file @ 1f747d2e
......@@ -27,7 +27,7 @@ import Gargantext.Core.Types (ListId, NodeId(..))
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_repofilepath)
import Gargantext.Core.Config (gc_repofilepath)
import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
import System.IO (hClose)
import System.IO.Temp (withTempFile)
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 1f747d2e
......@@ -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/Core/Viz/Phylo.hs
View file @ 1f747d2e
......@@ -45,6 +45,8 @@ data CorpusParser =
Wos {_wos_limit :: Int}
| Tsv {_tsv_limit :: Int}
| Tsv' {_tsv'_limit :: Int}
| Csv {_csv_limit :: Int}
| Csv' {_csv'_limit :: Int}
deriving (Show,Generic,Eq, ToExpr)
instance ToSchema CorpusParser where
......@@ -727,6 +729,8 @@ instance Arbitrary CorpusParser where
arbitrary = oneof [ Wos <$> arbitrary
, Tsv <$> arbitrary
, Tsv' <$> arbitrary
, Csv <$> arbitrary
, Csv' <$> arbitrary
]
instance Arbitrary ListParser where
......
src/Gargantext/Database/Action/Flow.hs
View file @ 1f747d2e
......@@ -91,7 +91,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)
......@@ -103,7 +103,7 @@ import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..), getOrMkRoot, getOr
import Gargantext.Database.Schema.Ngrams ( indexNgrams, text2ngrams )
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude hiding (to)
import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.System.Logging ( logLocM, LogLevel(DEBUG), MonadLogger )
import Gargantext.Utils.Jobs.Monad ( JobHandle, MonadJobStatus(..) )
import PUBMED.Types qualified as PUBMED
......@@ -111,6 +111,7 @@ import PUBMED.Types qualified as PUBMED
------------------------------------------------------------------------
-- Imports for upgrade function
import Gargantext.Database.Query.Tree.Error ( HasTreeError )
import Gargantext.API.Admin.Types (HasSettings)
------------------------------------------------------------------------
......@@ -127,14 +128,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
......@@ -144,12 +145,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
......@@ -166,6 +167,7 @@ flowDataText :: forall env err m.
, HasTreeError err
, HasValidationError err
, MonadJobStatus m
, HasSettings env
, HasCentralExchangeNotification env
)
=> User
......@@ -196,6 +198,7 @@ flowAnnuaire :: ( DbCmd' env err m
, HasTreeError err
, HasValidationError err
, MonadJobStatus m
, HasSettings env
, HasCentralExchangeNotification env )
=> MkCorpusUser
-> TermType Lang
......@@ -215,6 +218,7 @@ flowCorpusFile :: ( DbCmd' env err m
, HasTreeError err
, HasValidationError err
, MonadJobStatus m
, HasSettings env
, HasCentralExchangeNotification env )
=> MkCorpusUser
-> Limit -- Limit the number of docs (for dev purpose)
......@@ -245,6 +249,7 @@ flowCorpus :: ( DbCmd' env err m
, HasValidationError err
, FlowCorpus a
, MonadJobStatus m
, HasSettings env
, HasCentralExchangeNotification env )
=> MkCorpusUser
-> TermType Lang
......@@ -265,6 +270,7 @@ flow :: forall env err m a c.
, FlowCorpus a
, MkCorpus c
, MonadJobStatus m
, HasSettings env
, HasCentralExchangeNotification env
)
=> Maybe c
......@@ -302,6 +308,7 @@ addDocumentsToHyperCorpus :: ( DbCmd' env err m
, HasNodeError err
, FlowCorpus document
, MkCorpus corpus
, HasSettings env
)
=> NLPServerConfig
-> Maybe corpus
......@@ -315,7 +322,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
, HasCentralExchangeNotification env
)
......@@ -348,6 +355,7 @@ flowCorpusUser :: ( HasNodeError err
, HasTreeError err
, HasNodeStory env err m
, MkCorpus c
, HasSettings env
)
=> Lang
-> User
......@@ -377,6 +385,7 @@ buildSocialList :: ( HasNodeError err
, HasTreeError err
, HasNodeStory env err m
, MkCorpus c
, HasSettings env
)
=> Lang
-> User
......@@ -412,6 +421,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 @ 1f747d2e
......@@ -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.Core.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 @ 1f747d2e
......@@ -29,23 +29,24 @@ 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
import Gargantext.Prelude.Crypto.Pass.User (gargPass)
import Gargantext.Prelude.Mail.Types (MailConfig)
import Gargantext.Core.Config.Mail (MailConfig)
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/GargDB.hs
View file @ 1f747d2e
......@@ -20,7 +20,7 @@ import Data.Text qualified as Text
import Data.Tuple.Extra (both)
import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Prelude hiding (hash)
import Gargantext.Prelude.Config ( gc_datafilepath )
import Gargantext.Core.Config ( gc_datafilepath )
import Gargantext.Prelude.Crypto.Hash ( IsHashable(hash) )
import Prelude qualified
import System.Directory (createDirectoryIfMissing)
......
src/Gargantext/Database/Prelude.hs
View file @ 1f747d2e
......@@ -33,7 +33,7 @@ import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(), readIniFile', val)
import Gargantext.Core.Config (GargConfig, readIniFile', val)
import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields)
import Opaleye.Aggregate (countRows)
import Opaleye.Internal.Constant qualified
......@@ -97,11 +97,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/Table/NodeContext.hs
View file @ 1f747d2e
......@@ -152,8 +152,53 @@ data ContextForNgramsTerms =
getContextsForNgramsTerms :: HasNodeError err
=> NodeId
-> [Text]
-> Maybe Bool
-> DBCmd err [ContextForNgramsTerms]
getContextsForNgramsTerms cId ngramsTerms = do
getContextsForNgramsTerms cId ngramsTerms (Just True) = do
let terms_length = length ngramsTerms
res <- runPGSQuery query (cId, PGS.In ngramsTerms, terms_length)
pure $ (\( _cfnt_nodeId
, _cfnt_hash
, _cfnt_nodeTypeId
, _cfnt_userId
, _cfnt_parentId
, _cfnt_c_title
, _cfnt_date
, _cfnt_hyperdata
, _cfnt_score
, _cfnt_category) -> ContextForNgramsTerms { .. }) <$> res
where
query :: PGS.Query
query = [sql| SELECT t.id, t.hash_id, t.typename, t.user_id, t.parent_id, t.name, t.date, t.hyperdata, t.score, t.category
FROM (
SELECT DISTINCT ON (contexts.id)
contexts.id AS id,
hash_id,
typename,
user_id,
parent_id,
name,
date,
hyperdata,
nodes_contexts.score AS score,
nodes_contexts.category AS category --,
-- context_node_ngrams.doc_count AS doc_count
FROM contexts
JOIN context_node_ngrams ON contexts.id = context_node_ngrams.context_id
JOIN nodes_contexts ON contexts.id = nodes_contexts.context_id
JOIN ngrams ON context_node_ngrams.ngrams_id = ngrams.id
WHERE nodes_contexts.node_id = ?
AND ngrams.terms IN ?
GROUP BY
contexts.id,
nodes_contexts.score,
nodes_contexts.category
HAVING COUNT(DISTINCT ngrams.terms) = ?) t
-- ORDER BY t.doc_count DESC
ORDER BY t.score DESC
|]
getContextsForNgramsTerms cId ngramsTerms _ = do
res <- runPGSQuery query (cId, PGS.In ngramsTerms)
pure $ (\( _cfnt_nodeId
, _cfnt_hash
......
src/Gargantext/Database/Query/Tree/Root.hs
View file @ 1f747d2e
......@@ -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 @ 1f747d2e
This diff is collapsed.
stack.yaml
View file @ 1f747d2e
......@@ -64,6 +64,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:
......@@ -124,7 +128,7 @@
git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git"
subdirs:
- .
- commit: b99b9e568c8bdc73af2b8016ed03ba5ee83c2030
- commit: 3a7d039e07c8564e8ff84ef88480924d18aa5018
git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git"
subdirs:
- .
......@@ -148,7 +152,7 @@
git: "https://gitlab.iscpif.fr/gargantext/gargantext-graph.git"
subdirs:
- .
- commit: d4f9bee483d41bbdf8ab4e09efb5a5a8216edff4
- commit: bb15d828d5ef36eeaa84cccb00598b585048c88e
git: "https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude"
subdirs:
- .
......@@ -314,7 +318,6 @@ flags:
"full-text-search":
"build-search-demo": false
gargantext:
"disable-db-obfuscation-executable": false
"no-phylo-debug-logs": false
"test-crypto": false
"ghc-lib-parser":
......
test-data/phylo/cleopatre.golden.csv.json 0 → 100644
View file @ 1f747d2e
This diff is collapsed.
test/Test/API/Setup.hs
View file @ 1f747d2e
......@@ -28,9 +28,9 @@ import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
import Gargantext.Prelude.Config
import Gargantext.Prelude.Mail qualified as Mail
import Gargantext.Prelude.NLP qualified as NLP
import Gargantext.Core.Config
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.System.Logging
import Gargantext.Utils.Jobs qualified as Jobs
import Gargantext.Utils.Jobs.Monad qualified as Jobs
......
test/Test/API/UpdateList.hs
View file @ 1f747d2e
......@@ -189,7 +189,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
describe "POST /api/v1.0/lists/:id/csv/add/form/async (CSV)" $ do
it "parses CSV via ngramsListFromCSVData" $ \((_testEnv, _port), _app) -> do
simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/simple.csv")
simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/simple.tsv")
ngramsListFromTSVData simpleNgrams `shouldBe`
Right (Map.fromList [ (NgramsTerms, Versioned 0 $ Map.fromList [
(NgramsTerm "abelian group", NgramsRepoElement 1 MapTerm Nothing Nothing (MSet mempty))
......@@ -202,12 +202,12 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
withValidLogin port "alice" (GargPassword "alice") $ \token -> do
([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
-- Upload the CSV doc
simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/simple.csv")
simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/simple.tsv")
let tsvFileFormData = [ (T.pack "_wtf_data", simpleNgrams)
, ("_wtf_filetype", "CSV")
, ("_wtf_name", "simple.csv")
, ("_wtf_filetype", "TSV")
, ("_wtf_name", "simple.tsv")
]
let url = "/lists/" <> fromString (show $ _NodeId listId) <> "/csv/add/form/async"
let url = "/lists/" <> fromString (show $ _NodeId listId) <> "/tsv/add/form/async"
let mkPollUrl j = "/corpus/" <> fromString (show $ _NodeId listId) <> "/add/form/async/" +|_jph_id j|+ "/poll?limit=1"
(j :: JobPollHandle) <- postJSONUrlEncoded token (mkUrl port url) (urlEncodeFormStable $ toForm tsvFileFormData)
j' <- pollUntilFinished token port mkPollUrl j
......
test/Test/Database/Setup.hs
View file @ 1f747d2e
......@@ -15,9 +15,10 @@ 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
import Gargantext.Core.Config
import Gargantext.System.Logging (withLoggerHoisted)
import Paths_gargantext
import Prelude qualified
......@@ -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 @ 1f747d2e
......@@ -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(..))
......@@ -35,8 +36,8 @@ import Gargantext.Core.NLP (HasNLPServer(..))
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (HasConfig(..), HasConnectionPool(..))
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Prelude.Config
import Gargantext.Prelude.Mail.Types (MailConfig(..), LoginType(NoAuth))
import Gargantext.Core.Config
import Gargantext.Core.Config.Mail (MailConfig(..), LoginType(NoAuth))
import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..))
import Gargantext.Utils.Jobs
import Network.URI (parseURI)
......@@ -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
......
test/Test/Offline/Phylo.hs
View file @ 1f747d2e
......@@ -5,7 +5,7 @@
module Test.Offline.Phylo (tests) where
import Common
import CLI.Phylo.Common
import Data.Aeson as JSON
import Data.Aeson.Types qualified as JSON
import Data.GraphViz.Attributes.Complete qualified as Graphviz
......@@ -13,7 +13,7 @@ import Data.Text.Lazy as TL
import Data.TreeDiff
import Data.Vector qualified as V
import Gargantext.Core.Text.List.Formats.TSV
import Gargantext.Core.Types.Phylo
import Gargantext.Core.Types.Phylo hiding (Phylo(..))
import Gargantext.Core.Viz.Phylo hiding (EdgeType(..))
import Gargantext.Core.Viz.Phylo.API.Tools (readPhylo, phylo2dot2json)
import Gargantext.Core.Viz.Phylo.Example qualified as Cleopatre
......@@ -69,6 +69,7 @@ tests = testGroup "Phylo" [
, testGroup "relatedComponents" [
testCase "finds simple connection" testRelComp_Connected
]
, testCase "parses csv phylo" testCsvPhylo
]
testCleopatreWithoutLinkExpectedOutput :: Assertion
......@@ -248,3 +249,11 @@ testToPhyloDeterminism = do
let actual = setConfig phyloTestConfig $ toPhylo $ toPhyloWithoutLink corpus config
expected <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/187481.json")
assertBool ("Phylo mismatch! " <> show (ansiWlEditExprCompact $ ediff expected actual)) (expected == actual)
testCsvPhylo :: Assertion
testCsvPhylo = do
pth <- getDataFileName "test-data/phylo/cleopatre.golden.csv.json"
phyloJson <- eitherDecodeFileStrict' @Phylo pth
case phyloJson of
Left err -> error err
Right _ -> pure ()
test/Test/Offline/Stemming/Lancaster.hs
View file @ 1f747d2e
......@@ -8,15 +8,14 @@ import Data.Text qualified as T
import Gargantext.Core.Text.Terms.Mono.Stem.Internal.Lancaster (stem)
import Gargantext.Prelude (toS)
import Test.Tasty
import Test.Tasty.Golden (goldenVsStringDiff)
import Test.Tasty.Golden (goldenVsString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Encoding as TE
tests :: TestTree
tests = testGroup "Lancaster" [
goldenVsStringDiff "test vector works" (\ref new -> ["cabal", "v2-run", "-v0", "garg-golden-file-diff", "--", ref, new]) "test-data/stemming/lancaster.txt" mkTestVector
goldenVsString "test vector works" "test-data/stemming/lancaster.txt" mkTestVector
]
-- | List un /unstemmed/ test words
......
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