Skip to content

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

Merge branch 'dev-optim' into dev

parents 6cb3efe5 7782c515
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 985 additions and 443 deletions
bin/gargantext-import/Main.hs
View file @ fe831569
......@@ -28,7 +28,8 @@ import Gargantext.API.Node () -- instances
import Gargantext.API.Prelude (GargError)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpusFile, flowAnnuaire, TermType(..))
import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Hyperdata (toHyperdataDocument)
import Gargantext.Database.Admin.Types.Node (CorpusId)
import Gargantext.Database.Prelude (Cmd)
......@@ -46,10 +47,10 @@ 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
corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt format corpusPath Nothing
corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath
corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath Nothing
annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath
......
bin/gargantext-upgrade/Main.hs
View file @ fe831569
......@@ -19,33 +19,37 @@ import Gargantext.API.Admin.EnvTypes (DevEnv)
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Prelude (GargError)
import Gargantext.API.Node () -- instances only
import Gargantext.API.Ngrams.Tools (getRepo)
import Gargantext.Database.Prelude (Cmd'', )
import Gargantext.Core.NodeStory
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import System.Environment (getArgs)
import Prelude (getLine)
-- PosTag
import Gargantext.Database.Action.Flow (indexAllDocumentsWithPosTag)
import GHC.IO.Exception (IOException)
main :: IO ()
main = do
[iniPath] <- getArgs
putStrLn "Manual method (for now):"
putStrLn "Upgrade your schema database with the script:"
putStrLn "psql gargandbV5 < ./devops/postgres/upgrade/0.0.2.6.sql"
putStrLn "Then press enter key when you are done"
putStrLn "Manual method:"
putStrLn "Upgrade your GarganText instance with the script:"
putStrLn "Then press enter key to launch upgrade."
_ok <- getLine
[iniPath] <- getArgs
cfg <- readConfig iniPath
let
upgrade :: Cmd'' DevEnv GargError ()
-- upgrade :: Cmd'' DevEnv GargError ()
upgrade :: Cmd'' DevEnv IOException ()
upgrade = do
-- This method does not work for now
-- _ <- createTable_NgramsPostag
_ <- indexAllDocumentsWithPosTag
let repo_filepath = _gc_repofilepath cfg
repo <- getRepo
_ <- liftBase $ repoMigration repo_filepath repo
pure ()
withDevEnv iniPath $ \env -> do
_ <- runCmdDev env upgrade
putStrLn "Uprade"
putStrLn "Uprade done with success"
pure ()
package.yaml
View file @ fe831569
......@@ -43,18 +43,21 @@ library:
- Gargantext.API.Node
- Gargantext.API.Node.File
- Gargantext.API.Ngrams
- Gargantext.API.Ngrams.Tools
- Gargantext.API.Ngrams.Types
- Gargantext.API.Admin.Settings
- Gargantext.API.Admin.EnvTypes
- Gargantext.API.Admin.Types
- Gargantext.API.Prelude
- Gargantext.Core
- Gargantext.Core.NodeStory
- Gargantext.Core.Methods.Distances
- Gargantext.Core.Types
- Gargantext.Core.Types.Individu
- Gargantext.Core.Types.Main
- Gargantext.Core.Utils.Prefix
- Gargantext.Database.Action.Flow
- Gargantext.Database.Action.Flow.Types
- Gargantext.Database.Action.User.New
- Gargantext.Database.Query.Table.User
- Gargantext.Database.Query.Table.Node
......@@ -120,6 +123,7 @@ library:
- case-insensitive
- cassava
- cereal # (IGraph)
- cborg
- conduit
- conduit-extra
- containers
......
src/Gargantext/API.hs
View file @ fe831569
......@@ -28,36 +28,34 @@ Pouillard (who mainly made it).
{-# LANGUAGE ScopedTypeVariables #-}
---------------------------------------------------------------------
module Gargantext.API
where
---------------------------------------------------------------------
import Control.Exception (finally)
import Control.Lens
import Control.Monad.Reader (runReaderT)
import Data.List (lookup)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.IO (putStrLn)
import Data.Validity
import GHC.Base (Applicative)
import GHC.Generics (Generic)
import Network.HTTP.Types hiding (Query)
import Network.Wai
import Network.Wai.Handler.Warp hiding (defaultSettings)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger
import Servant
import System.IO (FilePath)
import Data.Text.IO (putStrLn)
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.Settings (newEnv)
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
import Gargantext.API.Ngrams (saveRepo)
import Gargantext.API.Ngrams.Types (HasRepoSaver(..))
import Gargantext.API.Ngrams (saveNodeStory)
import Gargantext.API.Prelude
import Gargantext.API.Routes
import Gargantext.API.Server (server)
import Gargantext.Core.NodeStory
import Gargantext.Prelude hiding (putStrLn)
import Network.HTTP.Types hiding (Query)
import Network.Wai
import Network.Wai.Handler.Warp hiding (defaultSettings)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger
import Servant
import System.IO (FilePath)
data Mode = Dev | Mock | Prod
......@@ -79,10 +77,10 @@ portRouteInfo port = do
putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
-- TODO clean this Monad condition (more generic) ?
stopGargantext :: HasRepoSaver env => env -> IO ()
stopGargantext :: HasNodeStorySaver env => env -> IO ()
stopGargantext env = do
putStrLn "----- Stopping gargantext -----"
runReaderT saveRepo env
runReaderT saveNodeStory env
{-
startGargantextMock :: PortNumber -> IO ()
......@@ -226,4 +224,4 @@ type family GenericTypeName t (r :: *) :: Symbol where
GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
-}
\ No newline at end of file
-}
src/Gargantext/API/Admin/EnvTypes.hs
View file @ fe831569
......@@ -14,23 +14,24 @@ 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.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Core.NodeStory
data Env = Env
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
, _env_pool :: !(Pool Connection)
, _env_repo :: !RepoEnv
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv
, _env_config :: !GargConfig
{ _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
}
deriving (Generic)
......@@ -42,17 +43,28 @@ instance HasConfig Env where
instance HasConnectionPool Env where
connPool = env_pool
instance HasNodeStoryEnv Env where
hasNodeStory = env_nodeStory
instance HasNodeStoryVar Env where
hasNodeStoryVar = hasNodeStory . nse_getter
instance HasNodeStorySaver Env where
hasNodeStorySaver = hasNodeStory . nse_saver
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 HasSettings Env where
settings = env_settings
instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
_env = env_scrapers . Servant.Job.Core._env
......@@ -68,11 +80,13 @@ data MockEnv = MockEnv
makeLenses ''MockEnv
data DevEnv = DevEnv
{ _dev_env_pool :: !(Pool Connection)
, _dev_env_repo :: !RepoEnv
, _dev_env_settings :: !Settings
, _dev_env_config :: !GargConfig
{ _dev_env_settings :: !Settings
, _dev_env_repo :: !RepoEnv
, _dev_env_config :: !GargConfig
, _dev_env_pool :: !(Pool Connection)
, _dev_env_nodeStory :: !NodeStoryEnv
}
makeLenses ''DevEnv
......@@ -83,14 +97,25 @@ instance HasConfig DevEnv where
instance HasConnectionPool DevEnv where
connPool = dev_env_pool
instance HasSettings DevEnv where
settings = dev_env_settings
instance HasNodeStoryEnv DevEnv where
hasNodeStory = dev_env_nodeStory
instance HasNodeStoryVar DevEnv where
hasNodeStoryVar = hasNodeStory . nse_getter
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 HasSettings DevEnv where
settings = dev_env_settings
src/Gargantext/API/Admin/Settings.hs
View file @ fe831569
......@@ -27,6 +27,8 @@ import Control.Monad.Reader
import Data.Maybe (fromMaybe)
import Data.Pool (Pool, createPool)
import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
import Gargantext.Core.NodeStory
import Gargantext.Prelude.Config (GargConfig(..), {-gc_repofilepath,-} readConfig)
import Network.HTTP.Client.TLS (newTlsManager)
import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
import Servant.Client (parseBaseUrl)
......@@ -38,12 +40,13 @@ import System.IO.Temp (withTempFile)
import System.Log.FastLogger
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.Prelude
import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig)
import Gargantext.Prelude.Config (gc_repofilepath)
devSettings :: FilePath -> IO Settings
devSettings jwkFile = do
......@@ -97,16 +100,20 @@ type RepoDirFilePath = FilePath
repoSnapshot :: RepoDirFilePath -> FilePath
repoSnapshot repoDir = repoDir <> "/repo.cbor"
-- | TODO add hard coded file in Settings
-- This assumes we own the lock on repoSnapshot.
repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO ()
repoSaverAction repoDir a = do
withTempFile "repos" "tmp-repo.cbor" $ \fp h -> do
withTempFile repoDir "tmp-repo.cbor" $ \fp h -> do
printDebug "repoSaverAction" fp
L.hPut h $ serialise a
hClose h
renameFile fp (repoSnapshot repoDir)
--{-
-- 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.
......@@ -155,43 +162,46 @@ readRepoEnv repoDir = do
-- TODO save in DB here
saver <- mkRepoSaver repoDir mvar
pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
--}
devJwkFile :: FilePath
devJwkFile = "dev.jwk"
newEnv :: PortNumber -> FilePath -> IO Env
newEnv port file = do
manager <- newTlsManager
manager_env <- newTlsManager
settings' <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
when (port /= settings' ^. appPort) $
panic "TODO: conflicting settings of port"
config' <- readConfig file
self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- databaseParameters file
pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath config')
scrapers_env <- newJobEnv defaultSettings manager
logger <- newStderrLoggerSet defaultBufSize
config_env <- readConfig file
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
pure $ Env
{ _env_settings = settings'
, _env_logger = logger
, _env_pool = pool
, _env_repo = repo
, _env_manager = manager
, _env_scrapers = scrapers_env
, _env_self_url = self_url
, _env_config = config'
{ _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
}
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)
repoSaverAction (env ^. hasConfig . gc_repofilepath) r
unlockFile (env ^. repoEnv . renv_lock)
type IniPath = FilePath
--}
src/Gargantext/API/Admin/Types.hs
View file @ fe831569
......@@ -9,10 +9,10 @@ import Control.Monad.Logger
import Data.ByteString (ByteString)
import GHC.Enum
import GHC.Generics (Generic)
import Gargantext.Prelude
import Servant.Auth.Server (JWTSettings, CookieSettings(..))
import Servant.Client (BaseUrl)
import Gargantext.Prelude
type PortNumber = Int
......@@ -42,4 +42,4 @@ class HasSettings env where
instance HasSettings Settings where
settings = identity
data FireWall = FireWall { unFireWall :: Bool }
\ No newline at end of file
data FireWall = FireWall { unFireWall :: Bool }
src/Gargantext/API/Dev.hs
View file @ fe831569
......@@ -15,16 +15,18 @@ module Gargantext.API.Dev where
import Control.Exception (finally)
import Control.Monad (fail)
import Control.Monad.Reader (runReaderT)
import Servant
import Gargantext.API.Prelude
import Gargantext.API.Admin.Settings
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Ngrams (saveRepo)
import Gargantext.API.Admin.Settings
import Gargantext.API.Ngrams (saveNodeStory)
import Gargantext.API.Prelude
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import Servant
import System.IO (FilePath)
type IniPath = FilePath
-------------------------------------------------------------------
withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
withDevEnv iniPath k = do
......@@ -35,12 +37,14 @@ withDevEnv iniPath k = do
newDevEnv = do
cfg <- readConfig iniPath
dbParam <- databaseParameters iniPath
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath cfg)
setts <- devSettings devJwkFile
pure $ DevEnv
{ _dev_env_pool = pool
, _dev_env_repo = repo
, _dev_env_nodeStory = nodeStory_env
, _dev_env_settings = setts
, _dev_env_config = cfg
}
......@@ -56,11 +60,11 @@ runCmdReplServantErr = runCmdRepl
-- the command.
-- This function is constrained to the DevEnv rather than
-- using HasConnectionPool and HasRepoVar.
runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
runCmdDev :: (Show err) => DevEnv -> Cmd'' DevEnv err a -> IO a
runCmdDev env f =
(either (fail . show) pure =<< runCmd env f)
`finally`
runReaderT saveRepo env
runReaderT saveNodeStory env
runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
runCmdDevNoErr = runCmdDev
......
src/Gargantext/API/Metrics.hs
View file @ fe831569
......@@ -30,10 +30,10 @@ import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeL
import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
import Gargantext.Core.Viz.Chart
import Gargantext.Core.Viz.Types
import Gargantext.Database.Action.Flow
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
......
src/Gargantext/API/Ngrams.hs
View file @ fe831569
This diff is collapsed.
src/Gargantext/API/Ngrams/List.hs
View file @ fe831569
......@@ -9,7 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
......@@ -18,33 +17,20 @@ module Gargantext.API.Ngrams.List
import Control.Lens hiding (elements, Indexed)
import Data.Aeson
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Csv as Csv
import Data.Either (Either(..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import Data.Map (Map, toList, fromList)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Text (Text, concat, pack)
import qualified Data.Text as Text
import Data.Vector (Vector)
import qualified Data.Vector as Vec
import Network.HTTP.Media ((//), (/:))
import qualified Prelude as Prelude
import Servant
import Servant.Job.Async
import qualified Protolude as P
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams (getNgramsTableMap, setListNgrams)
import Gargantext.API.Ngrams.List.Types
import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.API.Ngrams.Types
import Gargantext.API.Ngrams.List.Types
import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.Terms (ExtractedNgrams(..))
import Gargantext.Core.Text.Terms.WithList (buildPatterns, termsInText)
import Gargantext.Core.Types.Main (ListType(..))
......@@ -58,20 +44,29 @@ import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node
import Gargantext.Database.Types (Indexed(..))
import Gargantext.Prelude
import Network.HTTP.Media ((//), (/:))
import Servant
import Servant.Job.Async
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Csv as Csv
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vec
import qualified Prelude as Prelude
import qualified Protolude as P
------------------------------------------------------------------------
{-
-- | TODO refactor
{-
type API = Get '[JSON, HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
-- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool
:<|> PostAPI
:<|> CSVPostAPI
api :: ListId -> GargServer API
api l = get l :<|> postAsync l :<|> csvPostAsync l
-}
----------------------
type GETAPI = Summary "Get List"
:> "lists"
......@@ -86,7 +81,6 @@ instance Accept HTML where
instance ToJSON a => MimeRender HTML a where
mimeRender _ = encode
----------------------
type JSONAPI = Summary "Update List"
:> "lists"
......@@ -112,12 +106,8 @@ type CSVAPI = Summary "Update List (legacy v3 CSV)"
csvApi :: GargServer CSVAPI
csvApi = csvPostAsync
----------------------
------------------------------------------------------------------------
get :: RepoCmdM env err m =>
get :: HasNodeStory env err m =>
ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
get lId = do
lst <- get' lId
......@@ -128,7 +118,7 @@ get lId = do
]
) lst
get' :: RepoCmdM env err m
get' :: HasNodeStory env err m
=> ListId -> m NgramsList
get' lId = fromList
<$> zip ngramsTypes
......@@ -148,11 +138,10 @@ post l m = do
-- TODO reindex
pure True
-----------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Re-index documents of a corpus with new ngrams (called orphans here)
reIndexWith :: ( HasRepo env
, FlowCmdM env err m
reIndexWith :: ( HasNodeStory env err m
, FlowCmdM env err m
)
=> CorpusId
-> ListId
......@@ -252,6 +241,14 @@ postAsync' l (WithFile _ m _) logStatus = do
, _scst_events = Just []
}
------------------------------------------------------------------------
type CSVPostAPI = Summary "Update List (legacy v3 CSV)"
:> "csv"
:> "add"
:> "form"
:> "async"
:> AsyncJobs JobLog '[FormUrlEncoded] WithFile JobLog
readCsvText :: Text -> [(Text, Text, Text)]
readCsvText t = case eDec of
Left _ -> []
......@@ -300,6 +297,7 @@ csvPostAsync lId =
liftBase $ log' x
csvPostAsync' lId f log''
csvPostAsync' :: FlowCmdM env err m
=> ListId
-> WithTextFile
......@@ -318,5 +316,4 @@ csvPostAsync' l (WithTextFile _ m _) logStatus = do
, _scst_remaining = Just 0
, _scst_events = Just []
}
------------------------------------------------------------------------
src/Gargantext/API/Ngrams/Tools.hs
View file @ fe831569
......@@ -28,60 +28,102 @@ import Gargantext.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Gargantext.Core.NodeStory
mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
mergeNgramsElement _neOld neNew = neNew
type RootTerm = NgramsTerm
getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo = do
v <- view repoVar
liftBase $ readMVar v
listNgramsFromRepo :: [ListId] -> NgramsType
-> NgramsRepo -> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo nodeIds ngramsType repo = ngrams
where
ngramsMap = repo ^. r_state . at ngramsType . _Just
-- TODO HashMap linked
ngrams = HM.fromList $ Map.toList $ Map.unionsWith mergeNgramsElement
[ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
getRepo' :: HasNodeStory env err m
=> [ListId] -> m NodeListStory
getRepo' listIds = do
f <- getNodeListStory
v <- liftBase $ f listIds
v' <- liftBase $ readMVar v
pure $ v'
getNodeStoryVar :: HasNodeStory env err m
=> [ListId] -> m (MVar NodeListStory)
getNodeStoryVar l = do
f <- getNodeListStory
v <- liftBase $ f l
pure v
getNodeListStory :: HasNodeStory env err m
=> m ([NodeId] -> IO (MVar NodeListStory))
getNodeListStory = do
env <- view hasNodeStory
pure $ view nse_getter env
listNgramsFromRepo :: [ListId]
-> NgramsType
-> NodeListStory
-> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo nodeIds ngramsType repo =
HM.fromList $ Map.toList
$ Map.unionsWith mergeNgramsElement ngrams
where
ngrams = [ repo
^. unNodeStory
. at nodeId . _Just
. a_state
. at ngramsType . _Just
| nodeId <- nodeIds
]
-- TODO-ACCESS: We want to do the security check before entering here.
-- Add a static capability parameter would be nice.
-- Ideally this is the access to `repoVar` which needs to
-- be properly guarded.
getListNgrams :: RepoCmdM env err m
getListNgrams :: HasNodeStory env err m
=> [ListId] -> NgramsType
-> m (HashMap NgramsTerm NgramsRepoElement)
getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType
<$> getRepo' nodeIds
getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
getTermsWith :: (HasNodeStory env err m, Eq a, Hashable a)
=> (NgramsTerm -> a) -> [ListId]
-> NgramsType -> Set ListType
-> m (HashMap a [a])
getTermsWith f ls ngt lts = HM.fromListWith (<>)
getTermsWith f ls ngt lts = HM.fromListWith (<>)
<$> map toTreeWith
<$> HM.toList
<$> HM.filter (\f' -> Set.member (fst f') lts)
<$> mapTermListRoot ls ngt
<$> getRepo
<$> getRepo' ls
where
toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
Nothing -> (f t, [])
Just r -> (f r, [f t])
mapTermListRoot :: [ListId]
-> NgramsType
-> NgramsRepo
-> NodeListStory
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot nodeIds ngramsType repo =
(\nre -> (_nre_list nre, _nre_root nre))
<$> listNgramsFromRepo nodeIds ngramsType repo
filterListWithRootHashMap :: ListType
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (Maybe RootTerm)
......@@ -122,11 +164,17 @@ groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
data Diagonal = Diagonal Bool
getCoocByNgrams :: Diagonal -> HashMap NgramsTerm (Set NodeId) -> HashMap (NgramsTerm, NgramsTerm) Int
getCoocByNgrams :: Diagonal
-> HashMap NgramsTerm (Set NodeId)
-> HashMap (NgramsTerm, NgramsTerm) Int
getCoocByNgrams = getCoocByNgrams' identity
getCoocByNgrams' :: (Hashable a, Ord a, Ord c) => (b -> Set c) -> Diagonal -> HashMap a b -> HashMap (a, a) Int
getCoocByNgrams' :: (Hashable a, Ord a, Ord c)
=> (b -> Set c)
-> Diagonal
-> HashMap a b
-> HashMap (a, a) Int
getCoocByNgrams' f (Diagonal diag) m =
HM.fromList [( (t1,t2)
, maybe 0 Set.size $ Set.intersection
......
src/Gargantext/API/Ngrams/Types.hs
View file @ fe831569
......@@ -12,8 +12,7 @@ module Gargantext.API.Ngrams.Types where
import Codec.Serialise (Serialise())
import Control.Category ((>>>))
import Control.Concurrent
import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
import Control.Monad.Reader
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 Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON)
......@@ -23,7 +22,7 @@ import Data.Hashable (Hashable)
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..),PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace,MaybePatch(Mod), unMod, old, new)
import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
import Data.Set (Set)
import Data.String (IsString, fromString)
import Data.Swagger hiding (version, patch)
......@@ -32,10 +31,9 @@ import Data.Validity
import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
import GHC.Generics (Generic)
import Gargantext.Core.Text (size)
import Gargantext.Core.Types (ListType(..), ListId, NodeId)
import Gargantext.Core.Types (TODO)
import Gargantext.Core.Types (ListType(..), ListId, NodeId, TODO)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Prelude (fromField', CmdM', HasConnectionPool, HasConfig)
import Gargantext.Database.Prelude (fromField', HasConnectionPool, HasConfig, CmdM')
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
import Protolude (maybeToEither)
......@@ -53,6 +51,7 @@ import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
------------------------------------------------------------------------
type QueryParamR = QueryParam' '[Required, Strict]
------------------------------------------------------------------------
--data FacetFormat = Table | Chart
......@@ -251,16 +250,16 @@ toNgramsElement ns = map toNgramsElement' ns
mockTable :: NgramsTable
mockTable = NgramsTable
[ mkNgramsElement "animal" MapTerm Nothing (mSetFromList ["dog", "cat"])
, mkNgramsElement "cat" MapTerm (rp "animal") mempty
[ mkNgramsElement "animal" MapTerm Nothing (mSetFromList ["dog", "cat"])
, mkNgramsElement "cat" MapTerm (rp "animal") mempty
, mkNgramsElement "cats" StopTerm Nothing mempty
, mkNgramsElement "dog" MapTerm (rp "animal") (mSetFromList ["dogs"])
, mkNgramsElement "dog" MapTerm (rp "animal") (mSetFromList ["dogs"])
, mkNgramsElement "dogs" StopTerm (rp "dog") mempty
, mkNgramsElement "fox" MapTerm Nothing mempty
, mkNgramsElement "fox" MapTerm Nothing mempty
, mkNgramsElement "object" CandidateTerm Nothing mempty
, mkNgramsElement "nothing" StopTerm Nothing mempty
, mkNgramsElement "organic" MapTerm Nothing (mSetFromList ["flower"])
, mkNgramsElement "flower" MapTerm (rp "organic") mempty
, mkNgramsElement "organic" MapTerm Nothing (mSetFromList ["flower"])
, mkNgramsElement "flower" MapTerm (rp "organic") mempty
, mkNgramsElement "moon" CandidateTerm Nothing mempty
, mkNgramsElement "sky" StopTerm Nothing mempty
]
......@@ -533,6 +532,7 @@ instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTable
type instance ConflictResolution NgramsTablePatch =
NgramsTerm -> ConflictResolutionNgramsPatch
type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
-- ~ Patched (PatchMap NgramsTerm NgramsPatch)
type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
......@@ -577,7 +577,7 @@ ngramsElementFromRepo
, _ne_parent = p
, _ne_children = c
, _ne_ngrams = ngrams
, _ne_occurrences = panic $ "API.Ngrams._ne_occurrences"
, _ne_occurrences = panic $ "API.Ngrams.Types._ne_occurrences"
{-
-- Here we could use 0 if we want to avoid any `panic`.
-- It will not happen using getTableNgrams if
......@@ -666,6 +666,8 @@ instance Arbitrary a => Arbitrary (VersionedWithCount a) where
toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_
------------------------------------------------------------------------
-- | TOREMOVE
data Repo s p = Repo
{ _r_version :: !Version
, _r_state :: !s
......@@ -674,6 +676,13 @@ 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
parseJSON = genericParseJSON $ unPrefix "_r_"
......@@ -688,10 +697,6 @@ makeLenses ''Repo
initRepo :: Monoid s => Repo s p
initRepo = Repo 1 mempty []
type NgramsRepo = Repo NgramsState NgramsStatePatch
type NgramsState = Map TableNgrams.NgramsType (Map NodeId NgramsTableMap)
type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
instance Serialise (PM.PatchMap NodeId NgramsTablePatch)
instance Serialise NgramsStatePatch
......@@ -703,6 +708,8 @@ initMockRepo = Repo 1 s []
$ Map.fromList
[ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
--------------------
data RepoEnv = RepoEnv
{ _renv_var :: !(MVar NgramsRepo)
, _renv_saver :: !(IO ())
......@@ -712,36 +719,32 @@ data RepoEnv = RepoEnv
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)
instance HasRepoVar (MVar NgramsRepo) where
repoVar = identity
class HasRepoSaver env where
repoSaver :: Getter env (IO ())
class (HasRepoVar env, HasRepoSaver env) => HasRepo env where
repoEnv :: Getter env RepoEnv
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
type RepoCmdM env err m =
( CmdM' env err m
, HasRepo env
, HasConnectionPool env
, HasConfig env
)
type QueryParamR = QueryParam' '[Required, Strict]
------------------------------------------------------------------------
-- Instances
......@@ -756,13 +759,13 @@ instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
ngramsTypeFromTabType tabType =
let lieu = "Garg.API.Ngrams: " :: Text in
let here = "Garg.API.Ngrams: " :: Text in
case tabType of
Sources -> TableNgrams.Sources
Authors -> TableNgrams.Authors
Institutes -> TableNgrams.Institutes
Terms -> TableNgrams.NgramsTerms
_ -> panic $ lieu <> "No Ngrams for this tab"
_ -> panic $ here <> "No Ngrams for this tab"
-- TODO: This `panic` would disapear with custom NgramsType.
----
......
src/Gargantext/API/Node/Contact.hs
View file @ fe831569
......@@ -92,7 +92,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) [[hyperdataContact fn ln]]
_ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing [[hyperdataContact fn ln]]
pure JobLog { _scst_succeeded = Just 2
, _scst_failed = Just 0
......
src/Gargantext/API/Node/Corpus/Export.hs
View file @ fe831569
......@@ -26,10 +26,11 @@ import qualified Data.HashMap.Strict as HashMap
import Gargantext.API.Node.Corpus.Export.Types
import Gargantext.API.Ngrams.Types
import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo')
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Prelude.Crypto.Hash (hash)
import Gargantext.Core.Types
import Gargantext.Core.NodeStory
import Gargantext.Database.Action.Metrics.NgramsByNode (getNgramsByNodeOnlyUser)
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
......@@ -58,7 +59,8 @@ getCorpus cId lId nt' = do
ns <- Map.fromList
<$> map (\n -> (_node_id n, n))
<$> selectDocNodes cId
repo <- getRepo
repo <- getRepo' [fromMaybe (panic "[Gargantext.API.Node.Corpus.Export]") lId]
ngs <- getNodeNgrams cId lId nt repo
let -- uniqId is hash computed already for each document imported in database
r = Map.intersectionWith (\a b -> Document a (Ngrams (Set.toList b) (hash b)) (d_hash a b)
......@@ -75,7 +77,7 @@ getNodeNgrams :: HasNodeError err
=> CorpusId
-> Maybe ListId
-> NgramsType
-> NgramsRepo
-> NodeListStory
-> Cmd err (Map NodeId (Set NgramsTerm))
getNodeNgrams cId lId' nt repo = do
lId <- case lId' of
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ fe831569
......@@ -49,7 +49,8 @@ import qualified Gargantext.Core.Text.Corpus.API as API
import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileFormat(..), parseFormat)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpus, getDataText, flowDataText, TermType(..){-, allDataOrigins-})
import Gargantext.Database.Action.Flow (flowCorpus, getDataText, flowDataText, TermType(..){-, allDataOrigins-})
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Mail (sendMail)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Action.User (getUserId)
......@@ -136,6 +137,7 @@ data WithQuery = WithQuery
, _wq_datafield :: !Datafield
, _wq_lang :: !Lang
, _wq_node_id :: !Int
-- , _wq_flowListWith :: !FlowSocialListWith
}
deriving Generic
......@@ -212,7 +214,7 @@ addToCorpusWithQuery user cid (WithQuery q dbs datafield l _nid) maybeLimit logS
, _scst_events = Just []
}
cids <- mapM (\txt -> flowDataText user txt (Multi l) cid) txts
cids <- mapM (\txt -> flowDataText user txt (Multi l) cid Nothing) txts
printDebug "corpus id" cids
printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
sendMail user
......@@ -264,6 +266,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
_cid' <- flowCorpus user
(Right [cid])
(Multi $ fromMaybe EN l)
Nothing
(map (map toHyperdataDocument) docs)
printDebug "Extraction finished : " cid
......
src/Gargantext/API/Node/Corpus/Searx.hs
View file @ fe831569
......@@ -3,6 +3,8 @@
module Gargantext.API.Node.Corpus.Searx where
import Control.Lens (view)
import qualified Data.Aeson as Aeson
import Data.Aeson.TH (deriveJSON)
......@@ -19,7 +21,7 @@ import Gargantext.Prelude.Config
import Gargantext.Core (Lang(..))
import qualified Gargantext.Core.Text.Corpus.API as API
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Action.Flow (FlowCmdM)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Node (CorpusId)
import Gargantext.Database.Prelude (hasConfig)
......
src/Gargantext/API/Prelude.hs
View file @ fe831569
......@@ -33,7 +33,7 @@ import Data.Typeable
import Data.Validity
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Types
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
......@@ -51,10 +51,10 @@ joseError = throwError . (_JoseError #)
type EnvC env =
( HasConnectionPool env
, HasRepo env -- TODO rename HasNgramsRepo
, HasSettings env -- TODO rename HasDbSettings
, HasJobEnv env JobLog JobLog
, HasConfig env
, HasNodeStoryEnv env
)
type ErrC err =
......@@ -69,6 +69,7 @@ type ErrC err =
type GargServerC env err m =
( CmdRandom env err m
, HasNodeStory env err m
, EnvC env
, ErrC err
, MimeRender JSON err
......@@ -91,7 +92,7 @@ type GargNoServer t =
type GargNoServer' env err m =
( CmdM env err m
, HasRepo env
, HasNodeStory env err m
, HasSettings env
, HasNodeError err
)
......
src/Gargantext/API/Search.hs
View file @ fe831569
......@@ -66,7 +66,7 @@ api nId (SearchQuery q SearchContact) o l order = do
<$> SearchResultContact
<$> map (toRow aId)
<$> searchInCorpusWithContacts nId aId q o l order
api _ _ _ _ _ = undefined
api _ _ _ _ _ = panic "[G.A.Search.api] undefined"
-----------------------------------------------------------------------
-----------------------------------------------------------------------
......
src/Gargantext/API/Swagger.hs
View file @ fe831569
......@@ -25,7 +25,7 @@ import Gargantext.Prelude
-- | Swagger Specifications
swaggerDoc :: Swagger
swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
& info.title .~ "Gargantext"
& info.title .~ "GarganText"
& info.version .~ (cs $ showVersion PG.version)
-- & info.base_url ?~ (URL "http://gargantext.org/")
& info.description ?~ "REST API specifications"
......@@ -34,4 +34,4 @@ swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
["Gargantext" & description ?~ "Main operations"]
& info.license ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
where
urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
\ No newline at end of file
urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
src/Gargantext/Core/NodeStory.hs 0 → 100644
View file @ fe831569
This diff is collapsed.
src/Gargantext/Core/Text/List.hs
View file @ fe831569
......@@ -23,7 +23,8 @@ import Data.Monoid (mempty)
import Data.Ord (Down(..))
import Data.Set (Set)
import Data.Tuple.Extra (both)
import Gargantext.API.Ngrams.Types (NgramsElement, RepoCmdM, NgramsTerm(..))
import Gargantext.API.Ngrams.Types (NgramsElement, NgramsTerm(..))
import Gargantext.Core.NodeStory
import Gargantext.Core.Text (size)
import Gargantext.Core.Text.List.Group
import Gargantext.Core.Text.List.Group.Prelude
......@@ -34,22 +35,22 @@ import Gargantext.Core.Text.Metrics (scored', Scored(..), scored_speExc, scored_
import Gargantext.Core.Types (ListType(..), MasterCorpusId, UserCorpusId)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getNodesByNgramsOnlyUser)
import Gargantext.Database.Action.Metrics.TFICF (getTficf)
import Gargantext.Database.Action.Metrics.TFICF (getTficf_withSample)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (CmdM)
import Gargantext.Database.Query.Table.Ngrams (text2ngrams)
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.NgramsPostag (selectLems)
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Database.Query.Tree.Error (HasTreeError)
import Gargantext.Database.Schema.Ngrams (NgramsType(..), Ngrams(..))
import Gargantext.Prelude
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
import qualified Data.HashSet as HashSet
{-
-- TODO maybe useful for later
......@@ -61,19 +62,20 @@ isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
-- | TODO improve grouping functions of Authors, Sources, Institutes..
buildNgramsLists :: ( RepoCmdM env err m
buildNgramsLists :: ( HasNodeStory env err m
, CmdM env err m
, HasTreeError err
, HasNodeError err
)
=> GroupParams
-> User
=> User
-> UserCorpusId
-> MasterCorpusId
-> Maybe FlowSocialListWith
-> GroupParams
-> m (Map NgramsType [NgramsElement])
buildNgramsLists gp user uCid mCid = do
ngTerms <- buildNgramsTermsList user uCid mCid gp (NgramsTerms, MapListSize 350)
othersTerms <- mapM (buildNgramsOthersList user uCid GroupIdentity)
buildNgramsLists user uCid mCid mfslw gp = do
ngTerms <- buildNgramsTermsList user uCid mCid mfslw gp (NgramsTerms, MapListSize 350)
othersTerms <- mapM (buildNgramsOthersList user uCid mfslw GroupIdentity)
[ (Authors , MapListSize 9)
, (Sources , MapListSize 9)
, (Institutes, MapListSize 9)
......@@ -86,20 +88,21 @@ data MapListSize = MapListSize { unMapListSize :: !Int }
buildNgramsOthersList ::( HasNodeError err
, CmdM env err m
, RepoCmdM env err m
, HasNodeStory env err m
, HasTreeError err
)
=> User
-> UserCorpusId
-> Maybe FlowSocialListWith
-> GroupParams
-> (NgramsType, MapListSize)
-> m (Map NgramsType [NgramsElement])
buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
buildNgramsOthersList user uCid mfslw _groupParams (nt, MapListSize mapListSize) = do
allTerms :: HashMap NgramsTerm (Set NodeId) <- getNodesByNgramsUser uCid nt
-- PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists :: FlowCont NgramsTerm FlowListScores
<- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
<- flowSocialList mfslw user nt ( FlowCont HashMap.empty
$ HashMap.fromList
$ List.zip (HashMap.keys allTerms)
(List.cycle [mempty])
......@@ -128,7 +131,7 @@ buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
getGroupParams :: ( HasNodeError err
, CmdM env err m
, RepoCmdM env err m
, HasNodeStory env err m
, HasTreeError err
)
=> GroupParams -> HashSet Ngrams -> m GroupParams
......@@ -142,28 +145,34 @@ getGroupParams gp _ = pure gp
-- TODO use ListIds
buildNgramsTermsList :: ( HasNodeError err
, CmdM env err m
, RepoCmdM env err m
, HasNodeStory env err m
, HasTreeError err
)
=> User
-> UserCorpusId
-> MasterCorpusId
-> Maybe FlowSocialListWith
-> GroupParams
-> (NgramsType, MapListSize)
-> m (Map NgramsType [NgramsElement])
buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
buildNgramsTermsList user uCid mCid mfslw groupParams (nt, _mapListSize)= do
-- Filter 0 With Double
-- Computing global speGen score
allTerms :: HashMap NgramsTerm Double <- getTficf uCid mCid nt
printDebug "[buldNgramsTermsList: Sample List] / start" nt
allTerms :: HashMap NgramsTerm Double <- getTficf_withSample uCid mCid nt
printDebug "[buldNgramsTermsList: Sample List / end]" nt
printDebug "[buldNgramsTermsList: Flow Social List / start]" nt
-- PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists :: FlowCont NgramsTerm FlowListScores
<- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
<- flowSocialList mfslw user nt ( FlowCont HashMap.empty
$ HashMap.fromList
$ List.zip (HashMap.keys allTerms)
(List.cycle [mempty])
)
printDebug "[buldNgramsTermsList: Flow Social List / end]" nt
let ngramsKeys = HashMap.keysSet allTerms
groupParams' <- getGroupParams groupParams (HashSet.map (text2ngrams . unNgramsTerm) ngramsKeys)
......@@ -214,7 +223,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
$ setScoresWithMap mapTextDocIds (groupedMonoHead <> groupedMultHead)
printDebug "groupedTreeScores_SetNodeId" groupedTreeScores_SetNodeId
--printDebug "groupedTreeScores_SetNodeId" groupedTreeScores_SetNodeId
-- Coocurrences computation
--, t1 >= t2 -- permute byAxis diag -- since matrix symmetric
......
src/Gargantext/Core/Text/List/Social.hs
View file @ fe831569
......@@ -16,6 +16,7 @@ import Data.Map (Map)
import Data.Monoid (mconcat)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.List.Social.Find
import Gargantext.Core.Text.List.Social.History
import Gargantext.Core.Text.List.Social.Patch
......@@ -35,8 +36,12 @@ import Gargantext.Prelude
-- | FlowSocialListPriority
-- Sociological assumption: either private or others (public) first
-- This parameter depends on the user choice
data FlowSocialListPriority = MySelfFirst | OthersFirst
data FlowSocialListWith = FlowSocialListWithPriority { fslw_priority :: FlowSocialListPriority }
| FlowSocialListWithLists { fslw_lists :: [ListId] }
data FlowSocialListPriority = MySelfFirst | OthersFirst
flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
......@@ -49,7 +54,21 @@ keepAllParents _ = KeepAllParents True
-}
------------------------------------------------------------------------
flowSocialList :: ( RepoCmdM env err m
flowSocialList :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> Maybe FlowSocialListWith
-> User
-> NgramsType
-> FlowCont NgramsTerm FlowListScores
-> m (FlowCont NgramsTerm FlowListScores)
flowSocialList Nothing u = flowSocialList' MySelfFirst u
flowSocialList (Just (FlowSocialListWithPriority p)) u = flowSocialList' p u
flowSocialList (Just (FlowSocialListWithLists ls)) _ = getHistoryScores ls History_User
flowSocialList' :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
......@@ -58,12 +77,12 @@ flowSocialList :: ( RepoCmdM env err m
-> User -> NgramsType
-> FlowCont NgramsTerm FlowListScores
-> m (FlowCont NgramsTerm FlowListScores)
flowSocialList flowPriority user nt flc =
flowSocialList' flowPriority user nt flc =
mconcat <$> mapM (flowSocialListByMode' user nt flc)
(flowSocialListPriority flowPriority)
where
flowSocialListByMode' :: ( RepoCmdM env err m
flowSocialListByMode' :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
......@@ -77,7 +96,7 @@ flowSocialList flowPriority user nt flc =
>>= flowSocialListByModeWith nt' flc'
flowSocialListByModeWith :: ( RepoCmdM env err m
flowSocialListByModeWith :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
......@@ -87,27 +106,24 @@ flowSocialList flowPriority user nt flc =
-> [ListId]
-> m (FlowCont NgramsTerm FlowListScores)
flowSocialListByModeWith nt'' flc'' listes =
getHistoryScores History_User nt'' flc'' listes
{-
mapM (\l -> getListNgrams [l] nt'') listes
>>= pure
. toFlowListScores (keepAllParents nt'') flc''
-}
getHistoryScores listes History_User nt'' flc''
-----------------------------------------------------------------
getHistoryScores :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
getHistoryScores :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> History
=> [ListId]
-> History
-> NgramsType
-> FlowCont NgramsTerm FlowListScores
-> [ListId]
-> m (FlowCont NgramsTerm FlowListScores)
getHistoryScores hist nt fl listes =
addScorePatches nt listes fl <$> getHistory hist nt listes
getHistoryScores lists hist nt fl =
addScorePatches nt lists fl <$> getHistory hist nt lists
getHistory :: ( RepoCmdM env err m
getHistory :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
......@@ -115,7 +131,7 @@ getHistory :: ( RepoCmdM env err m
=> History
-> NgramsType
-> [ListId]
-> m (Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch]))
-> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
getHistory hist nt listes =
history hist [nt] listes <$> getRepo
history hist [nt] listes <$> getRepo' listes
src/Gargantext/Core/Text/List/Social/History.hs
View file @ fe831569
......@@ -15,6 +15,7 @@ import Control.Lens hiding (cons)
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Types (ListId)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
......@@ -37,8 +38,8 @@ data History = History_User
history :: History
-> [NgramsType]
-> [ListId]
-> Repo s NgramsStatePatch
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> NodeStory s NgramsStatePatch'
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
history History_User t l = clean . (history' t l)
where
clean = Map.map (Map.map List.init)
......@@ -53,35 +54,19 @@ history _ t l = history' t l
------------------------------------------------------------------------
history' :: [NgramsType]
-> [ListId]
-> Repo s NgramsStatePatch
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
history' types lists = merge
. map (Map.map ( Map.map cons))
. map (Map.map ((Map.filterWithKey (\k _ -> List.elem k lists))))
. map (Map.filterWithKey (\k _ -> List.elem k types))
. map toMap
. view r_history
merge :: [Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])]
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
merge = Map.unionsWith merge'
-> NodeStory s NgramsStatePatch'
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
history' types lists = (Map.map (Map.unionsWith (<>)))
. (Map.map (map (Map.filterWithKey (\k _ -> List.elem k types))))
. (Map.map (map toMap))
. (Map.map (view a_history))
. (Map.filterWithKey (\k _ -> List.elem k lists))
. (view unNodeStory)
where
merge' :: Map ListId [HashMap NgramsTerm NgramsPatch]
-> Map ListId [HashMap NgramsTerm NgramsPatch]
-> Map ListId [HashMap NgramsTerm NgramsPatch]
merge' = Map.unionWith (<>)
toMap :: PatchMap NgramsType NgramsTablePatch
-> Map NgramsType [HashMap NgramsTerm NgramsPatch]
toMap m = Map.map (cons . unNgramsTablePatch)
$ unPatchMapToMap m
toMap :: PatchMap NgramsType
(PatchMap ListId
(NgramsTablePatch
)
)
-> Map NgramsType
(Map ListId
(HashMap NgramsTerm NgramsPatch
)
)
toMap = Map.map (Map.map unNgramsTablePatch) . (Map.map unPatchMapToMap) . unPatchMapToMap
src/Gargantext/Core/Text/List/Social/Patch.hs
View file @ fe831569
......@@ -30,27 +30,29 @@ import qualified Data.Patch.Class as Patch (Replace(..))
addScorePatches :: NgramsType -> [ListId]
-> FlowCont NgramsTerm FlowListScores
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
-> FlowCont NgramsTerm FlowListScores
addScorePatches nt listes fl repo = foldl' (addScorePatchesList nt repo) fl listes
addScorePatches nt listes fl repo =
foldl' (addScorePatchesList nt repo) fl listes
addScorePatchesList :: NgramsType
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-- -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
-> FlowCont NgramsTerm FlowListScores
-> ListId
-> FlowCont NgramsTerm FlowListScores
addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches
addScorePatchesList nt repo fl lid =
foldl' addScorePatch fl patches
where
patches = maybe [] (List.concat . (map HashMap.toList)) patches'
patches' = do
lists <- Map.lookup nt repo
mapPatches <- Map.lookup lid lists
lists <- Map.lookup lid repo
mapPatches <- Map.lookup nt lists
pure mapPatches
addScorePatch :: FlowCont NgramsTerm FlowListScores
-> (NgramsTerm , NgramsPatch)
-> FlowCont NgramsTerm FlowListScores
......
src/Gargantext/Core/Viz/Chart.hs
View file @ fe831569
......@@ -35,7 +35,7 @@ import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Metrics.NgramsByNode
import Gargantext.Database.Schema.Ngrams
import Gargantext.Core.Viz.Types
......@@ -59,7 +59,7 @@ chartData :: FlowCmdM env err m
chartData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt <$> getRepo
ts <- mapTermListRoot ls nt <$> getRepo' ls
let
dico = filterListWithRoot lt ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
......@@ -79,7 +79,7 @@ treeData :: FlowCmdM env err m
treeData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt <$> getRepo
ts <- mapTermListRoot ls nt <$> getRepo' ls
let
dico = filterListWithRoot lt ts
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ fe831569
......@@ -16,18 +16,18 @@ Portability : POSIX
module Gargantext.Core.Viz.Graph.API
where
import Control.Lens (set, (^.), _Just, (^?))
import Control.Lens (set, (^.), _Just, (^?), at)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Swagger
import Data.Text
import Data.Text hiding (head)
import Debug.Trace (trace)
import GHC.Generics (Generic)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
import Gargantext.API.Prelude
import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
import Gargantext.Core.NodeStory
import Gargantext.Core.Types.Main
import Gargantext.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.GEXF ()
......@@ -42,13 +42,14 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Table.Node.User (getNodeUser)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node (node_parent_id, node_hyperdata, node_name, node_user_id)
import Gargantext.Prelude
import Servant
import Servant.Job.Async
import Servant.XML
import qualified Data.HashMap.Strict as HashMap
------------------------------------------------------------------------
-- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node.
......@@ -80,7 +81,6 @@ graphAPI u n = getGraph u n
getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
getGraph _uId nId = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
repo <- getRepo
let
graph = nodeGraph ^. node_hyperdata . hyperdataGraph
......@@ -89,6 +89,9 @@ getGraph _uId nId = do
identity
$ nodeGraph ^. node_parent_id
listId <- defaultList cId
repo <- getRepo' [listId]
-- TODO Distance in Graph params
case graph of
Nothing -> do
......@@ -118,9 +121,7 @@ recomputeGraph _uId nId maybeDistance = do
Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
_ -> maybeDistance
repo <- getRepo
let
v = repo ^. r_version
cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
identity
$ nodeGraph ^. node_parent_id
......@@ -128,6 +129,10 @@ recomputeGraph _uId nId maybeDistance = do
Nothing -> withMetric Order1
Just m -> withMetric m
listId <- defaultList cId
repo <- getRepo' [listId]
let v = repo ^. unNodeStory . at listId . _Just . a_version
case graph of
Nothing -> do
graph' <- computeGraph cId similarity NgramsTerms repo
......@@ -150,7 +155,7 @@ computeGraph :: HasNodeError err
=> CorpusId
-> Distance
-> NgramsType
-> NgramsRepo
-> NodeListStory
-> Cmd err Graph
computeGraph cId d nt repo = do
lId <- defaultList cId
......@@ -175,7 +180,7 @@ computeGraph cId d nt repo = do
defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> Text
-> NgramsRepo
-> NodeListStory
-> GraphMetric
-> Cmd err GraphMetadata
defaultGraphMetadata cId t repo gm = do
......@@ -191,7 +196,7 @@ defaultGraphMetadata cId t repo gm = do
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
, _gm_list = (ListForGraph lId (repo ^. r_version))
, _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
, _gm_startForceAtlas = True
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
......@@ -252,8 +257,13 @@ graphVersions nId = do
. gm_list
. lfg_version
repo <- getRepo
let v = repo ^. r_version
cId = maybe (panic "[G.V.G.API] Node has no parent")
identity
$ nodeGraph ^. node_parent_id
listId <- defaultList cId
repo <- getRepo' [listId]
let v = repo ^. unNodeStory . at listId . _Just . a_version
pure $ GraphVersions { gv_graph = listVersion
, gv_repo = v }
......
src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs
View file @ fe831569
......@@ -28,13 +28,13 @@ import Gargantext.Core.Text.Context (TermList)
import Gargantext.Core.Text.Terms.WithList
import Gargantext.Database.Query.Table.Node(defaultList)
import Gargantext.Prelude
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.Flow.Types
import Gargantext.Core.Viz.LegacyPhylo hiding (Svg, Dot)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Database.Query.Table.NodeNode (selectDocs)
import Gargantext.Core.Types
import Gargantext.Core (HasDBid)
-- import Gargantext.Core.Viz.Phylo.LevelMaker (toPhylo)
-- import Gargantext.Core.Viz.Phylo.Tools
......@@ -46,7 +46,7 @@ import qualified Data.Text as Text
type MinSizeBranch = Int
flowPhylo :: FlowCmdM env err m
flowPhylo :: (FlowCmdM env err m, HasDBid NodeType)
=> CorpusId
-> m Phylo
flowPhylo cId = do
......
src/Gargantext/Database/Action/Delete.hs
View file @ fe831569
......@@ -36,7 +36,9 @@ import Gargantext.Prelude
import qualified Gargantext.Database.GargDB as GargDB
------------------------------------------------------------------------
-- TODO
-- Delete Corpus children accoring its types
-- Delete NodeList (NodeStory + cbor file)
deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
=> User
-> NodeId
......@@ -44,7 +46,7 @@ deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
deleteNode u nodeId = do
node' <- N.getNode nodeId
case (view node_typename node') of
nt | nt == toDBid NodeUser -> panic "Not allowed to delete NodeUser (yet)"
nt | nt == toDBid NodeUser -> panic "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
nt | nt == toDBid NodeTeam -> do
uId <- getUserId u
if _node_user_id node' == uId
......
src/Gargantext/Database/Action/Flow.hs
View file @ fe831569
......@@ -24,8 +24,7 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
( FlowCmdM
, getDataText
( getDataText
, flowDataText
, flow
......@@ -73,6 +72,7 @@ import Gargantext.Core.Text
import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat)
import Gargantext.Core.Text.List (buildNgramsLists)
import Gargantext.Core.Text.List.Social (FlowSocialListWith)
import Gargantext.Core.Text.Terms
import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
import Gargantext.Core.Types (POS(NP))
......@@ -152,11 +152,12 @@ flowDataText :: ( FlowCmdM env err m
-> DataText
-> TermType Lang
-> CorpusId
-> Maybe FlowSocialListWith
-> m CorpusId
flowDataText u (DataOld ids) tt cid = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids
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 = flowCorpus u (Right [cid]) tt txt
flowDataText u (DataNew txt) tt cid mfslw = flowCorpus u (Right [cid]) tt mfslw txt
------------------------------------------------------------------------
-- TODO use proxy
......@@ -168,7 +169,7 @@ flowAnnuaire :: (FlowCmdM env err m)
-> m AnnuaireId
flowAnnuaire u n l filePath = do
docs <- liftBase $ (( splitEvery 500 <$> readFile_Annuaire filePath) :: IO [[HyperdataContact]])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing docs
------------------------------------------------------------------------
flowCorpusFile :: (FlowCmdM env err m)
......@@ -176,13 +177,14 @@ flowCorpusFile :: (FlowCmdM env err m)
-> Either CorpusName [CorpusId]
-> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang -> FileFormat -> FilePath
-> Maybe FlowSocialListWith
-> m CorpusId
flowCorpusFile u n l la ff fp = do
flowCorpusFile u n l la ff fp mfslw = do
eParsed <- liftBase $ parseFile ff fp
case eParsed of
Right parsed -> do
let docs = splitEvery 500 $ take l parsed
flowCorpus u n la (map (map toHyperdataDocument) docs)
flowCorpus u n la mfslw (map (map toHyperdataDocument) docs)
Left e -> panic $ "Error: " <> (T.pack e)
------------------------------------------------------------------------
......@@ -192,6 +194,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
=> User
-> Either CorpusName [CorpusId]
-> TermType Lang
-> Maybe FlowSocialListWith
-> [[a]]
-> m CorpusId
flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
......@@ -205,12 +208,13 @@ flow :: ( FlowCmdM env err m
-> User
-> Either CorpusName [CorpusId]
-> TermType Lang
-> Maybe FlowSocialListWith
-> [[a]]
-> m CorpusId
flow c u cn la docs = do
flow c u cn la mfslw docs = do
-- TODO if public insertMasterDocs else insertUserDocs
ids <- traverse (insertMasterDocs c la) docs
flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
flowCorpusUser (la ^. tt_lang) u cn c (concat ids) mfslw
------------------------------------------------------------------------
flowCorpusUser :: ( FlowCmdM env err m
......@@ -221,8 +225,9 @@ flowCorpusUser :: ( FlowCmdM env err m
-> Either CorpusName [CorpusId]
-> Maybe c
-> [NodeId]
-> Maybe FlowSocialListWith
-> m CorpusId
flowCorpusUser l user corpusName ctype ids = do
flowCorpusUser l user corpusName ctype ids mfslw = do
-- User Flow
(userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
-- NodeTexts is first
......@@ -243,7 +248,7 @@ flowCorpusUser l user corpusName ctype ids = do
--let gp = (GroupParams l 2 3 (StopSize 3))
let gp = GroupWithPosTag l CoreNLP HashMap.empty
ngs <- buildNgramsLists gp user userCorpusId masterCorpusId
ngs <- buildNgramsLists user userCorpusId masterCorpusId mfslw gp
_userListId <- flowList_DbRepo listId ngs
_mastListId <- getOrMkList masterCorpusId masterUserId
......
src/Gargantext/Database/Action/Flow/List.hs
View file @ fe831569
......@@ -18,15 +18,17 @@ module Gargantext.Database.Action.Flow.List
where
import Control.Concurrent
import Control.Lens (view, (^.), (+~), (%~), at)
import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
import Control.Monad.Reader
import Data.Map (Map, toList)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Gargantext.API.Ngrams.Types (HasRepoSaver(..), NgramsElement(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTablePatch(..), NgramsTerm(..), RepoCmdM, ne_ngrams, ngramsElementToRepo, r_history, r_state, r_version, repoVar)
import Gargantext.API.Ngrams (saveNodeStory)
import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (HasInvalidError(..), assertValid)
import Gargantext.Core.Types.Main (ListType(CandidateTerm))
import Gargantext.Core.Utils (something)
import Gargantext.Core.NodeStory
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
......@@ -136,14 +138,12 @@ listInsert lId ngs = mapM_ (\(typeList, ngElmts)
------------------------------------------------------------------------
------------------------------------------------------------------------
-- NOTE
-- This is no longer part of the API.
-- This function is maintained for its usage in Database.Action.Flow.List.
-- If the given list of ngrams elements contains ngrams already in
-- the repo, they will be ignored.
putListNgrams :: (HasInvalidError err, RepoCmdM env err m)
putListNgrams :: (HasInvalidError err, HasNodeStory env err m)
=> NodeId
-> TableNgrams.NgramsType
-> [NgramsElement]
......@@ -153,48 +153,33 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
where
m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
putListNgrams' :: (HasInvalidError err, RepoCmdM env err m)
=> NodeId
-> TableNgrams.NgramsType
-> Map NgramsTerm NgramsRepoElement
-> m ()
putListNgrams' nodeId ngramsType ns = do
-- printDebug "[putListNgrams'] nodeId" nodeId
-- printDebug "[putListNgrams'] ngramsType" ngramsType
-- printDebug "[putListNgrams'] ns" ns
let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
(p0, p0_validity) = PM.singleton nodeId p1
(p, p_validity) = PM.singleton ngramsType p0
assertValid p0_validity
assertValid p_validity
{-
-- TODO
v <- currentVersion
q <- commitStatePatch (Versioned v p)
assert empty q
-- What if another commit comes in between?
-- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
-- The modifyMVar_ would test the patch with applicable first.
-- If valid the rest would be atomic and no merge is required.
-}
var <- view repoVar
liftBase $ modifyMVar_ var $ \r -> do
pure $ r & r_version +~ 1
& r_history %~ (p :)
& r_state . at ngramsType %~
(Just .
(at nodeId %~
( Just
. (<> ns)
. something
)
)
. something
)
saveRepo
saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
=> m ()
saveRepo = liftBase =<< view repoSaver
putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
=> NodeId
-> TableNgrams.NgramsType
-> Map NgramsTerm NgramsRepoElement
-> m ()
putListNgrams' listId ngramsType' ns = do
-- printDebug "[putListNgrams'] nodeId" nodeId
-- printDebug "[putListNgrams'] ngramsType" ngramsType
-- printDebug "[putListNgrams'] ns" ns
let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
(p, p_validity) = PM.singleton ngramsType' p1
assertValid p_validity
{-
-- TODO
v <- currentVersion
q <- commitStatePatch (Versioned v p)
assert empty q
-- What if another commit comes in between?
-- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
-- The modifyMVar_ would test the patch with applicable first.
-- If valid the rest would be atomic and no merge is required.
-}
var <- getNodeStoryVar [listId]
liftBase $ modifyMVar_ var $ \r -> do
pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
& unNodeStory . at listId . _Just . a_history %~ (p :)
& unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
saveNodeStory
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ fe831569
......@@ -179,8 +179,8 @@ getNgramsDocId :: CorpusId
-> NgramsType
-> GargNoServer (HashMap DocAuthor (Set NodeId))
getNgramsDocId cId lId nt = do
repo <- getRepo
lIds <- selectNodesWithUsername NodeList userMaster
repo <- getRepo' lIds
let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
groupNodesByNgrams ngs
......
src/Gargantext/Database/Action/Flow/Types.hs
View file @ fe831569
......@@ -21,10 +21,10 @@ module Gargantext.Database.Action.Flow.Types
import Data.Aeson (ToJSON)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (HasInvalidError)
import Gargantext.Core.Flow.Types
import Gargantext.Core.Text
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.Terms
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Prelude (CmdM)
......@@ -33,10 +33,9 @@ import Gargantext.Database.Query.Tree.Error (HasTreeError)
type FlowCmdM env err m =
( CmdM env err m
, RepoCmdM env err m
, HasNodeStory env err m
, HasNodeError err
, HasInvalidError err
, HasRepoVar env
, HasTreeError err
)
......
src/Gargantext/Database/Action/Metrics.hs
View file @ fe831569
......@@ -15,10 +15,11 @@ module Gargantext.Database.Action.Metrics
import Data.HashMap.Strict (HashMap)
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.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
import Gargantext.Core.NodeStory
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-})
import Gargantext.Database.Admin.Config (userMaster)
......@@ -61,7 +62,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
getNgrams :: (FlowCmdM env err m)
getNgrams :: (HasNodeStory env err m)
=> CorpusId -> Maybe ListId -> TabType
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
......@@ -72,8 +73,11 @@ getNgrams cId maybeListId tabType = do
Nothing -> defaultList cId
Just lId' -> pure lId'
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo' [lId]
let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
[MapTerm, StopTerm, CandidateTerm]
pure (lists, maybeSyn)
src/Gargantext/Database/Action/Metrics/NgramsByNode.hs
View file @ fe831569
......@@ -105,6 +105,18 @@ getOccByNgramsOnlyFast cId nt ngs =
HM.fromListWith (+) <$> selectNgramsOccurrencesOnlyByNodeUser cId nt ngs
getOccByNgramsOnlyFast_withSample :: HasDBid NodeType
=> CorpusId
-> Int
-> NgramsType
-> [NgramsTerm]
-> Cmd err (HashMap NgramsTerm Int)
getOccByNgramsOnlyFast_withSample cId int nt ngs =
HM.fromListWith (+) <$> selectNgramsOccurrencesOnlyByNodeUser_withSample cId int nt ngs
getOccByNgramsOnlyFast' :: CorpusId
-> ListId
-> NgramsType
......@@ -190,6 +202,8 @@ selectNgramsOccurrencesOnlyByNodeUser cId nt tms =
where
fields = [QualifiedIdentifier Nothing "text"]
-- same as queryNgramsOnlyByNodeUser but using COUNT on the node ids.
-- Question: with the grouping is the result exactly the same (since Set NodeId for
-- equivalent ngrams intersections are not empty)
......@@ -208,6 +222,46 @@ queryNgramsOccurrencesOnlyByNodeUser = [sql|
GROUP BY nng.node2_id, ng.terms
|]
selectNgramsOccurrencesOnlyByNodeUser_withSample :: HasDBid NodeType
=> CorpusId
-> Int
-> NgramsType
-> [NgramsTerm]
-> Cmd err [(NgramsTerm, Int)]
selectNgramsOccurrencesOnlyByNodeUser_withSample cId int nt tms =
fmap (first NgramsTerm) <$>
runPGSQuery queryNgramsOccurrencesOnlyByNodeUser_withSample
( int
, toDBid NodeDocument
, cId
, Values fields ((DPS.Only . unNgramsTerm) <$> tms)
, cId
, ngramsTypeId nt
)
where
fields = [QualifiedIdentifier Nothing "text"]
queryNgramsOccurrencesOnlyByNodeUser_withSample :: DPS.Query
queryNgramsOccurrencesOnlyByNodeUser_withSample = [sql|
WITH nodes_sample AS (SELECT id FROM nodes n TABLESAMPLE SYSTEM_ROWS (?)
JOIN nodes_nodes nn ON n.id = nn.node2_id
WHERE n.typename = ?
AND nn.node1_id = ?),
input_rows(terms) AS (?)
SELECT ng.terms, COUNT(nng.node2_id) FROM node_node_ngrams nng
JOIN ngrams ng ON nng.ngrams_id = ng.id
JOIN input_rows ir ON ir.terms = ng.terms
JOIN nodes_nodes nn ON nn.node2_id = nng.node2_id
JOIN nodes_sample n ON nn.node2_id = n.id
WHERE nn.node1_id = ? -- CorpusId
AND nng.ngrams_type = ? -- NgramsTypeId
AND nn.category > 0
GROUP BY nng.node2_id, ng.terms
|]
queryNgramsOccurrencesOnlyByNodeUser' :: DPS.Query
queryNgramsOccurrencesOnlyByNodeUser' = [sql|
WITH input_rows(terms) AS (?)
......
src/Gargantext/Database/Action/Metrics/TFICF.hs
View file @ fe831569
......@@ -21,7 +21,7 @@ import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe)
import Gargantext.Core
import Gargantext.Core.Text.Metrics.TFICF
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getOccByNgramsOnlyFast)
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getOccByNgramsOnlyFast, getOccByNgramsOnlyFast_withSample)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.NodeNode (selectCountDocs)
......@@ -52,3 +52,29 @@ getTficf cId mId nt = do
(TficfSupra (Count $ fromMaybe 0 $ HM.lookup t mapTextDoubleGlobal)
(Total $ fromIntegral countGlobal))
) mapTextDoubleLocal
getTficf_withSample :: HasDBid NodeType
=> UserCorpusId
-> MasterCorpusId
-> NgramsType
-> Cmd err (HashMap NgramsTerm Double)
getTficf_withSample cId mId nt = do
mapTextDoubleLocal <- HM.filter (> 1)
<$> HM.map (fromIntegral . Set.size)
<$> getNodesByNgramsUser cId nt
countLocal <- selectCountDocs cId
let countGlobal = countLocal * 10
mapTextDoubleGlobal <- HM.map fromIntegral
<$> getOccByNgramsOnlyFast_withSample mId countGlobal nt
(HM.keys mapTextDoubleLocal)
pure $ HM.mapWithKey (\t n ->
tficf (TficfInfra (Count n )
(Total $ fromIntegral countLocal))
(TficfSupra (Count $ fromMaybe 0 $ HM.lookup t mapTextDoubleGlobal)
(Total $ fromIntegral countGlobal))
) mapTextDoubleLocal
src/Gargantext/Database/Admin/Types/Node.hs
View file @ fe831569
......@@ -131,7 +131,10 @@ pgNodeId = O.pgInt4 . id2int
------------------------------------------------------------------------
newtype NodeId = NodeId Int
deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable)
deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable)
instance Show NodeId where
show (NodeId n) = "nodeId-" <> show n
unNodeId :: NodeId -> Int
unNodeId (NodeId n) = n
......
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