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

Merge branch 'dev' into 86-dev-graphql

parents 133d581e 02a4c6df
Pipeline #2076 failed with stage
in 10 minutes and 16 seconds
......@@ -47,13 +47,13 @@ main = do
tt = (Multi EN)
format = CsvGargV3 -- CsvHal --WOS
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 = 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 = 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
......
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
LOG_FILE = /var/log/gargantext/backend.log
LOG_LEVEL = LevelDebug
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
version: '0.0.4.6'
version: '0.0.4.7.1'
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -371,19 +371,19 @@ executables:
- gargantext-prelude
- base
gargantext-upgrade:
main: Main.hs
source-dirs: bin/gargantext-upgrade
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -O2
- -Wmissing-signatures
dependencies:
- gargantext
- gargantext-prelude
- base
# gargantext-upgrade:
# main: Main.hs
# source-dirs: bin/gargantext-upgrade
# ghc-options:
# - -threaded
# - -rtsopts
# - -with-rtsopts=-N
# - -O2
# - -Wmissing-signatures
# dependencies:
# - gargantext
# - gargantext-prelude
# - base
gargantext-admin:
main: Main.hs
......@@ -399,22 +399,23 @@ executables:
- gargantext-prelude
- base
gargantext-cbor2json:
main: Main.hs
source-dirs: bin/gargantext-cbor2json
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -O2
- -Wmissing-signatures
dependencies:
- gargantext
- gargantext-prelude
- base
- bytestring
- aeson
- serialise
# gargantext-cbor2json:
# main: Main.hs
# source-dirs: bin/gargantext-cbor2json
# ghc-options:
# - -threaded
# - -rtsopts
# - -with-rtsopts=-N
# - -O2
# - -Wmissing-signatures
# dependencies:
# - gargantext
# - gargantext-prelude
# - base
# - bytestring
# - aeson
# - serialise
tests:
......
......@@ -20,6 +20,7 @@ TODO-ACCESS Critical
-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Gargantext.API.Admin.Auth
......@@ -35,17 +36,18 @@ import Servant
import Servant.Auth.Server
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.API.Admin.Types
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC)
import Gargantext.Core.Mail.Types (HasMail)
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.Root (getRoot)
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.Database.Query.Table.User
---------------------------------------------------
......@@ -60,7 +62,7 @@ makeTokenForUser uid = do
either joseError (pure . toStrict . decodeUtf8) e
-- 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
-> GargPassword
-> Cmd' env err CheckAuth
......@@ -79,7 +81,7 @@ checkAuthRequest u (GargPassword p) = do
token <- makeTokenForUser 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
auth (AuthRequest u p) = do
checkAuthRequest' <- checkAuthRequest u p
......
......@@ -14,24 +14,25 @@ import Servant.Job.Async (HasJobEnv(..), Job)
import System.Log.FastLogger
import qualified Servant.Job.Core
import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
import Gargantext.API.Admin.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.Prelude
import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Core.NodeStory
import Gargantext.Prelude.Mail.Types (MailConfig)
data Env = Env
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
, _env_pool :: !(Pool Connection)
, _env_repo :: !RepoEnv
, _env_nodeStory :: !NodeStoryEnv
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv
, _env_config :: !GargConfig
, _env_mail :: !MailConfig
}
deriving (Generic)
......@@ -55,15 +56,8 @@ instance HasNodeStorySaver Env where
instance HasSettings Env where
settings = env_settings
-- Specific to Repo
instance HasRepoVar Env where
repoVar = repoEnv . repoVar
instance HasRepoSaver Env where
repoSaver = repoEnv . repoSaver
instance HasRepo Env where
repoEnv = env_repo
instance HasMail Env where
mailSettings = env_mail
instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
......@@ -83,10 +77,10 @@ makeLenses ''MockEnv
data DevEnv = DevEnv
{ _dev_env_settings :: !Settings
, _dev_env_repo :: !RepoEnv
, _dev_env_config :: !GargConfig
, _dev_env_pool :: !(Pool Connection)
, _dev_env_nodeStory :: !NodeStoryEnv
, _dev_env_mail :: !MailConfig
}
makeLenses ''DevEnv
......@@ -110,12 +104,5 @@ instance HasNodeStoryVar DevEnv where
instance HasNodeStorySaver DevEnv where
hasNodeStorySaver = hasNodeStory . nse_saver
instance HasRepoVar DevEnv where
repoVar = repoEnv . repoVar
instance HasRepoSaver DevEnv where
repoSaver = repoEnv . repoSaver
instance HasRepo DevEnv where
repoEnv = dev_env_repo
instance HasMail DevEnv where
mailSettings = dev_env_mail
......@@ -18,9 +18,8 @@ TODO-SECURITY: Critical
module Gargantext.API.Admin.Settings
where
import Codec.Serialise (Serialise(), serialise, deserialise)
import Control.Concurrent
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
-- import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Codec.Serialise (Serialise(), serialise)
import Control.Lens
import Control.Monad.Logger
import Control.Monad.Reader
......@@ -34,7 +33,7 @@ import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSe
import Servant.Client (parseBaseUrl)
import Servant.Job.Async (newJobEnv, defaultSettings)
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.Temp (withTempFile)
import System.Log.FastLogger
......@@ -43,10 +42,11 @@ import qualified Data.ByteString.Lazy as L
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Types
import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
-- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
import Gargantext.Database.Prelude (databaseParameters)
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 jwkFile = do
......@@ -113,7 +113,7 @@ repoSaverAction repoDir a = do
--{-
{-
-- 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
-- be increased.
......@@ -133,6 +133,8 @@ mkRepoSaver repoDir repo_var = mkDebounce settings'
-- Add a new MVar just for saving.
}
-}
{-
readRepoEnv :: FilePath -> IO RepoEnv
readRepoEnv repoDir = do
-- Does file exist ? :: Bool
......@@ -178,27 +180,27 @@ newEnv port file = do
self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- databaseParameters file
pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath config_env)
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
scrapers_env <- newJobEnv defaultSettings manager_env
logger <- newStderrLoggerSet defaultBufSize
config_mail <- Mail.readConfig file
pure $ Env
{ _env_settings = settings'
, _env_logger = logger
, _env_pool = pool
, _env_repo = repo
, _env_nodeStory = nodeStory_env
, _env_manager = manager_env
, _env_scrapers = scrapers_env
, _env_self_url = self_url_env
, _env_config = config_env
, _env_mail = config_mail
}
newPool :: ConnectInfo -> IO (Pool Connection)
newPool param = createPool (connect param) close 1 (60*60) 8
--{-
{-
cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
cleanEnv env = do
r <- takeMVar (env ^. repoEnv . renv_var)
......
......@@ -23,6 +23,7 @@ import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import qualified Gargantext.Prelude.Mail as Mail
import Servant
import System.IO (FilePath)
......@@ -31,7 +32,7 @@ type IniPath = FilePath
withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
withDevEnv iniPath k = do
env <- newDevEnv
k env `finally` cleanEnv env
k env -- `finally` cleanEnv env
where
newDevEnv = do
......@@ -39,14 +40,14 @@ withDevEnv iniPath k = do
dbParam <- databaseParameters iniPath
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath cfg)
setts <- devSettings devJwkFile
mail <- Mail.readConfig iniPath
pure $ DevEnv
{ _dev_env_pool = pool
, _dev_env_repo = repo
, _dev_env_nodeStory = nodeStory_env
, _dev_env_settings = setts
, _dev_env_config = cfg
, _dev_env_mail = mail
}
-- | Run Cmd Sugar for the Repl (GHCI)
......
......@@ -33,7 +33,6 @@ module Gargantext.API.Ngrams
, apiNgramsTableCorpus
, apiNgramsTableDoc
, NgramsStatePatch
, NgramsTablePatch
, NgramsTableMap
......@@ -52,15 +51,10 @@ module Gargantext.API.Ngrams
, r_version
, r_state
, r_history
, NgramsRepo
, NgramsRepoElement(..)
, saveNodeStory
, initRepo
, RepoEnv(..)
, renv_var
, renv_lock
, TabType(..)
, QueryParamR
......@@ -102,6 +96,7 @@ import Gargantext.API.Job
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude
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.API.Ngrams.Tools
import Gargantext.Database.Action.Flow.Types
......@@ -280,7 +275,7 @@ newNgramsFromNgramsStatePatch p =
commitStatePatch :: HasNodeStory env err m
commitStatePatch :: (HasNodeStory env err m, HasMail env)
=> ListId
-> Versioned NgramsStatePatch'
-> m (Versioned NgramsStatePatch')
......@@ -346,8 +341,9 @@ tableNgramsPull listId ngramsType p_version = do
-- client.
-- TODO-ACCESS check
tableNgramsPut :: ( HasNodeStory env err m
, HasInvalidError err
, HasInvalidError err
, HasSettings env
, HasMail env
)
=> TabType
-> ListId
......@@ -494,7 +490,7 @@ type MaxSize = Int
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
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
......@@ -617,7 +613,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
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
scoresRecomputeTableNgrams nId tabType listId = do
tableMap <- getNgramsTableMap listId ngramsType
......@@ -712,7 +708,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
:> "update"
:> 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
-> TabType
-> ListId
......@@ -746,7 +742,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId
-- | 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
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
......
......@@ -35,12 +35,12 @@ mergeNgramsElement _neOld neNew = neNew
type RootTerm = NgramsTerm
{-
getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo = do
v <- view repoVar
liftBase $ readMVar v
-}
getRepo' :: HasNodeStory env err m
=> [ListId] -> m NodeListStory
......
......@@ -11,8 +11,7 @@ module Gargantext.API.Ngrams.Types where
import Codec.Serialise (Serialise())
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_, (?~), Getter)
import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
import Control.Monad.State
import Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON)
......@@ -39,7 +38,7 @@ import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
import Protolude (maybeToEither)
import Servant hiding (Patch)
import Servant.Job.Utils (jsonOptions)
import System.FileLock (FileLock)
-- import System.FileLock (FileLock)
import Test.QuickCheck (elements, frequency)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
......@@ -676,11 +675,6 @@ data Repo s p = Repo
}
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
......@@ -697,52 +691,16 @@ makeLenses ''Repo
initRepo :: Monoid s => Repo s p
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 =
( CmdM' env err m
, HasRepo env
, HasConnectionPool 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
, _scst_remaining = Just 1
, _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
, _scst_failed = Just 0
......
......@@ -213,15 +213,15 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
-- TODO if cid is folder -> create Corpus
-- if cid is corpus -> add to corpus
-- 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
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_remaining = Just $ 1 + length txts
, _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 "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
sendMail user
......@@ -297,6 +297,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
(Multi $ fromMaybe EN l)
Nothing
(map (map toHyperdataDocument) docs)
logStatus
printDebug "Extraction finished : " cid
printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
......
......@@ -63,6 +63,7 @@ instance FromHttpApiData FileType
parseUrlPiece "CSV_HAL" = pure CSV_HAL
parseUrlPiece "PresseRis" = pure PresseRIS
parseUrlPiece "ZIP" = pure ZIP
parseUrlPiece "WOS" = pure WOS
parseUrlPiece _ = pure CSV -- TODO error here
......
......@@ -107,6 +107,6 @@ documentUpload uId nId doc logStatus = do
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _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
......@@ -100,7 +100,7 @@ documentsFromWriteNodes uId nId _p logStatus = do
let parsedE = (\(node, contents) -> hyperdataDocumentFromFrameWrite (node ^. node_hyperdata, contents)) <$> frameWritesWithContents
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
------------------------------------------------------------------------
......
......@@ -34,6 +34,7 @@ import Data.Validity
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.Types
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
......@@ -54,7 +55,8 @@ type EnvC env =
, HasSettings env -- TODO rename HasDbSettings
, HasJobEnv env JobLog JobLog
, HasConfig env
, HasNodeStoryEnv env
, HasNodeStoryEnv env
, HasMail env
)
type ErrC err =
......
......@@ -7,19 +7,19 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
TODO put main configuration variables in gargantext.ini
-}
module Gargantext.Core.Mail
where
module Gargantext.Core.Mail where
import Control.Lens ((^.))
import Data.Text (Text, unlines, splitOn)
import Gargantext.Core.Types.Individu
import Gargantext.Prelude
import Gargantext.Prelude.Mail (gargMail, GargMail(..))
import Gargantext.Prelude.Mail.Types (MailConfig, mc_mail_host)
import qualified Data.List as List
-- | Tool to put elsewhere
isEmail :: Text -> Bool
isEmail = ((==) 2) . List.length . (splitOn "@")
......@@ -38,12 +38,12 @@ data MailModel = Invitation { invitation_user :: NewUser GargPassword }
}
------------------------------------------------------------------------
------------------------------------------------------------------------
mail :: ServerAddress -> MailModel -> IO ()
mail server model = gargMail (GargMail m (Just u) subject body)
mail :: MailConfig -> MailModel -> IO ()
mail cfg model = gargMail cfg (GargMail m (Just u) subject body)
where
(m,u) = email_to model
subject = email_subject model
body = emailWith server model
body = emailWith (cfg ^. mc_mail_host) model
------------------------------------------------------------------------
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
import Control.Monad.Reader
import Data.Aeson hiding ((.=), decode)
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Semigroup
import GHC.Generics (Generic)
......@@ -48,7 +47,6 @@ import System.IO.Temp (withTempFile)
import qualified Data.ByteString.Lazy as DBL
import qualified Data.List as List
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
------------------------------------------------------------------------
......@@ -207,6 +205,7 @@ nodeStoryPath repoDir nId = repoDir <> "/" <> filename
------------------------------------------------------------------------
-- TODO : repo Migration TODO TESTS
{-
repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
......@@ -249,7 +248,7 @@ ngramsStatePatch_migration np' = Map.fromListWith (<>)
-> (nid, [fst $ Patch.singleton nt table])
) $ Patch.toList nTable
) $ Patch.toList p
-}
------------------------------------------------------------------------
{- | Node Story for each NodeType where the Key of the Map is NodeId
......
......@@ -21,25 +21,26 @@ import Control.Lens (view, (^.))
import Data.Text
import Servant
import Gargantext.Core
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.User (getUserId)
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.Node -- (NodeType(..))
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.Error (HasNodeError)
import Gargantext.Database.Schema.Node
import Gargantext.Prelude
import qualified Gargantext.Database.GargDB as GargDB
import qualified Gargantext.Database.Query.Table.Node as N (getNode, deleteNode)
------------------------------------------------------------------------
-- TODO
-- Delete Corpus children accoring its types
-- Delete NodeList (NodeStory + cbor file)
deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
deleteNode :: (HasMail env, HasConfig env, HasConnectionPool env, HasNodeError err)
=> User
-> NodeId
-> Cmd' env err Int
......
......@@ -65,6 +65,7 @@ import qualified Data.HashMap.Strict as HashMap
import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
import qualified Data.Map as Map
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
import Gargantext.Core (Lang(..), PosTagAlgo(..))
import Gargantext.Core.Ext.IMT (toSchoolName)
import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
......@@ -154,11 +155,12 @@ flowDataText :: ( FlowCmdM env err m
-> TermType Lang
-> CorpusId
-> Maybe FlowSocialListWith
-> (JobLog -> m ())
-> 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
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
......@@ -167,10 +169,11 @@ flowAnnuaire :: (FlowCmdM env err m)
-> Either CorpusName [CorpusId]
-> (TermType Lang)
-> FilePath
-> (JobLog -> m ())
-> m AnnuaireId
flowAnnuaire u n l filePath = do
flowAnnuaire u n l filePath logStatus = do
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)
......@@ -179,13 +182,14 @@ flowCorpusFile :: (FlowCmdM env err m)
-> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang -> FileFormat -> FilePath
-> Maybe FlowSocialListWith
-> (JobLog -> m ())
-> 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
case eParsed of
Right parsed -> do
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)
------------------------------------------------------------------------
......@@ -197,6 +201,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
-> TermType Lang
-> Maybe FlowSocialListWith
-> [[a]]
-> (JobLog -> m ())
-> m CorpusId
flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
......@@ -211,10 +216,19 @@ flow :: ( FlowCmdM env err m
-> TermType Lang
-> Maybe FlowSocialListWith
-> [[a]]
-> (JobLog -> m ())
-> 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
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
------------------------------------------------------------------------
......
......@@ -14,21 +14,21 @@ module Gargantext.Database.Action.Mail
where
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.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Core.Mail
import Gargantext.Prelude.Config
import Gargantext.Database.Schema.User
import Gargantext.Database.Action.User
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Prelude
------------------------------------------------------------------------
sendMail :: HasNodeError err => User -> Cmd err ()
sendMail u = do
server <- view $ hasConfig . gc_url
cfg <- view $ mailSettings
userLight <- getUserLightDB u
liftBase $ mail server (MailInfo { mailInfo_username = userLight_username userLight
, mailInfo_address = userLight_email userLight })
liftBase $ mail cfg (MailInfo { mailInfo_username = userLight_username userLight
, mailInfo_address = userLight_email userLight })
......@@ -18,6 +18,7 @@ import Data.Vector (Vector)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo')
import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm)
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.NodeStory
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
......@@ -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
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
......
......@@ -16,24 +16,25 @@ module Gargantext.Database.Action.User.New
import Control.Lens (view)
import Control.Monad.Random
import Data.Text (Text, splitOn)
import qualified Data.Text as Text
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.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
import Gargantext.Database.Query.Table.User
import Gargantext.Prelude
import Gargantext.Prelude.Config
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
newUsers us = do
us' <- mapM newUserQuick us
url <- view $ hasConfig . gc_url
newUsers' url us'
config <- view $ mailSettings
newUsers' config us'
------------------------------------------------------------------------
newUserQuick :: (MonadRandom m)
=> Text -> m (NewUser GargPassword)
......@@ -54,27 +55,27 @@ guessUserName n = case splitOn "@" n of
_ -> Nothing
------------------------------------------------------------------------
newUser' :: HasNodeError err
=> ServerAddress -> NewUser GargPassword -> Cmd err Int64
newUser' address u = newUsers' address [u]
=> MailConfig -> NewUser GargPassword -> Cmd err Int64
newUser' cfg u = newUsers' cfg [u]
newUsers' :: HasNodeError err
=> ServerAddress -> [NewUser GargPassword] -> Cmd err Int64
newUsers' address us = do
=> MailConfig -> [NewUser GargPassword] -> Cmd err Int64
newUsers' cfg us = do
us' <- liftBase $ mapM toUserHash us
r <- insertUsers $ map toUserWrite 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
pure r
------------------------------------------------------------------------
updateUser :: HasNodeError err
=> SendEmail -> Text -> NewUser GargPassword -> Cmd err Int64
updateUser (SendEmail send) server u = do
=> SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64
updateUser (SendEmail send) cfg u = do
u' <- liftBase $ toUserHash u
n <- updateUserDB $ toUserWrite u'
_ <- case send of
True -> liftBase $ mail server (PassUpdate u)
True -> liftBase $ mail cfg (PassUpdate u)
False -> pure ()
pure n
......
......@@ -21,16 +21,17 @@ import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
import Data.ByteString.Char8 (hPutStrLn)
import Data.Either.Extra (Either(Left, Right))
import Data.Ini (readIniFile, lookupValue)
import Data.Either.Extra (Either)
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default)
import Data.Text (unpack, pack, Text)
import Data.Text (unpack, Text)
import Data.Word (Word16)
import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field)
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Prelude
import Gargantext.Prelude.Config (readIniFile', val)
import Opaleye (Query, Unpackspec, showSql, FromFields, Select, runSelect, PGJsonb, DefaultFromField)
import Opaleye.Aggregate (countRows)
import System.IO (FilePath)
......@@ -77,13 +78,15 @@ type CmdM env err m =
( CmdM' env err m
, HasConnectionPool env
, HasConfig env
, HasMail env
)
type CmdRandom env err m =
( CmdM' env err m
, HasConnectionPool env
, HasConfig env
, MonadRandom m
, MonadRandom m
, HasMail env
)
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
databaseParameters :: FilePath -> IO PGS.ConnectInfo
databaseParameters fp = do
ini <- readIniFile fp
let ini'' = case ini of
Left e -> panic (pack $ "No ini file error" <> show e)
Right ini' -> ini'
let val x = case (lookupValue (pack "database") (pack x) ini'') of
Left _ -> panic (pack $ "no" <> x)
Right p' -> unpack p'
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"
ini <- readIniFile' fp
let val' key = unpack $ val ini "database" key
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
......
......@@ -17,10 +17,9 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Query.Table.NodesNgramsRepo
( module Gargantext.Database.Schema.NodesNgramsRepo
)
where
{-
import Gargantext.Database.Schema.Prelude
import Gargantext.API.Ngrams (NgramsStatePatch)
import Gargantext.Database.Schema.NodesNgramsRepo
......@@ -42,4 +41,4 @@ _insertRepos ns = mkCmd $ \conn -> runInsert_ conn $ Insert repoTable (toWrite n
toWrite :: [NgramsStatePatch] -> [RepoDbWrite]
toWrite = undefined
--ns' = map (\(RepoDbNgrams v ps) -> RepoDbWrite (sqlInt4 v) (pgJSONB ps)) ns
-}
......@@ -21,10 +21,11 @@ Portability : POSIX
module Gargantext.Database.Schema.NodesNgramsRepo
where
{-
import Data.Map.Strict.Patch (PatchMap)
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.Admin.Types.Node (NodeId)
import Gargantext.Prelude
......@@ -59,4 +60,4 @@ repoTable = Table "nodes_ngrams_repo"
, _rdp_patches = requiredTableField "patches"
}
)
-}
......@@ -27,9 +27,8 @@ allow-newer: true
# "$everything": -haddock
extra-deps:
- #git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
git: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude.git
commit: 35b09629a658fc16cc9ff63e7591e58511cd98a7
- git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
commit: 6bfdb29e9a576472c7fd7ebe648ad101e5b3927f
# Data Mining Libs
- git: https://github.com/delanoe/data-time-segment.git
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