Commit 49436f17 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

Merge branch 'dev' into 86-dev-graphql

parents 133d581e 02a4c6df
...@@ -47,13 +47,13 @@ main = do ...@@ -47,13 +47,13 @@ main = do
tt = (Multi EN) tt = (Multi EN)
format = CsvGargV3 -- CsvHal --WOS format = CsvGargV3 -- CsvHal --WOS
corpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId corpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt format corpusPath Nothing corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt format corpusPath Nothing (\_ -> pure ())
corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath Nothing corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath Nothing (\_ -> pure ())
annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath (\_ -> pure ())
{- {-
let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
......
WITH repeated AS
( select nn.node2_id AS id, count(*) AS c
FROM nodes_nodes nn
GROUP BY nn.node2_id
)
DELETE FROM nodes n
USING repeated r
WHERE
n.id = r.id
AND r.c <= 1
;
WITH listed AS
( select nn.ngrams_id AS id, count(*) AS c
FROM node_node_ngrams nn
GROUP BY nn.ngrams_id
)
--SELECT count(*) from listed l
-- WHERE
--l.c <= 1
DELETE FROM ngrams n
USING listed l
WHERE
n.id = l.id
AND l.c <= 1
;
...@@ -67,3 +67,11 @@ DB_PASS = PASSWORD_TO_CHANGE ...@@ -67,3 +67,11 @@ DB_PASS = PASSWORD_TO_CHANGE
LOG_FILE = /var/log/gargantext/backend.log LOG_FILE = /var/log/gargantext/backend.log
LOG_LEVEL = LevelDebug LOG_LEVEL = LevelDebug
LOG_FORMATTER = verbose LOG_FORMATTER = verbose
[mail]
MAIL_PORT = 25
MAIL_HOST = localhost
MAIL_USER = gargantext
MAIL_PASSWORD =
# Normal | SSL | TLS | STARTTLS
MAIL_LOGIN_TYPE = Normal
name: gargantext name: gargantext
version: '0.0.4.6' version: '0.0.4.7.1'
synopsis: Search, map, share synopsis: Search, map, share
description: Please see README.md description: Please see README.md
category: Data category: Data
...@@ -371,19 +371,19 @@ executables: ...@@ -371,19 +371,19 @@ executables:
- gargantext-prelude - gargantext-prelude
- base - base
gargantext-upgrade: # gargantext-upgrade:
main: Main.hs # main: Main.hs
source-dirs: bin/gargantext-upgrade # source-dirs: bin/gargantext-upgrade
ghc-options: # ghc-options:
- -threaded # - -threaded
- -rtsopts # - -rtsopts
- -with-rtsopts=-N # - -with-rtsopts=-N
- -O2 # - -O2
- -Wmissing-signatures # - -Wmissing-signatures
dependencies: # dependencies:
- gargantext # - gargantext
- gargantext-prelude # - gargantext-prelude
- base # - base
gargantext-admin: gargantext-admin:
main: Main.hs main: Main.hs
...@@ -399,22 +399,23 @@ executables: ...@@ -399,22 +399,23 @@ executables:
- gargantext-prelude - gargantext-prelude
- base - base
gargantext-cbor2json:
main: Main.hs # gargantext-cbor2json:
source-dirs: bin/gargantext-cbor2json # main: Main.hs
ghc-options: # source-dirs: bin/gargantext-cbor2json
- -threaded # ghc-options:
- -rtsopts # - -threaded
- -with-rtsopts=-N # - -rtsopts
- -O2 # - -with-rtsopts=-N
- -Wmissing-signatures # - -O2
dependencies: # - -Wmissing-signatures
- gargantext # dependencies:
- gargantext-prelude # - gargantext
- base # - gargantext-prelude
- bytestring # - base
- aeson # - bytestring
- serialise # - aeson
# - serialise
tests: tests:
......
...@@ -20,6 +20,7 @@ TODO-ACCESS Critical ...@@ -20,6 +20,7 @@ TODO-ACCESS Critical
-} -}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Gargantext.API.Admin.Auth module Gargantext.API.Admin.Auth
...@@ -35,17 +36,18 @@ import Servant ...@@ -35,17 +36,18 @@ import Servant
import Servant.Auth.Server import Servant.Auth.Server
import qualified Gargantext.Prelude.Crypto.Auth as Auth import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.API.Admin.Types
import Gargantext.API.Admin.Auth.Types import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC) import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC)
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..)) import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
import Gargantext.Database.Query.Table.User
import Gargantext.Database.Query.Tree (isDescendantOf, isIn) import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
import Gargantext.Database.Query.Tree.Root (getRoot) import Gargantext.Database.Query.Tree.Root (getRoot)
import Gargantext.Database.Schema.Node (NodePoly(_node_id)) import Gargantext.Database.Schema.Node (NodePoly(_node_id))
import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
import Gargantext.Prelude hiding (reverse) import Gargantext.Prelude hiding (reverse)
import Gargantext.Database.Query.Table.User
--------------------------------------------------- ---------------------------------------------------
...@@ -60,7 +62,7 @@ makeTokenForUser uid = do ...@@ -60,7 +62,7 @@ makeTokenForUser uid = do
either joseError (pure . toStrict . decodeUtf8) e either joseError (pure . toStrict . decodeUtf8) e
-- TODO not sure about the encoding... -- TODO not sure about the encoding...
checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env) checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
=> Username => Username
-> GargPassword -> GargPassword
-> Cmd' env err CheckAuth -> Cmd' env err CheckAuth
...@@ -79,7 +81,7 @@ checkAuthRequest u (GargPassword p) = do ...@@ -79,7 +81,7 @@ checkAuthRequest u (GargPassword p) = do
token <- makeTokenForUser uid token <- makeTokenForUser uid
pure $ Valid token uid pure $ Valid token uid
auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env) auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
=> AuthRequest -> Cmd' env err AuthResponse => AuthRequest -> Cmd' env err AuthResponse
auth (AuthRequest u p) = do auth (AuthRequest u p) = do
checkAuthRequest' <- checkAuthRequest u p checkAuthRequest' <- checkAuthRequest u p
......
...@@ -14,24 +14,25 @@ import Servant.Job.Async (HasJobEnv(..), Job) ...@@ -14,24 +14,25 @@ import Servant.Job.Async (HasJobEnv(..), Job)
import System.Log.FastLogger import System.Log.FastLogger
import qualified Servant.Job.Core import qualified Servant.Job.Core
import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
import Gargantext.API.Admin.Types import Gargantext.API.Admin.Types
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..)) import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..)) import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Core.NodeStory import Gargantext.Prelude.Mail.Types (MailConfig)
data Env = Env data Env = Env
{ _env_settings :: !Settings { _env_settings :: !Settings
, _env_logger :: !LoggerSet , _env_logger :: !LoggerSet
, _env_pool :: !(Pool Connection) , _env_pool :: !(Pool Connection)
, _env_repo :: !RepoEnv
, _env_nodeStory :: !NodeStoryEnv , _env_nodeStory :: !NodeStoryEnv
, _env_manager :: !Manager , _env_manager :: !Manager
, _env_self_url :: !BaseUrl , _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv , _env_scrapers :: !ScrapersEnv
, _env_config :: !GargConfig , _env_config :: !GargConfig
, _env_mail :: !MailConfig
} }
deriving (Generic) deriving (Generic)
...@@ -55,15 +56,8 @@ instance HasNodeStorySaver Env where ...@@ -55,15 +56,8 @@ instance HasNodeStorySaver Env where
instance HasSettings Env where instance HasSettings Env where
settings = env_settings settings = env_settings
-- Specific to Repo instance HasMail Env where
instance HasRepoVar Env where mailSettings = env_mail
repoVar = repoEnv . repoVar
instance HasRepoSaver Env where
repoSaver = repoEnv . repoSaver
instance HasRepo Env where
repoEnv = env_repo
instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
...@@ -83,10 +77,10 @@ makeLenses ''MockEnv ...@@ -83,10 +77,10 @@ makeLenses ''MockEnv
data DevEnv = DevEnv data DevEnv = DevEnv
{ _dev_env_settings :: !Settings { _dev_env_settings :: !Settings
, _dev_env_repo :: !RepoEnv
, _dev_env_config :: !GargConfig , _dev_env_config :: !GargConfig
, _dev_env_pool :: !(Pool Connection) , _dev_env_pool :: !(Pool Connection)
, _dev_env_nodeStory :: !NodeStoryEnv , _dev_env_nodeStory :: !NodeStoryEnv
, _dev_env_mail :: !MailConfig
} }
makeLenses ''DevEnv makeLenses ''DevEnv
...@@ -110,12 +104,5 @@ instance HasNodeStoryVar DevEnv where ...@@ -110,12 +104,5 @@ instance HasNodeStoryVar DevEnv where
instance HasNodeStorySaver DevEnv where instance HasNodeStorySaver DevEnv where
hasNodeStorySaver = hasNodeStory . nse_saver hasNodeStorySaver = hasNodeStory . nse_saver
instance HasMail DevEnv where
instance HasRepoVar DevEnv where mailSettings = dev_env_mail
repoVar = repoEnv . repoVar
instance HasRepoSaver DevEnv where
repoSaver = repoEnv . repoSaver
instance HasRepo DevEnv where
repoEnv = dev_env_repo
...@@ -18,9 +18,8 @@ TODO-SECURITY: Critical ...@@ -18,9 +18,8 @@ TODO-SECURITY: Critical
module Gargantext.API.Admin.Settings module Gargantext.API.Admin.Settings
where where
import Codec.Serialise (Serialise(), serialise, deserialise) -- import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Control.Concurrent import Codec.Serialise (Serialise(), serialise)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Control.Lens import Control.Lens
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
...@@ -34,7 +33,7 @@ import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSe ...@@ -34,7 +33,7 @@ import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSe
import Servant.Client (parseBaseUrl) import Servant.Client (parseBaseUrl)
import Servant.Job.Async (newJobEnv, defaultSettings) import Servant.Job.Async (newJobEnv, defaultSettings)
import System.Directory import System.Directory
import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive)) -- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
import System.IO (FilePath, hClose) import System.IO (FilePath, hClose)
import System.IO.Temp (withTempFile) import System.IO.Temp (withTempFile)
import System.Log.FastLogger import System.Log.FastLogger
...@@ -43,10 +42,11 @@ import qualified Data.ByteString.Lazy as L ...@@ -43,10 +42,11 @@ import qualified Data.ByteString.Lazy as L
import Gargantext.API.Admin.EnvTypes import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Types import Gargantext.API.Admin.Types
import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock) -- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
import Gargantext.Database.Prelude (databaseParameters, HasConfig(..)) import Gargantext.Database.Prelude (databaseParameters)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_repofilepath) -- import Gargantext.Prelude.Config (gc_repofilepath)
import qualified Gargantext.Prelude.Mail as Mail
devSettings :: FilePath -> IO Settings devSettings :: FilePath -> IO Settings
devSettings jwkFile = do devSettings jwkFile = do
...@@ -113,7 +113,7 @@ repoSaverAction repoDir a = do ...@@ -113,7 +113,7 @@ repoSaverAction repoDir a = do
--{- {-
-- The use of mkDebounce makes sure that repoSaverAction is not called too often. -- The use of mkDebounce makes sure that repoSaverAction is not called too often.
-- If repoSaverAction start taking more time than the debounceFreq then it should -- If repoSaverAction start taking more time than the debounceFreq then it should
-- be increased. -- be increased.
...@@ -133,6 +133,8 @@ mkRepoSaver repoDir repo_var = mkDebounce settings' ...@@ -133,6 +133,8 @@ mkRepoSaver repoDir repo_var = mkDebounce settings'
-- Add a new MVar just for saving. -- Add a new MVar just for saving.
} }
-}
{-
readRepoEnv :: FilePath -> IO RepoEnv readRepoEnv :: FilePath -> IO RepoEnv
readRepoEnv repoDir = do readRepoEnv repoDir = do
-- Does file exist ? :: Bool -- Does file exist ? :: Bool
...@@ -178,27 +180,27 @@ newEnv port file = do ...@@ -178,27 +180,27 @@ newEnv port file = do
self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- databaseParameters file dbParam <- databaseParameters file
pool <- newPool dbParam pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath config_env)
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env) nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
scrapers_env <- newJobEnv defaultSettings manager_env scrapers_env <- newJobEnv defaultSettings manager_env
logger <- newStderrLoggerSet defaultBufSize logger <- newStderrLoggerSet defaultBufSize
config_mail <- Mail.readConfig file
pure $ Env pure $ Env
{ _env_settings = settings' { _env_settings = settings'
, _env_logger = logger , _env_logger = logger
, _env_pool = pool , _env_pool = pool
, _env_repo = repo
, _env_nodeStory = nodeStory_env , _env_nodeStory = nodeStory_env
, _env_manager = manager_env , _env_manager = manager_env
, _env_scrapers = scrapers_env , _env_scrapers = scrapers_env
, _env_self_url = self_url_env , _env_self_url = self_url_env
, _env_config = config_env , _env_config = config_env
, _env_mail = config_mail
} }
newPool :: ConnectInfo -> IO (Pool Connection) newPool :: ConnectInfo -> IO (Pool Connection)
newPool param = createPool (connect param) close 1 (60*60) 8 newPool param = createPool (connect param) close 1 (60*60) 8
--{- {-
cleanEnv :: (HasConfig env, HasRepo env) => env -> IO () cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
cleanEnv env = do cleanEnv env = do
r <- takeMVar (env ^. repoEnv . renv_var) r <- takeMVar (env ^. repoEnv . renv_var)
......
...@@ -23,6 +23,7 @@ import Gargantext.Core.NodeStory ...@@ -23,6 +23,7 @@ import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig) import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import qualified Gargantext.Prelude.Mail as Mail
import Servant import Servant
import System.IO (FilePath) import System.IO (FilePath)
...@@ -31,7 +32,7 @@ type IniPath = FilePath ...@@ -31,7 +32,7 @@ type IniPath = FilePath
withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
withDevEnv iniPath k = do withDevEnv iniPath k = do
env <- newDevEnv env <- newDevEnv
k env `finally` cleanEnv env k env -- `finally` cleanEnv env
where where
newDevEnv = do newDevEnv = do
...@@ -39,14 +40,14 @@ withDevEnv iniPath k = do ...@@ -39,14 +40,14 @@ withDevEnv iniPath k = do
dbParam <- databaseParameters iniPath dbParam <- databaseParameters iniPath
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg) nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath cfg)
setts <- devSettings devJwkFile setts <- devSettings devJwkFile
mail <- Mail.readConfig iniPath
pure $ DevEnv pure $ DevEnv
{ _dev_env_pool = pool { _dev_env_pool = pool
, _dev_env_repo = repo
, _dev_env_nodeStory = nodeStory_env , _dev_env_nodeStory = nodeStory_env
, _dev_env_settings = setts , _dev_env_settings = setts
, _dev_env_config = cfg , _dev_env_config = cfg
, _dev_env_mail = mail
} }
-- | Run Cmd Sugar for the Repl (GHCI) -- | Run Cmd Sugar for the Repl (GHCI)
......
...@@ -33,7 +33,6 @@ module Gargantext.API.Ngrams ...@@ -33,7 +33,6 @@ module Gargantext.API.Ngrams
, apiNgramsTableCorpus , apiNgramsTableCorpus
, apiNgramsTableDoc , apiNgramsTableDoc
, NgramsStatePatch
, NgramsTablePatch , NgramsTablePatch
, NgramsTableMap , NgramsTableMap
...@@ -52,15 +51,10 @@ module Gargantext.API.Ngrams ...@@ -52,15 +51,10 @@ module Gargantext.API.Ngrams
, r_version , r_version
, r_state , r_state
, r_history , r_history
, NgramsRepo
, NgramsRepoElement(..) , NgramsRepoElement(..)
, saveNodeStory , saveNodeStory
, initRepo , initRepo
, RepoEnv(..)
, renv_var
, renv_lock
, TabType(..) , TabType(..)
, QueryParamR , QueryParamR
...@@ -102,6 +96,7 @@ import Gargantext.API.Job ...@@ -102,6 +96,7 @@ import Gargantext.API.Job
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, TODO, assertValid, HasInvalidError) import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, TODO, assertValid, HasInvalidError)
import Gargantext.API.Ngrams.Tools import Gargantext.API.Ngrams.Tools
import Gargantext.Database.Action.Flow.Types import Gargantext.Database.Action.Flow.Types
...@@ -280,7 +275,7 @@ newNgramsFromNgramsStatePatch p = ...@@ -280,7 +275,7 @@ newNgramsFromNgramsStatePatch p =
commitStatePatch :: HasNodeStory env err m commitStatePatch :: (HasNodeStory env err m, HasMail env)
=> ListId => ListId
-> Versioned NgramsStatePatch' -> Versioned NgramsStatePatch'
-> m (Versioned NgramsStatePatch') -> m (Versioned NgramsStatePatch')
...@@ -346,8 +341,9 @@ tableNgramsPull listId ngramsType p_version = do ...@@ -346,8 +341,9 @@ tableNgramsPull listId ngramsType p_version = do
-- client. -- client.
-- TODO-ACCESS check -- TODO-ACCESS check
tableNgramsPut :: ( HasNodeStory env err m tableNgramsPut :: ( HasNodeStory env err m
, HasInvalidError err , HasInvalidError err
, HasSettings env , HasSettings env
, HasMail env
) )
=> TabType => TabType
-> ListId -> ListId
...@@ -494,7 +490,7 @@ type MaxSize = Int ...@@ -494,7 +490,7 @@ type MaxSize = Int
getTableNgrams :: forall env err m. getTableNgrams :: forall env err m.
(HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env) (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
=> NodeType -> NodeId -> TabType => NodeType -> NodeId -> TabType
-> ListId -> Limit -> Maybe Offset -> ListId -> Limit -> Maybe Offset
-> Maybe ListType -> Maybe ListType
...@@ -617,7 +613,7 @@ getTableNgrams _nType nId tabType listId limit_ offset ...@@ -617,7 +613,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
scoresRecomputeTableNgrams :: forall env err m. scoresRecomputeTableNgrams :: forall env err m.
(HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env) (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
=> NodeId -> TabType -> ListId -> m Int => NodeId -> TabType -> ListId -> m Int
scoresRecomputeTableNgrams nId tabType listId = do scoresRecomputeTableNgrams nId tabType listId = do
tableMap <- getNgramsTableMap listId ngramsType tableMap <- getNgramsTableMap listId ngramsType
...@@ -712,7 +708,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API" ...@@ -712,7 +708,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
:> "update" :> "update"
:> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env) getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
=> NodeId => NodeId
-> TabType -> TabType
-> ListId -> ListId
...@@ -746,7 +742,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId ...@@ -746,7 +742,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId
-- | Text search is deactivated for now for ngrams by doc only -- | Text search is deactivated for now for ngrams by doc only
getTableNgramsDoc :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env) getTableNgramsDoc :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
=> DocId -> TabType => DocId -> TabType
-> ListId -> Limit -> Maybe Offset -> ListId -> Limit -> Maybe Offset
-> Maybe ListType -> Maybe ListType
......
...@@ -35,12 +35,12 @@ mergeNgramsElement _neOld neNew = neNew ...@@ -35,12 +35,12 @@ mergeNgramsElement _neOld neNew = neNew
type RootTerm = NgramsTerm type RootTerm = NgramsTerm
{-
getRepo :: RepoCmdM env err m => m NgramsRepo getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo = do getRepo = do
v <- view repoVar v <- view repoVar
liftBase $ readMVar v liftBase $ readMVar v
-}
getRepo' :: HasNodeStory env err m getRepo' :: HasNodeStory env err m
=> [ListId] -> m NodeListStory => [ListId] -> m NodeListStory
......
...@@ -11,8 +11,7 @@ module Gargantext.API.Ngrams.Types where ...@@ -11,8 +11,7 @@ module Gargantext.API.Ngrams.Types where
import Codec.Serialise (Serialise()) import Codec.Serialise (Serialise())
import Control.Category ((>>>)) import Control.Category ((>>>))
import Control.Concurrent import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~), Getter)
import Control.Monad.State import Control.Monad.State
import Data.Aeson hiding ((.=)) import Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
...@@ -39,7 +38,7 @@ import Gargantext.Prelude.Crypto.Hash (IsHashable(..)) ...@@ -39,7 +38,7 @@ import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
import Protolude (maybeToEither) import Protolude (maybeToEither)
import Servant hiding (Patch) import Servant hiding (Patch)
import Servant.Job.Utils (jsonOptions) import Servant.Job.Utils (jsonOptions)
import System.FileLock (FileLock) -- import System.FileLock (FileLock)
import Test.QuickCheck (elements, frequency) import Test.QuickCheck (elements, frequency)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
...@@ -676,11 +675,6 @@ data Repo s p = Repo ...@@ -676,11 +675,6 @@ data Repo s p = Repo
} }
deriving (Generic, Show) deriving (Generic, Show)
-- | TO REMOVE
type NgramsRepo = Repo NgramsState NgramsStatePatch
type NgramsState = Map TableNgrams.NgramsType (Map NodeId NgramsTableMap)
type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
---------------------------------------------------------------------- ----------------------------------------------------------------------
instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
...@@ -697,52 +691,16 @@ makeLenses ''Repo ...@@ -697,52 +691,16 @@ makeLenses ''Repo
initRepo :: Monoid s => Repo s p initRepo :: Monoid s => Repo s p
initRepo = Repo 1 mempty [] initRepo = Repo 1 mempty []
instance Serialise (PM.PatchMap NodeId NgramsTablePatch)
instance Serialise NgramsStatePatch
initMockRepo :: NgramsRepo
initMockRepo = Repo 1 s []
where
s = Map.singleton TableNgrams.NgramsTerms
$ Map.singleton 47254
$ Map.fromList
[ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
-------------------- --------------------
data RepoEnv = RepoEnv
{ _renv_var :: !(MVar NgramsRepo)
, _renv_saver :: !(IO ())
, _renv_lock :: !FileLock
}
deriving (Generic)
makeLenses ''RepoEnv
type RepoCmdM env err m = type RepoCmdM env err m =
( CmdM' env err m ( CmdM' env err m
, HasRepo env
, HasConnectionPool env , HasConnectionPool env
, HasConfig env , HasConfig env
) )
class (HasRepoVar env, HasRepoSaver env)
=> HasRepo env where
repoEnv :: Getter env RepoEnv
class HasRepoVar env where
repoVar :: Getter env (MVar NgramsRepo)
class HasRepoSaver env where
repoSaver :: Getter env (IO ())
instance HasRepo RepoEnv where
repoEnv = identity
instance HasRepoVar (MVar NgramsRepo) where
repoVar = identity
instance HasRepoVar RepoEnv where
repoVar = renv_var
instance HasRepoSaver RepoEnv where
repoSaver = renv_saver
------------------------------------------------------------------------ ------------------------------------------------------------------------
......
...@@ -93,7 +93,7 @@ addContact u nId (AddContactParams fn ln) logStatus = do ...@@ -93,7 +93,7 @@ addContact u nId (AddContactParams fn ln) logStatus = do
, _scst_remaining = Just 1 , _scst_remaining = Just 1
, _scst_events = Just [] , _scst_events = Just []
} }
_ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing [[hyperdataContact fn ln]] _ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing [[hyperdataContact fn ln]] logStatus
pure JobLog { _scst_succeeded = Just 2 pure JobLog { _scst_succeeded = Just 2
, _scst_failed = Just 0 , _scst_failed = Just 0
......
...@@ -213,15 +213,15 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q ...@@ -213,15 +213,15 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
-- TODO if cid is folder -> create Corpus -- TODO if cid is folder -> create Corpus
-- if cid is corpus -> add to corpus -- if cid is corpus -> add to corpus
-- if cid is root -> create corpus in Private -- if cid is root -> create corpus in Private
txts <- mapM (\db -> getDataText db (Multi l) q maybeLimit) [database2origin dbs] txts <- mapM (\db -> getDataText db (Multi l) q maybeLimit) [database2origin dbs]
logStatus JobLog { _scst_succeeded = Just 2 logStatus JobLog { _scst_succeeded = Just 2
, _scst_failed = Just 0 , _scst_failed = Just 0
, _scst_remaining = Just 1 , _scst_remaining = Just $ 1 + length txts
, _scst_events = Just [] , _scst_events = Just []
} }
cids <- mapM (\txt -> flowDataText user txt (Multi l) cid Nothing) txts cids <- mapM (\txt -> flowDataText user txt (Multi l) cid Nothing logStatus) txts
printDebug "corpus id" cids printDebug "corpus id" cids
printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text) printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
sendMail user sendMail user
...@@ -297,6 +297,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do ...@@ -297,6 +297,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
(Multi $ fromMaybe EN l) (Multi $ fromMaybe EN l)
Nothing Nothing
(map (map toHyperdataDocument) docs) (map (map toHyperdataDocument) docs)
logStatus
printDebug "Extraction finished : " cid printDebug "Extraction finished : " cid
printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text) printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
......
...@@ -63,6 +63,7 @@ instance FromHttpApiData FileType ...@@ -63,6 +63,7 @@ instance FromHttpApiData FileType
parseUrlPiece "CSV_HAL" = pure CSV_HAL parseUrlPiece "CSV_HAL" = pure CSV_HAL
parseUrlPiece "PresseRis" = pure PresseRIS parseUrlPiece "PresseRis" = pure PresseRIS
parseUrlPiece "ZIP" = pure ZIP parseUrlPiece "ZIP" = pure ZIP
parseUrlPiece "WOS" = pure WOS
parseUrlPiece _ = pure CSV -- TODO error here parseUrlPiece _ = pure CSV -- TODO error here
......
...@@ -107,6 +107,6 @@ documentUpload uId nId doc logStatus = do ...@@ -107,6 +107,6 @@ documentUpload uId nId doc logStatus = do
, _hd_publication_minute = Nothing , _hd_publication_minute = Nothing
, _hd_publication_second = Nothing , _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ T.pack $ show EN } , _hd_language_iso2 = Just $ T.pack $ show EN }
_ <- flowDataText (RootId (NodeId uId)) (DataNew [[hd]]) (Multi EN) cId Nothing _ <- flowDataText (RootId (NodeId uId)) (DataNew [[hd]]) (Multi EN) cId Nothing logStatus
pure $ jobLogSuccess jl pure $ jobLogSuccess jl
...@@ -100,7 +100,7 @@ documentsFromWriteNodes uId nId _p logStatus = do ...@@ -100,7 +100,7 @@ documentsFromWriteNodes uId nId _p logStatus = do
let parsedE = (\(node, contents) -> hyperdataDocumentFromFrameWrite (node ^. node_hyperdata, contents)) <$> frameWritesWithContents let parsedE = (\(node, contents) -> hyperdataDocumentFromFrameWrite (node ^. node_hyperdata, contents)) <$> frameWritesWithContents
let parsed = rights parsedE let parsed = rights parsedE
_ <- flowDataText (RootId (NodeId uId)) (DataNew [parsed]) (Multi EN) cId Nothing _ <- flowDataText (RootId (NodeId uId)) (DataNew [parsed]) (Multi EN) cId Nothing logStatus
pure $ jobLogSuccess jobLog pure $ jobLogSuccess jobLog
------------------------------------------------------------------------ ------------------------------------------------------------------------
......
...@@ -34,6 +34,7 @@ import Data.Validity ...@@ -34,6 +34,7 @@ import Data.Validity
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types import Gargantext.API.Admin.Types
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.Types import Gargantext.Core.Types
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
...@@ -54,7 +55,8 @@ type EnvC env = ...@@ -54,7 +55,8 @@ type EnvC env =
, HasSettings env -- TODO rename HasDbSettings , HasSettings env -- TODO rename HasDbSettings
, HasJobEnv env JobLog JobLog , HasJobEnv env JobLog JobLog
, HasConfig env , HasConfig env
, HasNodeStoryEnv env , HasNodeStoryEnv env
, HasMail env
) )
type ErrC err = type ErrC err =
......
...@@ -7,19 +7,19 @@ Maintainer : team@gargantext.org ...@@ -7,19 +7,19 @@ Maintainer : team@gargantext.org
Stability : experimental Stability : experimental
Portability : POSIX Portability : POSIX
TODO put main configuration variables in gargantext.ini
-} -}
module Gargantext.Core.Mail module Gargantext.Core.Mail where
where
import Control.Lens ((^.))
import Data.Text (Text, unlines, splitOn) import Data.Text (Text, unlines, splitOn)
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Mail (gargMail, GargMail(..)) import Gargantext.Prelude.Mail (gargMail, GargMail(..))
import Gargantext.Prelude.Mail.Types (MailConfig, mc_mail_host)
import qualified Data.List as List import qualified Data.List as List
-- | Tool to put elsewhere -- | Tool to put elsewhere
isEmail :: Text -> Bool isEmail :: Text -> Bool
isEmail = ((==) 2) . List.length . (splitOn "@") isEmail = ((==) 2) . List.length . (splitOn "@")
...@@ -38,12 +38,12 @@ data MailModel = Invitation { invitation_user :: NewUser GargPassword } ...@@ -38,12 +38,12 @@ data MailModel = Invitation { invitation_user :: NewUser GargPassword }
} }
------------------------------------------------------------------------ ------------------------------------------------------------------------
------------------------------------------------------------------------ ------------------------------------------------------------------------
mail :: ServerAddress -> MailModel -> IO () mail :: MailConfig -> MailModel -> IO ()
mail server model = gargMail (GargMail m (Just u) subject body) mail cfg model = gargMail cfg (GargMail m (Just u) subject body)
where where
(m,u) = email_to model (m,u) = email_to model
subject = email_subject model subject = email_subject model
body = emailWith server model body = emailWith (cfg ^. mc_mail_host) model
------------------------------------------------------------------------ ------------------------------------------------------------------------
emailWith :: ServerAddress -> MailModel -> Text emailWith :: ServerAddress -> MailModel -> Text
......
{-|
Module : Gargantext.Core.Mail.Types
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.Core.Mail.Types where
import Control.Lens (Getter)
import Gargantext.Prelude.Mail.Types (MailConfig)
class HasMail env where
mailSettings :: Getter env MailConfig
...@@ -32,7 +32,6 @@ import Control.Monad.Except ...@@ -32,7 +32,6 @@ import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import Data.Aeson hiding ((.=), decode) import Data.Aeson hiding ((.=), decode)
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid import Data.Monoid
import Data.Semigroup import Data.Semigroup
import GHC.Generics (Generic) import GHC.Generics (Generic)
...@@ -48,7 +47,6 @@ import System.IO.Temp (withTempFile) ...@@ -48,7 +47,6 @@ import System.IO.Temp (withTempFile)
import qualified Data.ByteString.Lazy as DBL import qualified Data.ByteString.Lazy as DBL
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Map.Strict.Patch.Internal as Patch
import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -207,6 +205,7 @@ nodeStoryPath repoDir nId = repoDir <> "/" <> filename ...@@ -207,6 +205,7 @@ nodeStoryPath repoDir nId = repoDir <> "/" <> filename
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- TODO : repo Migration TODO TESTS -- TODO : repo Migration TODO TESTS
{-
repoMigration :: NodeStoryDir -> NgramsRepo -> IO () repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
repoMigration fp r = writeNodeStories fp (repoToNodeListStory r) repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
...@@ -249,7 +248,7 @@ ngramsStatePatch_migration np' = Map.fromListWith (<>) ...@@ -249,7 +248,7 @@ ngramsStatePatch_migration np' = Map.fromListWith (<>)
-> (nid, [fst $ Patch.singleton nt table]) -> (nid, [fst $ Patch.singleton nt table])
) $ Patch.toList nTable ) $ Patch.toList nTable
) $ Patch.toList p ) $ Patch.toList p
-}
------------------------------------------------------------------------ ------------------------------------------------------------------------
{- | Node Story for each NodeType where the Key of the Map is NodeId {- | Node Story for each NodeType where the Key of the Map is NodeId
......
...@@ -21,25 +21,26 @@ import Control.Lens (view, (^.)) ...@@ -21,25 +21,26 @@ import Control.Lens (view, (^.))
import Data.Text import Data.Text
import Servant import Servant
import Gargantext.Core
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Action.Share (delFolderTeam) import Gargantext.Database.Action.Share (delFolderTeam)
import Gargantext.Core import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Admin.Types.Hyperdata.File import Gargantext.Database.Admin.Types.Hyperdata.File
import Gargantext.Database.Admin.Types.Node -- (NodeType(..)) import Gargantext.Database.Admin.Types.Node -- (NodeType(..))
import Gargantext.Database.Prelude (Cmd', HasConfig, HasConnectionPool) import Gargantext.Database.Prelude (Cmd', HasConfig, HasConnectionPool)
import qualified Gargantext.Database.Query.Table.Node as N (getNode, deleteNode)
import Gargantext.Database.Query.Table.Node (getNodeWith) import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
import Gargantext.Prelude import Gargantext.Prelude
import qualified Gargantext.Database.GargDB as GargDB import qualified Gargantext.Database.GargDB as GargDB
import qualified Gargantext.Database.Query.Table.Node as N (getNode, deleteNode)
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- TODO -- TODO
-- Delete Corpus children accoring its types -- Delete Corpus children accoring its types
-- Delete NodeList (NodeStory + cbor file) -- Delete NodeList (NodeStory + cbor file)
deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err) deleteNode :: (HasMail env, HasConfig env, HasConnectionPool env, HasNodeError err)
=> User => User
-> NodeId -> NodeId
-> Cmd' env err Int -> Cmd' env err Int
......
...@@ -65,6 +65,7 @@ import qualified Data.HashMap.Strict as HashMap ...@@ -65,6 +65,7 @@ import qualified Data.HashMap.Strict as HashMap
import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
import qualified Data.Map as Map import qualified Data.Map as Map
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
import Gargantext.Core (Lang(..), PosTagAlgo(..)) import Gargantext.Core (Lang(..), PosTagAlgo(..))
import Gargantext.Core.Ext.IMT (toSchoolName) import Gargantext.Core.Ext.IMT (toSchoolName)
import Gargantext.Core.Ext.IMTUser (readFile_Annuaire) import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
...@@ -154,11 +155,12 @@ flowDataText :: ( FlowCmdM env err m ...@@ -154,11 +155,12 @@ flowDataText :: ( FlowCmdM env err m
-> TermType Lang -> TermType Lang
-> CorpusId -> CorpusId
-> Maybe FlowSocialListWith -> Maybe FlowSocialListWith
-> (JobLog -> m ())
-> m CorpusId -> m CorpusId
flowDataText u (DataOld ids) tt cid mfslw = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids mfslw flowDataText u (DataOld ids) tt cid mfslw _ = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids mfslw
where where
corpusType = (Nothing :: Maybe HyperdataCorpus) corpusType = (Nothing :: Maybe HyperdataCorpus)
flowDataText u (DataNew txt) tt cid mfslw = flowCorpus u (Right [cid]) tt mfslw txt flowDataText u (DataNew txt) tt cid mfslw logStatus = flowCorpus u (Right [cid]) tt mfslw txt logStatus
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- TODO use proxy -- TODO use proxy
...@@ -167,10 +169,11 @@ flowAnnuaire :: (FlowCmdM env err m) ...@@ -167,10 +169,11 @@ flowAnnuaire :: (FlowCmdM env err m)
-> Either CorpusName [CorpusId] -> Either CorpusName [CorpusId]
-> (TermType Lang) -> (TermType Lang)
-> FilePath -> FilePath
-> (JobLog -> m ())
-> m AnnuaireId -> m AnnuaireId
flowAnnuaire u n l filePath = do flowAnnuaire u n l filePath logStatus = do
docs <- liftBase $ (( splitEvery 500 <$> readFile_Annuaire filePath) :: IO [[HyperdataContact]]) docs <- liftBase $ (( splitEvery 500 <$> readFile_Annuaire filePath) :: IO [[HyperdataContact]])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing docs flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing docs logStatus
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowCorpusFile :: (FlowCmdM env err m) flowCorpusFile :: (FlowCmdM env err m)
...@@ -179,13 +182,14 @@ flowCorpusFile :: (FlowCmdM env err m) ...@@ -179,13 +182,14 @@ flowCorpusFile :: (FlowCmdM env err m)
-> Limit -- Limit the number of docs (for dev purpose) -> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang -> FileFormat -> FilePath -> TermType Lang -> FileFormat -> FilePath
-> Maybe FlowSocialListWith -> Maybe FlowSocialListWith
-> (JobLog -> m ())
-> m CorpusId -> m CorpusId
flowCorpusFile u n l la ff fp mfslw = do flowCorpusFile u n l la ff fp mfslw logStatus = do
eParsed <- liftBase $ parseFile ff fp eParsed <- liftBase $ parseFile ff fp
case eParsed of case eParsed of
Right parsed -> do Right parsed -> do
let docs = splitEvery 500 $ take l parsed let docs = splitEvery 500 $ take l parsed
flowCorpus u n la mfslw (map (map toHyperdataDocument) docs) flowCorpus u n la mfslw (map (map toHyperdataDocument) docs) logStatus
Left e -> panic $ "Error: " <> (T.pack e) Left e -> panic $ "Error: " <> (T.pack e)
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -197,6 +201,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a) ...@@ -197,6 +201,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
-> TermType Lang -> TermType Lang
-> Maybe FlowSocialListWith -> Maybe FlowSocialListWith
-> [[a]] -> [[a]]
-> (JobLog -> m ())
-> m CorpusId -> m CorpusId
flowCorpus = flow (Nothing :: Maybe HyperdataCorpus) flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
...@@ -211,10 +216,19 @@ flow :: ( FlowCmdM env err m ...@@ -211,10 +216,19 @@ flow :: ( FlowCmdM env err m
-> TermType Lang -> TermType Lang
-> Maybe FlowSocialListWith -> Maybe FlowSocialListWith
-> [[a]] -> [[a]]
-> (JobLog -> m ())
-> m CorpusId -> m CorpusId
flow c u cn la mfslw docs = do flow c u cn la mfslw docs logStatus = do
-- TODO if public insertMasterDocs else insertUserDocs -- TODO if public insertMasterDocs else insertUserDocs
ids <- traverse (insertMasterDocs c la) docs ids <- traverse (\(idx, doc) -> do
id <- insertMasterDocs c la doc
logStatus JobLog { _scst_succeeded = Just $ 1 + idx
, _scst_failed = Just 0
, _scst_remaining = Just $ length docs - idx
, _scst_events = Just []
}
pure id
) (zip [1..] docs)
flowCorpusUser (la ^. tt_lang) u cn c (concat ids) mfslw flowCorpusUser (la ^. tt_lang) u cn c (concat ids) mfslw
------------------------------------------------------------------------ ------------------------------------------------------------------------
......
...@@ -14,21 +14,21 @@ module Gargantext.Database.Action.Mail ...@@ -14,21 +14,21 @@ module Gargantext.Database.Action.Mail
where where
import Control.Lens (view) import Control.Lens (view)
import Gargantext.Prelude import Gargantext.Core.Mail (mail, MailModel(..))
import Gargantext.Core.Mail.Types (mailSettings)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.User
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Core.Mail
import Gargantext.Prelude.Config
import Gargantext.Database.Schema.User import Gargantext.Database.Schema.User
import Gargantext.Database.Action.User import Gargantext.Prelude
import Gargantext.Core.Types.Individu (User(..))
------------------------------------------------------------------------ ------------------------------------------------------------------------
sendMail :: HasNodeError err => User -> Cmd err () sendMail :: HasNodeError err => User -> Cmd err ()
sendMail u = do sendMail u = do
server <- view $ hasConfig . gc_url cfg <- view $ mailSettings
userLight <- getUserLightDB u userLight <- getUserLightDB u
liftBase $ mail server (MailInfo { mailInfo_username = userLight_username userLight liftBase $ mail cfg (MailInfo { mailInfo_username = userLight_username userLight
, mailInfo_address = userLight_email userLight }) , mailInfo_address = userLight_email userLight })
...@@ -18,6 +18,7 @@ import Data.Vector (Vector) ...@@ -18,6 +18,7 @@ import Data.Vector (Vector)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo') import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo')
import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm) import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm)
import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-}) import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.Types (ListType(..), Limit, NodeType(..)) import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
import Gargantext.Database.Action.Flow.Types (FlowCmdM) import Gargantext.Database.Action.Flow.Types (FlowCmdM)
...@@ -62,7 +63,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do ...@@ -62,7 +63,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
getNgrams :: (HasNodeStory env err m) getNgrams :: (HasMail env, HasNodeStory env err m)
=> CorpusId -> Maybe ListId -> TabType => CorpusId -> Maybe ListId -> TabType
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm) -> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm) , HashMap NgramsTerm (Maybe RootTerm)
......
...@@ -16,24 +16,25 @@ module Gargantext.Database.Action.User.New ...@@ -16,24 +16,25 @@ module Gargantext.Database.Action.User.New
import Control.Lens (view) import Control.Lens (view)
import Control.Monad.Random import Control.Monad.Random
import Data.Text (Text, splitOn) import Data.Text (Text, splitOn)
import qualified Data.Text as Text
import Gargantext.Core.Mail import Gargantext.Core.Mail
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow (getOrMkRoot) import Gargantext.Database.Action.Flow (getOrMkRoot)
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
import Gargantext.Database.Query.Table.User import Gargantext.Database.Query.Table.User
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Config
import Gargantext.Prelude.Crypto.Pass.User (gargPass) import Gargantext.Prelude.Crypto.Pass.User (gargPass)
import qualified Data.Text as Text import Gargantext.Prelude.Mail.Types (MailConfig)
------------------------------------------------------------------------ ------------------------------------------------------------------------
------------------------------------------------------------------------ ------------------------------------------------------------------------
newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err) newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
=> [EmailAddress] -> m Int64 => [EmailAddress] -> m Int64
newUsers us = do newUsers us = do
us' <- mapM newUserQuick us us' <- mapM newUserQuick us
url <- view $ hasConfig . gc_url config <- view $ mailSettings
newUsers' url us' newUsers' config us'
------------------------------------------------------------------------ ------------------------------------------------------------------------
newUserQuick :: (MonadRandom m) newUserQuick :: (MonadRandom m)
=> Text -> m (NewUser GargPassword) => Text -> m (NewUser GargPassword)
...@@ -54,27 +55,27 @@ guessUserName n = case splitOn "@" n of ...@@ -54,27 +55,27 @@ guessUserName n = case splitOn "@" n of
_ -> Nothing _ -> Nothing
------------------------------------------------------------------------ ------------------------------------------------------------------------
newUser' :: HasNodeError err newUser' :: HasNodeError err
=> ServerAddress -> NewUser GargPassword -> Cmd err Int64 => MailConfig -> NewUser GargPassword -> Cmd err Int64
newUser' address u = newUsers' address [u] newUser' cfg u = newUsers' cfg [u]
newUsers' :: HasNodeError err newUsers' :: HasNodeError err
=> ServerAddress -> [NewUser GargPassword] -> Cmd err Int64 => MailConfig -> [NewUser GargPassword] -> Cmd err Int64
newUsers' address us = do newUsers' cfg us = do
us' <- liftBase $ mapM toUserHash us us' <- liftBase $ mapM toUserHash us
r <- insertUsers $ map toUserWrite us' r <- insertUsers $ map toUserWrite us'
_ <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us _ <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
_ <- liftBase $ mapM (\u -> mail address (Invitation u)) us _ <- liftBase $ mapM (\u -> mail cfg (Invitation u)) us
printDebug "newUsers'" us printDebug "newUsers'" us
pure r pure r
------------------------------------------------------------------------ ------------------------------------------------------------------------
updateUser :: HasNodeError err updateUser :: HasNodeError err
=> SendEmail -> Text -> NewUser GargPassword -> Cmd err Int64 => SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64
updateUser (SendEmail send) server u = do updateUser (SendEmail send) cfg u = do
u' <- liftBase $ toUserHash u u' <- liftBase $ toUserHash u
n <- updateUserDB $ toUserWrite u' n <- updateUserDB $ toUserWrite u'
_ <- case send of _ <- case send of
True -> liftBase $ mail server (PassUpdate u) True -> liftBase $ mail cfg (PassUpdate u)
False -> pure () False -> pure ()
pure n pure n
......
...@@ -21,16 +21,17 @@ import Control.Monad.Reader ...@@ -21,16 +21,17 @@ import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON) import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
import Data.ByteString.Char8 (hPutStrLn) import Data.ByteString.Char8 (hPutStrLn)
import Data.Either.Extra (Either(Left, Right)) import Data.Either.Extra (Either)
import Data.Ini (readIniFile, lookupValue)
import Data.Pool (Pool, withResource) import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default) import Data.Profunctor.Product.Default (Default)
import Data.Text (unpack, pack, Text) import Data.Text (unpack, Text)
import Data.Word (Word16) import Data.Word (Word16)
import Database.PostgreSQL.Simple (Connection, connect) import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError) import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field) import Database.PostgreSQL.Simple.Internal (Field)
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Config (readIniFile', val)
import Opaleye (Query, Unpackspec, showSql, FromFields, Select, runSelect, PGJsonb, DefaultFromField) import Opaleye (Query, Unpackspec, showSql, FromFields, Select, runSelect, PGJsonb, DefaultFromField)
import Opaleye.Aggregate (countRows) import Opaleye.Aggregate (countRows)
import System.IO (FilePath) import System.IO (FilePath)
...@@ -77,13 +78,15 @@ type CmdM env err m = ...@@ -77,13 +78,15 @@ type CmdM env err m =
( CmdM' env err m ( CmdM' env err m
, HasConnectionPool env , HasConnectionPool env
, HasConfig env , HasConfig env
, HasMail env
) )
type CmdRandom env err m = type CmdRandom env err m =
( CmdM' env err m ( CmdM' env err m
, HasConnectionPool env , HasConnectionPool env
, HasConfig env , HasConfig env
, MonadRandom m , MonadRandom 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
...@@ -157,20 +160,14 @@ execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a ...@@ -157,20 +160,14 @@ execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
databaseParameters :: FilePath -> IO PGS.ConnectInfo databaseParameters :: FilePath -> IO PGS.ConnectInfo
databaseParameters fp = do databaseParameters fp = do
ini <- readIniFile fp ini <- readIniFile' fp
let ini'' = case ini of let val' key = unpack $ val ini "database" key
Left e -> panic (pack $ "No ini file error" <> show e)
Right ini' -> ini' pure $ PGS.ConnectInfo { PGS.connectHost = val' "DB_HOST"
, PGS.connectPort = read (val' "DB_PORT") :: Word16
let val x = case (lookupValue (pack "database") (pack x) ini'') of , PGS.connectUser = val' "DB_USER"
Left _ -> panic (pack $ "no" <> x) , PGS.connectPassword = val' "DB_PASS"
Right p' -> unpack p' , PGS.connectDatabase = val' "DB_NAME"
pure $ PGS.ConnectInfo { PGS.connectHost = val "DB_HOST"
, PGS.connectPort = read (val "DB_PORT") :: Word16
, PGS.connectUser = val "DB_USER"
, PGS.connectPassword = val "DB_PASS"
, PGS.connectDatabase = val "DB_NAME"
} }
connectGargandb :: FilePath -> IO Connection connectGargandb :: FilePath -> IO Connection
......
...@@ -17,10 +17,9 @@ Portability : POSIX ...@@ -17,10 +17,9 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Query.Table.NodesNgramsRepo module Gargantext.Database.Query.Table.NodesNgramsRepo
( module Gargantext.Database.Schema.NodesNgramsRepo
)
where where
{-
import Gargantext.Database.Schema.Prelude import Gargantext.Database.Schema.Prelude
import Gargantext.API.Ngrams (NgramsStatePatch) import Gargantext.API.Ngrams (NgramsStatePatch)
import Gargantext.Database.Schema.NodesNgramsRepo import Gargantext.Database.Schema.NodesNgramsRepo
...@@ -42,4 +41,4 @@ _insertRepos ns = mkCmd $ \conn -> runInsert_ conn $ Insert repoTable (toWrite n ...@@ -42,4 +41,4 @@ _insertRepos ns = mkCmd $ \conn -> runInsert_ conn $ Insert repoTable (toWrite n
toWrite :: [NgramsStatePatch] -> [RepoDbWrite] toWrite :: [NgramsStatePatch] -> [RepoDbWrite]
toWrite = undefined toWrite = undefined
--ns' = map (\(RepoDbNgrams v ps) -> RepoDbWrite (sqlInt4 v) (pgJSONB ps)) ns --ns' = map (\(RepoDbNgrams v ps) -> RepoDbWrite (sqlInt4 v) (pgJSONB ps)) ns
-}
...@@ -21,10 +21,11 @@ Portability : POSIX ...@@ -21,10 +21,11 @@ Portability : POSIX
module Gargantext.Database.Schema.NodesNgramsRepo module Gargantext.Database.Schema.NodesNgramsRepo
where where
{-
import Data.Map.Strict.Patch (PatchMap) import Data.Map.Strict.Patch (PatchMap)
import Gargantext.Database.Schema.Prelude import Gargantext.Database.Schema.Prelude
import Gargantext.API.Ngrams.Types (NgramsStatePatch, NgramsTablePatch) import Gargantext.API.Ngrams.Types (NgramsTablePatch)
import Gargantext.Database.Schema.Ngrams (NgramsType) import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Database.Admin.Types.Node (NodeId) import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -59,4 +60,4 @@ repoTable = Table "nodes_ngrams_repo" ...@@ -59,4 +60,4 @@ repoTable = Table "nodes_ngrams_repo"
, _rdp_patches = requiredTableField "patches" , _rdp_patches = requiredTableField "patches"
} }
) )
-}
...@@ -27,9 +27,8 @@ allow-newer: true ...@@ -27,9 +27,8 @@ allow-newer: true
# "$everything": -haddock # "$everything": -haddock
extra-deps: extra-deps:
- #git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git - git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
git: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude.git commit: 6bfdb29e9a576472c7fd7ebe648ad101e5b3927f
commit: 35b09629a658fc16cc9ff63e7591e58511cd98a7
# Data Mining Libs # Data Mining Libs
- git: https://github.com/delanoe/data-time-segment.git - git: https://github.com/delanoe/data-time-segment.git
commit: 10a416b9f6c443866b36479c3441ebb3bcdeb7ef commit: 10a416b9f6c443866b36479c3441ebb3bcdeb7ef
......
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