Skip to content

haskell-gargantext
haskell-gargantext
Commit b7c7b416 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

Merge branch 'dev' into 145-graphExplorerSearch

parents 8c570825 6023449c
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1682 additions and 1426 deletions
CHANGELOG.md
View file @ b7c7b416
## Version 0.0.6.8
* [BACK][FEAT][Flexible job queue system](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/109)
* [FRONT][FEAT][Doc View, Histogram click on bar -> select documents by Date (#430)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/430)
* [BACK][OPTIM][Ngrams Table, queries optimization (#144)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/144)
* [BACK][FIX] SQL error disconnection
* [FRONT][UPGRADE][Upgrade PS to 0.15 (#395)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/395)
* [FRONT][GRAPH][Filtering edge weight bring back new edges (#442)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/442)
* [FRONT][GRAPH][Louvain clustering on filtered graph (#418)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/418)
* [FRONT][GRAPH][GraphExplorer Node size slider (#215)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/215)
* [FRONT][GRAPH][Graph Explorer : link filtering does not impact spatialization (#243)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/243)
## Version 0.0.6.7.1
* [FRONT][FIX][[maplist upload] bugged modal after upload (#440)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/440)
* [BACK][OPTIM][Ngrams Table, queries optimization (#144)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/144)
* [BACK][CONFIG] gargantext.ini needs new field
BACKEND_NAME = THE INSTANCE NAME
## Version 0.0.6.7
* [GRAPH][FIX] Nodes with one edge only are removed now
* [FRONT][GRAPH] Option to chose the clustering method is not shown any more.
......
bin/gargantext-client/Auth.hs deleted 100644 → 0
View file @ 8c570825
module Auth where
import Prelude
import Core
import Options
import Control.Monad.IO.Class
import Data.Text.Encoding (encodeUtf8)
import Options.Generic
import Servant.Client
import qualified Servant.Auth.Client as SA
import Gargantext.API.Client
import qualified Gargantext.API.Admin.Auth.Types as Auth
import qualified Gargantext.Core.Types.Individu as Auth
import qualified Gargantext.Database.Admin.Types.Node as Node
-- | Authenticate and use the resulting Token to perform
-- auth-restricted actions
withAuthToken
:: ClientOpts -- ^ source of user/pass data
-> (SA.Token -> Node.NodeId -> ClientM a) -- ^ do something once authenticated
-> ClientM a
withAuthToken opts act
-- both user and password CLI arguments passed
| Helpful (Just usr) <- user opts
, Helpful (Just pw) <- pass opts = do
authRes <- postAuth (Auth.AuthRequest usr (Auth.GargPassword pw))
case Auth._authRes_valid authRes of
-- authentication failed, this function critically needs it to
-- be able to run the action, so we abort
Nothing -> problem $
"invalid auth response: " ++
maybe "" (show . Auth._authInv_message)
(Auth._authRes_inval authRes)
-- authentication went through, we can run the action
Just (Auth.AuthValid tok tree_id _uid) -> do
let tok' = SA.Token (encodeUtf8 tok)
whenVerbose opts $ do
liftIO . putStrLn $ "[Debug] Authenticated: token=" ++ show tok ++
", tree_id=" ++ show tree_id
act tok' tree_id
-- user and/or pass CLI arguments not passed
| otherwise =
problem "auth-protected actions require --user and --pass"
bin/gargantext-client/Core.hs deleted 100644 → 0
View file @ 8c570825
module Core (problem, whenVerbose) where
import Prelude
import Options
import Options.Generic
import Control.Exception
import Control.Monad
import Control.Monad.Catch
import Servant.Client
newtype GargClientException = GCE String
instance Show GargClientException where
show (GCE s) = "Garg client exception: " ++ s
instance Exception GargClientException
-- | Abort with a message
problem :: String -> ClientM a
problem = throwM . GCE
-- | Only run the given computation when the @--verbose@ flag is
-- passed.
whenVerbose :: Monad m => ClientOpts -> m () -> m ()
whenVerbose opts act = when (unHelpful $ verbose opts) act
bin/gargantext-client/Main.hs deleted 100644 → 0
View file @ 8c570825
module Main where
import Control.Monad
import Network.HTTP.Client
import Options
import Options.Generic
import Prelude
import Script (script)
import Servant.Client
main :: IO ()
main = do
-- we parse CLI options
opts@(ClientOpts (Helpful uri) _ _ (Helpful verb)) <- getRecord "Gargantext client"
mgr <- newManager defaultManagerSettings
burl <- parseBaseUrl uri
when verb $ do
putStrLn $ "[Debug] user: " ++ maybe "<none>" show (unHelpful $ user opts)
putStrLn $ "[Debug] backend: " ++ show burl
-- we run 'script' from the Script module, reporting potential errors
res <- runClientM (script opts) (mkClientEnv mgr burl)
case res of
Left err -> putStrLn $ "[Client error] " ++ show err
Right a -> print a
bin/gargantext-client/Options.hs deleted 100644 → 0
View file @ 8c570825
{-# LANGUAGE TypeOperators #-}
module Options where
import Prelude
import Options.Generic
-- | Some general options to be specified on the command line.
data ClientOpts = ClientOpts
{ url :: String <?> "URL to gargantext backend"
, user :: Maybe Text <?> "(optional) username for auth-restricted actions"
, pass :: Maybe Text <?> "(optional) password for auth-restricted actions"
, verbose :: Bool <?> "Enable verbose output"
} deriving (Generic, Show)
instance ParseRecord ClientOpts
bin/gargantext-client/Script.hs deleted 100644 → 0
View file @ 8c570825
module Script (script) where
import Auth
import Control.Monad.IO.Class
import Core
import Gargantext.API.Client
import Options
import Prelude
import Servant.Client
import Tracking
-- | An example script. Tweak, rebuild and re-run the executable to see the
-- effect of your changes. You can hit any gargantext endpoint in the body
-- of 'script' using the many (many!) client functions exposed by the
-- 'Gargantext.API.Client' module.
--
-- Don't forget to pass @--user@ and @--pass@ if you're using 'withAuthToken'.
script :: ClientOpts -> ClientM ()
script opts = do
-- we start by asking the backend for its version
ver <- getBackendVersion
liftIO . putStrLn $ "Backend version: " ++ show ver
-- next we authenticate using the credentials given on the command line
-- (through --user and --pass), erroring out loudly if the auth creds don't
-- go through, running the continuation otherwise.
withAuthToken opts $ \tok userNode -> do
liftIO . putStrLn $ "user node: " ++ show userNode
steps <-
-- we run a few client computations while tracking some EKG metrics
-- (any RTS stats or routing-related data), which means that we sample the
-- metrics at the beginning, the end, and in between each pair of steps.
tracking opts ["rts.gc.bytes_allocated"]
[ ("get roots", do
roots <- getRoots tok
liftIO . putStrLn $ "roots: " ++ show roots
)
, ("get user node detail", do
userNodeDetail <- getNode tok userNode
liftIO . putStrLn $ "user node details: " ++ show userNodeDetail
)
]
-- we pretty print the values we sampled for all metrics and the
-- results of all the steps
whenVerbose opts (ppTracked steps)
bin/gargantext-client/Tracking.hs deleted 100644 → 0
View file @ 8c570825
{-# LANGUAGE TupleSections #-}
module Tracking
( tracking
, ppTracked
, EkgMetric
, Step
) where
import Core
import Options
import Prelude
import Control.Monad.IO.Class
import Data.List (intersperse)
import Data.Text (Text)
import Servant.Client
import System.Metrics.Json (Value)
import Gargantext.API.Client
import qualified Data.Text as T
-- | e.g @["rts", "gc", "bytes_allocated"]@
type EkgMetric = [Text]
-- | Any textual description of a step
type Step = Text
-- | Track EKG metrics before/after running a bunch of computations
-- that can talk to the backend.
tracking
:: ClientOpts
-> [Text] -- ^ e.g @["rts.gc.bytes_allocated"]@
-> [(Step, ClientM a)]
-> ClientM [Either [(EkgMetric, Value)] (Step, a)]
-- no steps, nothing to do
tracking _ _ [] = return []
-- no metrics to track, we just run the steps
tracking _ [] steps = traverse runStep steps
-- metrics to track: we intersperse metric fetching and steps,
-- starting and ending with metric fetching
tracking opts ms' steps = mix (Left <$> fetchMetrics) (map runStep steps)
where fetchMetrics :: ClientM [(EkgMetric, Value)]
fetchMetrics = flip traverse ms $ \metric -> do
whenVerbose opts $
liftIO . putStrLn $ "[Debug] metric to track: " ++ T.unpack (T.intercalate "." metric)
dat <- (metric,) <$> getMetricSample metric
whenVerbose opts $
liftIO . putStrLn $ "[Debug] metric pulled: " ++ show dat
return dat
mix :: ClientM a -> [ClientM a] -> ClientM [a]
mix x xs = sequence $ [x] ++ intersperse x xs ++ [x]
ms = map (T.splitOn ".") ms'
-- ^ A trivial function to print results of steps and sampled metrics
ppTracked :: Show a => [Either [(EkgMetric, Value)] (Step, a)] -> ClientM ()
ppTracked [] = return ()
ppTracked (Right (step, a) : rest) = do
liftIO . putStrLn $ "[step: " ++ T.unpack step ++ "] returned: " ++ show a
ppTracked rest
ppTracked (Left ms : rest) = do
liftIO . putStrLn $ unlines
[ T.unpack (T.intercalate "." metric) ++ " = " ++ show val
| (metric, val) <- ms
]
ppTracked rest
runStep :: (Step, ClientM a) -> ClientM (Either e (Step, a))
runStep (step, act) = Right . (step,) <$> act
devops/postgres/upgrade/0.0.6.7.2.sql 0 → 100644
View file @ b7c7b416
-- Adding index to improve ngrams_table query
create index node_node_ngrams_weight_idx on node_node_ngrams(weight);
gargantext.cabal
View file @ b7c7b416
......@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.6.7
version: 0.0.6.8
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -44,14 +44,20 @@ library
Gargantext.API.Admin.Auth.Types
Gargantext.API.Admin.Types
Gargantext.API.Prelude
Gargantext.API.Client
Gargantext.Core
Gargantext.Core.NodeStory
Gargantext.Core.Methods.Distances
Gargantext.Core.Methods.Similarities
Gargantext.Core.Types
Gargantext.Core.Types.Individu
Gargantext.Core.Types.Main
Gargantext.Core.Utils.Prefix
Gargantext.Utils.Jobs
Gargantext.Utils.Jobs.API
Gargantext.Utils.Jobs.Map
Gargantext.Utils.Jobs.Monad
Gargantext.Utils.Jobs.Queue
Gargantext.Utils.Jobs.Settings
Gargantext.Utils.Jobs.State
Gargantext.Utils.SpacyNLP
Gargantext.Database.Action.Flow
Gargantext.Database.Action.Flow.Types
......@@ -156,14 +162,14 @@ library
Gargantext.Core.Flow.Types
Gargantext.Core.Mail
Gargantext.Core.Mail.Types
Gargantext.Core.Methods.Distances.Accelerate.Conditional
Gargantext.Core.Methods.Distances.Accelerate.Distributional
Gargantext.Core.Methods.Distances.Accelerate.SpeGen
Gargantext.Core.Methods.Distances.Conditional
Gargantext.Core.Methods.Distances.Distributional
Gargantext.Core.Methods.Graph.BAC.Proxemy
Gargantext.Core.Methods.Graph.MaxClique
Gargantext.Core.Methods.Matrix.Accelerate.Utils
Gargantext.Core.Methods.Similarities.Accelerate.Conditional
Gargantext.Core.Methods.Similarities.Accelerate.Distributional
Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
Gargantext.Core.Methods.Similarities.Conditional
Gargantext.Core.Methods.Similarities.Distributional
Gargantext.Core.NodeStoryFile
Gargantext.Core.Statistics
Gargantext.Core.Text.Convert
......@@ -477,6 +483,7 @@ library
, singletons
, split
, stemmer
, stm
, swagger2
, taggy-lens
, tagsoup
......@@ -610,55 +617,6 @@ executable gargantext-cli
, vector
default-language: Haskell2010
executable gargantext-client
main-is: Main.hs
other-modules:
Auth
Core
Options
Script
Tracking
Paths_gargantext
hs-source-dirs:
bin/gargantext-client
default-extensions:
DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
MultiParamTypeClasses
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
RankNTypes
RecordWildCards
DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
MultiParamTypeClasses
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
RankNTypes
RecordWildCards
ghc-options: -Wall -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -Wmissing-signatures
build-depends:
base
, ekg-json
, exceptions
, extra
, gargantext
, http-client
, optparse-generic
, servant
, servant-auth-client
, servant-client
, text
default-language: Haskell2010
executable gargantext-import
main-is: Main.hs
other-modules:
......@@ -901,3 +859,33 @@ test-suite garg-test
, time
, unordered-containers
default-language: Haskell2010
test-suite jobqueue-test
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
Paths_gargantext
hs-source-dirs:
tests/queue
default-extensions:
DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
MultiParamTypeClasses
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
RankNTypes
RecordWildCards
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends:
async
, base
, extra
, gargantext
, hspec
, stm
, text
default-language: Haskell2010
gargantext.ini_toModify
View file @ b7c7b416
......@@ -3,6 +3,9 @@
# Main url serving the FrontEnd
URL = http://localhost
# The instance name
BACKEND_NAME = localhost
# Main API url serving the BackEnd
URL_BACKEND_API = http://localhost:8008/api/v1.0
......
package.yaml
View file @ b7c7b416
......@@ -6,7 +6,7 @@ name: gargantext
# | | | +----- Layers * : New versions with API additions
# | | | | +--- Layers * : New versions without API breaking changes
# | | | | |
version: '0.0.6.7'
version: '0.0.6.8'
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -68,14 +68,20 @@ library:
- Gargantext.API.Admin.Auth.Types
- Gargantext.API.Admin.Types
- Gargantext.API.Prelude
- Gargantext.API.Client
- Gargantext.Core
- Gargantext.Core.NodeStory
- Gargantext.Core.Methods.Distances
- Gargantext.Core.Methods.Similarities
- Gargantext.Core.Types
- Gargantext.Core.Types.Individu
- Gargantext.Core.Types.Main
- Gargantext.Core.Utils.Prefix
- Gargantext.Utils.Jobs
- Gargantext.Utils.Jobs.API
- Gargantext.Utils.Jobs.Map
- Gargantext.Utils.Jobs.Monad
- Gargantext.Utils.Jobs.Queue
- Gargantext.Utils.Jobs.Settings
- Gargantext.Utils.Jobs.State
- Gargantext.Utils.SpacyNLP
- Gargantext.Database.Action.Flow
- Gargantext.Database.Action.Flow.Types
......@@ -262,6 +268,7 @@ library:
- singletons # (IGraph)
- split
- stemmer
- stm
- swagger2
- taggy-lens
- tagsoup
......@@ -347,42 +354,6 @@ executables:
- unordered-containers
- full-text-search
gargantext-client:
main: Main.hs
source-dirs: bin/gargantext-client
ghc-options:
- -Wall
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -O2
- -Wmissing-signatures
default-extensions:
- DataKinds
- DeriveGeneric
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- OverloadedStrings
- RankNTypes
- RecordWildCards
dependencies:
- base
- extra
- servant
- text
- optparse-generic
- exceptions
- servant-client
- servant-auth-client
- gargantext
- ekg-json
- http-client
gargantext-phylo:
main: Main.hs
source-dirs: bin/gargantext-phylo
......@@ -533,6 +504,19 @@ tests:
- duckling
- text
- unordered-containers
jobqueue-test:
main: Main.hs
source-dirs: tests/queue
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- base
- gargantext
- hspec
- async
- stm
# garg-doctest:
# main: Main.hs
# source-dirs: src-doctest
......
src-test/Graph/Clustering.hs
View file @ b7c7b416
This diff is collapsed.
src/Gargantext/API.hs
View file @ b7c7b416
......@@ -44,11 +44,11 @@ import Data.Validity
import GHC.Base (Applicative)
import GHC.Generics (Generic)
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Admin.Settings (newEnv)
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
import Gargantext.API.EKG
import Gargantext.API.Ngrams (saveNodeStoryImmediate)
import Gargantext.API.Prelude
import Gargantext.API.Routes
import Gargantext.API.Server (server)
import Gargantext.Core.NodeStory
......@@ -207,7 +207,7 @@ serverGargAdminAPI = roots
--gargMock = mock apiGarg Proxy
---------------------------------------------------------------------
makeApp :: (Typeable env, EnvC env) => env -> IO Application
makeApp :: Env -> IO Application
makeApp env = do
serv <- server env
(ekgStore, ekgMid) <- newEkgStore api
......
src/Gargantext/API/Admin/Auth.hs
View file @ b7c7b416
......@@ -47,16 +47,16 @@ import Data.UUID.V4 (nextRandom)
import GHC.Generics (Generic)
import Servant
import Servant.Auth.Server
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
--import qualified Text.Blaze.Html5.Attributes as HA
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types
import Gargantext.API.Job (jobLogSuccess)
import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError)
import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM, GargError)
import Gargantext.Core.Mail (MailModel(..), mail)
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
......@@ -69,6 +69,7 @@ import Gargantext.Database.Query.Tree.Root (getRoot)
import Gargantext.Database.Schema.Node (NodePoly(_node_id))
import Gargantext.Prelude hiding (reverse)
import Gargantext.Prelude.Crypto.Pass.User (gargPass)
import Gargantext.Utils.Jobs (serveJobsAPI)
---------------------------------------------------
......@@ -266,12 +267,10 @@ generateForgotPasswordUUID = do
type ForgotPasswordAsyncAPI = Summary "Forgot password asnc"
:> AsyncJobs JobLog '[JSON] ForgotPasswordAsyncParams JobLog
forgotPasswordAsync :: GargServer ForgotPasswordAsyncAPI
forgotPasswordAsync :: ServerT ForgotPasswordAsyncAPI (GargM Env GargError)
forgotPasswordAsync =
serveJobsAPI $
JobFunction (\p log' ->
forgotPasswordAsync' p (liftBase . log')
)
serveJobsAPI ForgotPasswordJob $ \p log' ->
forgotPasswordAsync' p (liftBase . log')
forgotPasswordAsync' :: (FlowCmdM env err m)
=> ForgotPasswordAsyncParams
......
src/Gargantext/API/Admin/EnvTypes.hs
View file @ b7c7b416
......@@ -5,6 +5,9 @@
module Gargantext.API.Admin.EnvTypes where
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
import Data.Monoid
import Data.Pool (Pool)
import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
......@@ -16,6 +19,7 @@ import qualified Servant.Job.Core
import Gargantext.API.Admin.Types
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Prelude (GargError)
import Gargantext.Core.NodeStory
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
......@@ -23,6 +27,27 @@ import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Prelude.Mail.Types (MailConfig)
import qualified Gargantext.Utils.Jobs.Monad as Jobs
data GargJob
= TableNgramsJob
| ForgotPasswordJob
| UpdateNgramsListJobJSON
| UpdateNgramsListJobCSV
| AddContactJob
| AddFileJob
| DocumentFromWriteNodeJob
| UpdateNodeJob
| UploadFrameCalcJob
| UploadDocumentJob
| NewNodeJob
| AddCorpusQueryJob
| AddCorpusFormJob
| AddCorpusFileJob
| AddAnnuaireFormJob
| RecomputeGraphJob
deriving (Show, Eq, Ord, Enum, Bounded)
data Env = Env
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
......@@ -31,6 +56,7 @@ data Env = Env
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv
, _env_jobs :: !(Jobs.JobEnv GargJob (Dual [JobLog]) JobLog)
, _env_config :: !GargConfig
, _env_mail :: !MailConfig
}
......@@ -62,13 +88,15 @@ instance HasSettings Env where
instance HasMail Env where
mailSettings = env_mail
instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
_env = env_scrapers . Servant.Job.Core._env
instance HasJobEnv Env JobLog JobLog where
job_env = env_scrapers
instance Jobs.MonadJob (ReaderT Env (ExceptT GargError IO)) GargJob (Dual [JobLog]) JobLog where
getJobEnv = asks (view env_jobs)
data MockEnv = MockEnv
{ _menv_firewall :: !FireWall
}
......
src/Gargantext/API/Admin/Settings.hs
View file @ b7c7b416
......@@ -47,6 +47,9 @@ import Gargantext.Database.Prelude (databaseParameters)
import Gargantext.Prelude
-- import Gargantext.Prelude.Config (gc_repofilepath)
import qualified Gargantext.Prelude.Mail as Mail
import qualified Gargantext.Utils.Jobs as Jobs
import qualified Gargantext.Utils.Jobs.Monad as Jobs
import qualified Gargantext.Utils.Jobs.Queue as Jobs
devSettings :: FilePath -> IO Settings
devSettings jwkFile = do
......@@ -177,12 +180,19 @@ newEnv port file = do
panic "TODO: conflicting settings of port"
config_env <- readConfig file
prios <- Jobs.readPrios (file <> ".jobs")
let prios' = Jobs.applyPrios prios Jobs.defaultPrios
putStrLn $ "Overrides: " <> show prios
putStrLn $ "New priorities: " <> show prios'
self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- databaseParameters file
pool <- newPool dbParam
--nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
nodeStory_env <- readNodeStoryEnv pool
scrapers_env <- newJobEnv defaultSettings manager_env
secret <- Jobs.genSecret
jobs_env <- Jobs.newJobEnv (Jobs.defaultJobSettings 1 secret) prios' manager_env
logger <- newStderrLoggerSet defaultBufSize
config_mail <- Mail.readConfig file
......@@ -193,6 +203,7 @@ newEnv port file = do
, _env_nodeStory = nodeStory_env
, _env_manager = manager_env
, _env_scrapers = scrapers_env
, _env_jobs = jobs_env
, _env_self_url = self_url_env
, _env_config = config_env
, _env_mail = config_mail
......
src/Gargantext/API/Client.hs deleted 100644 → 0
View file @ 8c570825
This diff is collapsed.
src/Gargantext/API/Ngrams.hs
View file @ b7c7b416
......@@ -95,6 +95,7 @@ import Data.Text (Text, isInfixOf, unpack, pack)
import Data.Text.Lazy.IO as DTL
import Formatting (hprint, int, (%))
import GHC.Generics (Generic)
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Job
......@@ -105,7 +106,7 @@ 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
import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast')
import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Node (NodeType(..))
import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig)
......@@ -118,7 +119,7 @@ import Gargantext.Prelude hiding (log)
import Gargantext.Prelude.Clock (hasTime, getTime)
import Prelude (error)
import Servant hiding (Patch)
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Gargantext.Utils.Jobs (serveJobsAPI)
import System.IO (stderr)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......@@ -581,10 +582,9 @@ getTableNgrams _nType nId tabType listId limit_ offset
let ngrams_terms = table ^.. each . ne_ngrams
-- printDebug "ngrams_terms" ngrams_terms
t1 <- getTime
occurrences <- getOccByNgramsOnlyFast' nId
occurrences <- getOccByNgramsOnlyFast nId
listId
ngramsType
ngrams_terms
--printDebug "occurrences" occurrences
t2 <- getTime
liftBase $ hprint stderr
......@@ -644,19 +644,15 @@ scoresRecomputeTableNgrams nId tabType listId = do
setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
setScores table = do
let ngrams_terms = table ^.. each . ne_ngrams
occurrences <- getOccByNgramsOnlyFast' nId
occurrences <- getOccByNgramsOnlyFast nId
listId
ngramsType
ngrams_terms
let
setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
pure $ table & each %~ setOcc
-- APIs
-- TODO: find a better place for the code above, All APIs stay here
......@@ -779,28 +775,23 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
apiNgramsTableCorpus :: ( GargServerC env err m
)
=> NodeId -> ServerT TableNgramsApi m
apiNgramsTableCorpus :: NodeId -> ServerT TableNgramsApi (GargM Env GargError)
apiNgramsTableCorpus cId = getTableNgramsCorpus cId
:<|> tableNgramsPut
:<|> scoresRecomputeTableNgrams cId
:<|> getTableNgramsVersion cId
:<|> apiNgramsAsync cId
apiNgramsTableDoc :: ( GargServerC env err m
)
=> DocId -> ServerT TableNgramsApi m
apiNgramsTableDoc :: DocId -> ServerT TableNgramsApi (GargM Env GargError)
apiNgramsTableDoc dId = getTableNgramsDoc dId
:<|> tableNgramsPut
:<|> scoresRecomputeTableNgrams dId
:<|> getTableNgramsVersion dId
:<|> apiNgramsAsync dId
apiNgramsAsync :: NodeId -> GargServer TableNgramsAsyncApi
apiNgramsAsync :: NodeId -> ServerT TableNgramsAsyncApi (GargM Env GargError)
apiNgramsAsync _dId =
serveJobsAPI $
JobFunction $ \i log ->
serveJobsAPI TableNgramsJob $ \i log ->
let
log' x = do
printDebug "tableNgramsPostChartsAsync" x
......
src/Gargantext/API/Ngrams/List.hs
View file @ b7c7b416
......@@ -23,13 +23,14 @@ import Data.Maybe (catMaybes, fromMaybe)
import Data.Set (Set)
import Data.Text (Text, concat, pack, splitOn)
import Data.Vector (Vector)
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams (setListNgrams)
import Gargantext.API.Ngrams.List.Types
import Gargantext.API.Ngrams.Prelude (getNgramsList)
import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargServer)
import Gargantext.API.Prelude (GargServer, GargM, GargError)
import Gargantext.API.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.Terms (ExtractedNgrams(..))
......@@ -46,8 +47,9 @@ import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node (_node_parent_id)
import Gargantext.Database.Types (Indexed(..))
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI)
import Servant
import Servant.Job.Async
-- import Servant.Job.Async
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Csv as Csv
import qualified Data.HashMap.Strict as HashMap
......@@ -75,7 +77,7 @@ type JSONAPI = Summary "Update List"
:> "async"
:> AsyncJobs JobLog '[FormUrlEncoded] WithFile JobLog
jsonApi :: GargServer JSONAPI
jsonApi :: ServerT JSONAPI (GargM Env GargError)
jsonApi = postAsync
----------------------
......@@ -88,7 +90,7 @@ type CSVAPI = Summary "Update List (legacy v3 CSV)"
:> "async"
:> AsyncJobs JobLog '[FormUrlEncoded] WithTextFile JobLog
csvApi :: GargServer CSVAPI
csvApi :: ServerT CSVAPI (GargM Env GargError)
csvApi = csvPostAsync
------------------------------------------------------------------------
......@@ -188,15 +190,14 @@ type PostAPI = Summary "Update List"
:> "async"
:> AsyncJobs JobLog '[FormUrlEncoded] WithFile JobLog
postAsync :: GargServer JSONAPI
postAsync :: ListId -> ServerT PostAPI (GargM Env GargError)
postAsync lId =
serveJobsAPI $
JobFunction (\f log' ->
serveJobsAPI UpdateNgramsListJobJSON $ \f log' ->
let
log'' x = do
-- printDebug "postAsync ListId" x
liftBase $ log' x
in postAsync' lId f log'')
in postAsync' lId f log''
postAsync' :: FlowCmdM env err m
=> ListId
......@@ -291,10 +292,9 @@ csvPost l m = do
pure True
------------------------------------------------------------------------
csvPostAsync :: GargServer CSVAPI
csvPostAsync :: ServerT CSVAPI (GargM Env GargError)
csvPostAsync lId =
serveJobsAPI $
JobFunction $ \f@(WithTextFile ft _ n) log' -> do
serveJobsAPI UpdateNgramsListJobCSV $ \f@(WithTextFile ft _ n) log' -> do
let log'' x = do
printDebug "[csvPostAsync] filetype" ft
printDebug "[csvPostAsync] name" n
......
src/Gargantext/API/Ngrams/Tools.hs
View file @ b7c7b416
......@@ -187,14 +187,44 @@ getCoocByNgrams' f (Diagonal diag) m =
<$> (fmap f $ HM.lookup t1 m)
<*> (fmap f $ HM.lookup t2 m)
)
| (t1,t2) <- if diag then
[ (x,y) | x <- ks, y <- ks, x <= y] -- TODO if we keep a Data.Map here it might be
-- more efficient to enumerate all the y <= x.
else
listToCombi identity ks
| (t1,t2) <- if diag
then [ (x,y) | x <- ks, y <- ks, x <= y]
-- TODO if we keep a Data.Map here it might be
-- more efficient to enumerate all the y <= x.
else
listToCombi identity ks
]
where ks = HM.keys m
where
ks = HM.keys m
-- TODO k could be either k1 or k2 here
getCoocByNgrams'' :: (Hashable k, Ord k, Ord contexts)
=> Diagonal
-> (contextA -> Set contexts, contextB -> Set contexts)
-> (HashMap k contextA, HashMap k contextB)
-> HashMap (k, k) Int
getCoocByNgrams'' (Diagonal diag) (f1,f2) (m1,m2) =
HM.fromList [( (t1,t2)
, maybe 0 Set.size $ Set.intersection
<$> (fmap f1 $ HM.lookup t1 m1)
<*> (fmap f2 $ HM.lookup t2 m2)
)
| (t1,t2) <- if diag
then
[ (x,y) | x <- ks1, y <- ks2, x <= y]
-- TODO if we keep a Data.Map here it might be
-- more efficient to enumerate all the y <= x.
else
[ (x,y) | x <- ks1, y <- ks2, x < y]
-- TODO check optim
-- listToCombi identity ks1
]
where
ks1 = HM.keys m1
ks2 = HM.keys m2
------------------------------------------
......
src/Gargantext/API/Node.hs
View file @ b7c7b416
......@@ -36,6 +36,7 @@ import Data.Text (Text())
import GHC.Generics (Generic)
import Gargantext.API.Admin.Auth (withAccess)
import Gargantext.API.Admin.Auth.Types (PathId(..))
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Metrics
import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableCorpus)
import Gargantext.API.Ngrams.Types (TabType(..))
......@@ -196,10 +197,10 @@ nodeAPI :: forall proxy a.
) => proxy a
-> UserId
-> NodeId
-> GargServer (NodeAPI a)
-> ServerT (NodeAPI a) (GargM Env GargError)
nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id') nodeAPI'
where
nodeAPI' :: GargServer (NodeAPI a)
nodeAPI' :: ServerT (NodeAPI a) (GargM Env GargError)
nodeAPI' = getNodeWith id' p
:<|> rename id'
:<|> postNode uId id'
......
src/Gargantext/API/Node/Contact.hs
View file @ b7c7b416
......@@ -30,14 +30,14 @@ import Data.Swagger
import Data.Text (Text)
import GHC.Generics (Generic)
import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Node
import Gargantext.API.Prelude (GargServer, simuLogs)
import Gargantext.API.Prelude (GargError, GargM, simuLogs)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Terms (TermType(..))
import Gargantext.Core.Types.Individu (User(..))
......@@ -48,6 +48,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude (($), liftBase, (.), printDebug, pure)
import qualified Gargantext.Utils.Aeson as GUA
import Gargantext.Utils.Jobs (serveJobsAPI)
------------------------------------------------------------------------
type API = "contact" :> Summary "Contact endpoint"
......@@ -56,7 +57,7 @@ type API = "contact" :> Summary "Contact endpoint"
:> NodeNodeAPI HyperdataContact
api :: UserId -> CorpusId -> GargServer API
api :: UserId -> CorpusId -> ServerT API (GargM Env GargError)
api uid cid = (api_async (RootId (NodeId uid)) cid)
:<|> (nodeNodeAPI (Proxy :: Proxy HyperdataContact) uid cid)
......@@ -70,16 +71,14 @@ data AddContactParams = AddContactParams { firstname :: !Text, lastname
deriving (Generic)
----------------------------------------------------------------------
api_async :: User -> NodeId -> GargServer API_Async
api_async :: User -> NodeId -> ServerT API_Async (GargM Env GargError)
api_async u nId =
serveJobsAPI $
JobFunction (\p log ->
serveJobsAPI AddContactJob $ \p log ->
let
log' x = do
printDebug "addContact" x
liftBase $ log x
in addContact u nId p (liftBase . log')
)
addContact :: (HasSettings env, FlowCmdM env err m)
=> User
......
src/Gargantext/API/Node/Document/Export.hs
View file @ b7c7b416
......@@ -40,7 +40,7 @@ getDocumentsJSON :: UserId
getDocumentsJSON uId pId = do
mcId <- getClosestParentIdByType pId NodeCorpus
let cId = maybe (panic "[G.A.N.D.Export] Node has no parent") identity mcId
docs <- runViewDocuments cId False Nothing Nothing Nothing Nothing
docs <- runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
pure $ DocumentExport { _de_documents = mapFacetDoc <$> docs
, _de_garg_version = T.pack $ showVersion PG.version }
where
......
src/Gargantext/API/Node/DocumentUpload.hs
View file @ b7c7b416
......@@ -10,9 +10,9 @@ import Data.Aeson
import Data.Swagger (ToSchema)
import GHC.Generics (Generic)
import Servant
import Servant.Job.Async
import qualified Data.Text as T
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Job (jobLogSuccess)
import Gargantext.API.Prelude
......@@ -28,14 +28,15 @@ import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node (getClosestParentIdByType')
import Gargantext.Prelude
import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus(..))
import Gargantext.Utils.Jobs (serveJobsAPI)
data DocumentUpload = DocumentUpload
{ _du_abstract :: T.Text
, _du_authors :: T.Text
, _du_sources :: T.Text
, _du_title :: T.Text
, _du_date :: T.Text
, _du_title :: T.Text
, _du_date :: T.Text
}
deriving (Generic)
......@@ -65,12 +66,10 @@ type API = Summary " Document upload"
:> "async"
:> AsyncJobs JobLog '[JSON] DocumentUpload JobLog
api :: UserId -> NodeId -> GargServer API
api :: UserId -> NodeId -> ServerT API (GargM Env GargError)
api uId nId =
serveJobsAPI $
JobFunction (\q log' -> do
serveJobsAPI UploadDocumentJob $ \q log' -> do
documentUploadAsync uId nId q (liftBase . log')
)
documentUploadAsync :: (FlowCmdM env err m)
=> UserId
......@@ -99,8 +98,8 @@ documentUpload nId doc = do
let cId = case mcId of
Just c -> c
Nothing -> panic $ T.pack $ "[G.A.N.DU] Node has no corpus parent: " <> show nId
(theFullDate, (year, month, day)) <- liftBase $ dateSplit EN
(theFullDate, (year, month, day)) <- liftBase $ dateSplit EN
$ Just
$ view du_date doc <> "T:0:0:0"
......@@ -123,9 +122,7 @@ documentUpload nId doc = do
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ T.pack $ show EN }
docIds <- insertMasterDocs (Nothing :: Maybe HyperdataCorpus) (Multi EN) [hd]
_ <- Doc.add cId docIds
pure docIds
src/Gargantext/API/Node/DocumentsFromWriteNodes.hs
View file @ b7c7b416
......@@ -22,10 +22,11 @@ import Data.Aeson
import Data.Either (Either(..), rights)
import Data.Swagger
import qualified Data.Text as T
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Job (jobLogSuccess, jobLogFailTotalWithMessage)
import Gargantext.API.Prelude (GargServer)
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Corpus.Parsers.FrameWrite
import Gargantext.Core.Text.Terms (TermType(..))
......@@ -39,9 +40,9 @@ import Gargantext.Database.Query.Table.Node (getChildrenByType, getClosestParent
import Gargantext.Database.Schema.Node (node_hyperdata)
import qualified Gargantext.Defaults as Defaults
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI)
import GHC.Generics (Generic)
import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
------------------------------------------------------------------------
type API = Summary " Documents from Write nodes."
......@@ -55,15 +56,13 @@ instance ToJSON Params where
toJSON = genericToJSON defaultOptions
instance ToSchema Params
------------------------------------------------------------------------
api :: UserId -> NodeId -> GargServer API
api :: UserId -> NodeId -> ServerT API (GargM Env GargError)
api uId nId =
serveJobsAPI $
JobFunction (\p log'' ->
serveJobsAPI DocumentFromWriteNodeJob $ \p log'' ->
let
log' x = do
liftBase $ log'' x
in documentsFromWriteNodes uId nId p (liftBase . log')
)
documentsFromWriteNodes :: (HasSettings env, FlowCmdM env err m)
=> UserId
......
src/Gargantext/API/Node/File.hs
View file @ b7c7b416
......@@ -11,7 +11,6 @@ import Data.Swagger
import Data.Text
import GHC.Generics (Generic)
import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.MIME.Types as DMT
......@@ -19,6 +18,7 @@ import qualified Gargantext.Database.GargDB as GargDB
import qualified Network.HTTP.Media as M
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Node.Types
import Gargantext.API.Prelude
......@@ -31,6 +31,7 @@ import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI)
import Data.Either
data RESPONSE deriving Typeable
......@@ -99,15 +100,14 @@ type FileAsyncApi = Summary "File Async Api"
:> "add"
:> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog
fileAsyncApi :: UserId -> NodeId -> GargServer FileAsyncApi
fileAsyncApi :: UserId -> NodeId -> ServerT FileAsyncApi (GargM Env GargError)
fileAsyncApi uId nId =
serveJobsAPI $
JobFunction (\i l ->
serveJobsAPI AddFileJob $ \i l ->
let
log' x = do
printDebug "addWithFile" x
liftBase $ l x
in addWithFile uId nId i log')
in addWithFile uId nId i log'
addWithFile :: (HasSettings env, FlowCmdM env err m)
......
src/Gargantext/API/Node/FrameCalcUpload.hs
View file @ b7c7b416
......@@ -14,9 +14,9 @@ import GHC.Generics (Generic)
import Network.HTTP.Client (newManager, httpLbs, parseRequest, responseBody)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant
import Servant.Job.Async
import Web.FormUrlEncoded (FromForm)
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Job (jobLogInit, jobLogSuccess, jobLogFail)
import Gargantext.API.Node.Corpus.New (addToCorpusWithForm)
......@@ -31,6 +31,7 @@ import Gargantext.Database.Prelude (HasConfig)
import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, getNodeWith)
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI)
data FrameCalcUpload = FrameCalcUpload ()
deriving (Generic)
......@@ -46,12 +47,11 @@ type API = Summary " FrameCalc upload"
:> "async"
:> AsyncJobs JobLog '[JSON] FrameCalcUpload JobLog
api :: UserId -> NodeId -> GargServer API
api :: UserId -> NodeId -> ServerT API (GargM Env GargError)
api uId nId =
serveJobsAPI $
JobFunction (\p logs ->
frameCalcUploadAsync uId nId p (liftBase . logs) (jobLogInit 5)
)
serveJobsAPI UploadFrameCalcJob $ \p logs ->
frameCalcUploadAsync uId nId p (liftBase . logs) (jobLogInit 5)
frameCalcUploadAsync :: (HasConfig env, FlowCmdM env err m)
......
src/Gargantext/API/Node/Get.hs
View file @ b7c7b416
......@@ -18,10 +18,6 @@ Polymorphic Get Node API
module Gargantext.API.Node.Get
where
-- import Gargantext.API.Admin.Types (HasSettings)
-- import Servant.Job.Async (JobFunction(..), serveJobsAPI)
-- import Test.QuickCheck (elements)
-- import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Data.Aeson
import Data.Swagger
import GHC.Generics (Generic)
......@@ -30,7 +26,7 @@ import Test.QuickCheck.Arbitrary
import Gargantext.API.Prelude
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (JSONB{-, getNodeWith-})
import Gargantext.Database.Prelude (JSONB)
import Gargantext.Prelude
------------------------------------------------------------------------
......
src/Gargantext/API/Node/New.hs
View file @ b7c7b416
......@@ -26,11 +26,11 @@ import Data.Swagger
import Data.Text (Text)
import GHC.Generics (Generic)
import Servant
import Servant.Job.Async
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Web.FormUrlEncoded (FromForm, ToForm)
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Prelude
import Gargantext.Database.Action.Flow.Types
......@@ -41,6 +41,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Table.Node.User
import Gargantext.Database.Schema.Node
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI)
------------------------------------------------------------------------
data PostNode = PostNode { pn_name :: Text
......@@ -73,10 +74,11 @@ type PostNodeAsync = Summary "Post Node"
:> AsyncJobs JobLog '[FormUrlEncoded] PostNode JobLog
postNodeAsyncAPI :: UserId -> NodeId -> GargServer PostNodeAsync
postNodeAsyncAPI
:: UserId -> NodeId -> ServerT PostNodeAsync (GargM Env GargError)
postNodeAsyncAPI uId nId =
serveJobsAPI $
JobFunction (\p logs -> postNodeAsync uId nId p (liftBase . logs))
serveJobsAPI NewNodeJob $ \p logs ->
postNodeAsync uId nId p (liftBase . logs)
------------------------------------------------------------------------
postNodeAsync :: FlowCmdM env err m
......
src/Gargantext/API/Node/Update.hs
View file @ b7c7b416
......@@ -21,16 +21,17 @@ import Data.Aeson
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Swagger
import GHC.Generics (Generic)
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Ngrams.List (reIndexWith)
--import Gargantext.API.Ngrams.Types (TabType(..))
import Gargantext.API.Prelude (GargServer, simuLogs)
import Gargantext.Core.Methods.Distances (GraphMetric(..))
import Gargantext.API.Prelude (GargM, GargError, simuLogs)
import Gargantext.Core.Methods.Similarities (GraphMetric(..))
import Gargantext.Core.Types.Main (ListType(..))
import Gargantext.Core.Viz.Graph (Strength)
import Gargantext.Core.Viz.Graph.API (recomputeGraph)
import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..))
import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..), BridgenessMethod(..))
import Gargantext.Core.Viz.Phylo (PhyloSubConfig(..), subConfig2config)
import Gargantext.Core.Viz.Phylo.API.Tools (flowPhyloAPI)
import Gargantext.Database.Action.Flow.Pairing (pairing)
......@@ -43,9 +44,9 @@ import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Ngrams (NgramsType(NgramsTerms))
import Gargantext.Database.Schema.Node (node_parent_id)
import Gargantext.Prelude (Bool(..), Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure, show, cs, (<>), panic, (<*>))
import Gargantext.Utils.Jobs (serveJobsAPI)
import Prelude (Enum, Bounded, minBound, maxBound)
import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import qualified Data.Set as Set
......@@ -62,7 +63,10 @@ data UpdateNodeParams = UpdateNodeParamsList { methodList :: !Method }
| UpdateNodeParamsGraph { methodGraphMetric :: !GraphMetric
, methodGraphClustering :: !PartitionMethod
, methodGraphBridgeness :: !BridgenessMethod
, methodGraphEdgesStrength :: !Strength
, methodGraphNodeType1 :: !NgramsType
, methodGraphNodeType2 :: !NgramsType
}
| UpdateNodeParamsTexts { methodTexts :: !Granularity }
......@@ -88,16 +92,14 @@ data Charts = Sources | Authors | Institutes | Ngrams | All
deriving (Generic, Eq, Ord, Enum, Bounded)
------------------------------------------------------------------------
api :: UserId -> NodeId -> GargServer API
api :: UserId -> NodeId -> ServerT API (GargM Env GargError)
api uId nId =
serveJobsAPI $
JobFunction (\p log'' ->
serveJobsAPI UpdateNodeJob $ \p log'' ->
let
log' x = do
printDebug "updateNode" x
liftBase $ log'' x
in updateNode uId nId p (liftBase . log')
)
updateNode :: (HasSettings env, FlowCmdM env err m)
=> UserId
......@@ -105,16 +107,16 @@ updateNode :: (HasSettings env, FlowCmdM env err m)
-> UpdateNodeParams
-> (JobLog -> m ())
-> m JobLog
updateNode uId nId (UpdateNodeParamsGraph metric method strength) logStatus = do
updateNode uId nId (UpdateNodeParamsGraph metric partitionMethod bridgeMethod strength nt1 nt2) logStatus = do
logStatus JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
printDebug "Computing graph: " method
_ <- recomputeGraph uId nId method (Just metric) (Just strength) True
printDebug "Graph computed: " method
-- printDebug "Computing graph: " method
_ <- recomputeGraph uId nId partitionMethod bridgeMethod (Just metric) (Just strength) nt1 nt2 True
-- printDebug "Graph computed: " method
pure JobLog { _scst_succeeded = Just 2
, _scst_failed = Just 0
......@@ -274,7 +276,7 @@ instance ToSchema UpdateNodeParams
instance Arbitrary UpdateNodeParams where
arbitrary = do
l <- UpdateNodeParamsList <$> arbitrary
g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary <*> arbitrary
g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
t <- UpdateNodeParamsTexts <$> arbitrary
b <- UpdateNodeParamsBoard <$> arbitrary
elements [l,g,t,b]
......
src/Gargantext/API/Prelude.hs
View file @ b7c7b416
......@@ -40,6 +40,7 @@ import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
import Gargantext.Database.Query.Tree
import Gargantext.Prelude
import qualified Gargantext.Utils.Jobs.Monad as Jobs
import Servant
import Servant.Job.Async
import Servant.Job.Core (HasServerError(..), serverError)
......@@ -108,6 +109,7 @@ data GargError
| GargInvalidError Validation
| GargJoseError Jose.Error
| GargServerError ServerError
| GargJobError Jobs.JobError
deriving (Show, Typeable)
makePrisms ''GargError
......
src/Gargantext/API/Routes.hs
View file @ b7c7b416
......@@ -25,11 +25,11 @@ import Data.Validity
import Servant
import Servant.Auth as SA
import Servant.Auth.Swagger ()
import Servant.Job.Async
import Servant.Swagger.UI
import Gargantext.API.Admin.Auth (ForgotPasswordAPI, ForgotPasswordAsyncAPI, withAccess)
import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse, AuthenticatedUser(..), PathId(..))
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
import Gargantext.API.Context
import Gargantext.API.Count (CountAPI, count, Query)
......@@ -44,6 +44,7 @@ import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_max_docs_scrapers)
import Gargantext.Utils.Jobs (serveJobsAPI)
import qualified Gargantext.API.GraphQL as GraphQL
import qualified Gargantext.API.Ngrams.List as List
import qualified Gargantext.API.Node.Contact as Contact
......@@ -219,7 +220,8 @@ serverGargAdminAPI = roots
:<|> nodesAPI
serverPrivateGargAPI' :: AuthenticatedUser -> GargServer GargPrivateAPI'
serverPrivateGargAPI'
:: AuthenticatedUser -> ServerT GargPrivateAPI' (GargM Env GargError)
serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
= serverGargAdminAPI
:<|> nodeAPI (Proxy :: Proxy HyperdataAny) uid
......@@ -272,47 +274,35 @@ waitAPI n = do
pure $ "Waited: " <> (cs $ show n)
----------------------------------------
addCorpusWithQuery :: User -> GargServer New.AddWithQuery
addCorpusWithQuery :: User -> ServerT New.AddWithQuery (GargM Env GargError)
addCorpusWithQuery user cid =
serveJobsAPI $
JobFunction (\q log' -> do
limit <- view $ hasConfig . gc_max_docs_scrapers
New.addToCorpusWithQuery user cid q (Just limit) (liftBase . log')
serveJobsAPI AddCorpusQueryJob $ \q log' -> do
limit <- view $ hasConfig . gc_max_docs_scrapers
New.addToCorpusWithQuery user cid q (Just limit) (liftBase . log')
{- let log' x = do
printDebug "addToCorpusWithQuery" x
liftBase $ log x
-}
)
{-
addWithFile :: GargServer New.AddWithFile
addWithFile cid i f =
serveJobsAPI $
JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftBase . log))
-}
addCorpusWithForm :: User -> GargServer New.AddWithForm
addCorpusWithForm :: User -> ServerT New.AddWithForm (GargM Env GargError)
addCorpusWithForm user cid =
serveJobsAPI $
JobFunction (\i log' ->
serveJobsAPI AddCorpusFormJob $ \i log' ->
let
log'' x = do
printDebug "[addToCorpusWithForm] " x
liftBase $ log' x
in New.addToCorpusWithForm user cid i log'' (jobLogInit 3))
in New.addToCorpusWithForm user cid i log'' (jobLogInit 3)
addCorpusWithFile :: User -> GargServer New.AddWithFile
addCorpusWithFile :: User -> ServerT New.AddWithFile (GargM Env GargError)
addCorpusWithFile user cid =
serveJobsAPI $
JobFunction (\i log' ->
serveJobsAPI AddCorpusFileJob $ \i log' ->
let
log'' x = do
printDebug "[addToCorpusWithFile]" x
liftBase $ log' x
in New.addToCorpusWithFile user cid i log'')
in New.addToCorpusWithFile user cid i log''
addAnnuaireWithForm :: GargServer Annuaire.AddWithForm
addAnnuaireWithForm :: ServerT Annuaire.AddWithForm (GargM Env GargError)
addAnnuaireWithForm cid =
serveJobsAPI $
JobFunction (\i log' -> Annuaire.addToAnnuaireWithForm cid i (liftBase . log'))
serveJobsAPI AddAnnuaireFormJob $ \i log' ->
Annuaire.addToAnnuaireWithForm cid i (liftBase . log')
src/Gargantext/API/Server.hs
View file @ b7c7b416
......@@ -17,7 +17,6 @@ module Gargantext.API.Server where
import Control.Lens ((^.))
import Control.Monad.Except (withExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Aeson
import Data.Text (Text)
import Data.Version (showVersion)
import Servant
......@@ -29,6 +28,7 @@ import qualified Gargantext.API.Public as Public
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.Auth (auth, forgotPassword, forgotPasswordAsync)
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Admin.FrontEnd (frontEndServer)
import qualified Gargantext.API.GraphQL as GraphQL
import Gargantext.API.Prelude
......@@ -41,7 +41,7 @@ import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_url_backend_api)
serverGargAPI :: ToJSON err => Text -> GargServerM env err GargAPI
serverGargAPI :: Text -> ServerT GargAPI (GargM Env GargError)
serverGargAPI baseUrl -- orchestrator
= auth
:<|> forgotPassword
......@@ -56,7 +56,7 @@ serverGargAPI baseUrl -- orchestrator
gargVersion = pure (cs $ showVersion PG.version)
-- | Server declarations
server :: forall env. (Typeable env, EnvC env) => env -> IO (Server API)
server :: Env -> IO (Server API)
server env = do
-- orchestrator <- scrapyOrchestrator env
pure $ swaggerSchemaUIServer swaggerDoc
......@@ -72,7 +72,7 @@ server env = do
GraphQL.api
:<|> frontEndServer
where
transform :: forall a. GargM env GargError a -> Handler a
transform :: forall a. GargM Env GargError a -> Handler a
transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
......
src/Gargantext/API/Table.hs
View file @ b7c7b416
......@@ -61,6 +61,7 @@ type TableApi = Summary "Table API"
:> QueryParam "offset" Int
:> QueryParam "orderBy" OrderBy
:> QueryParam "query" Text
:> QueryParam "year" Text
:> Get '[JSON] (HashedResponse FacetTableResult)
:<|> Summary "Table API (POST)"
:> ReqBody '[JSON] TableQuery
......@@ -106,14 +107,16 @@ getTableApi :: NodeId
-> Maybe Int
-> Maybe OrderBy
-> Maybe Text
-> Maybe Text
-> Cmd err (HashedResponse FacetTableResult)
getTableApi cId tabType _mListId mLimit mOffset mOrderBy mQuery = do
getTableApi cId tabType _mListId mLimit mOffset mOrderBy mQuery mYear = do
printDebug "[getTableApi] mQuery" mQuery
t <- getTable cId tabType mOffset mLimit mOrderBy mQuery
printDebug "[getTableApi] mYear" mYear
t <- getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
pure $ constructHashedResponse t
postTableApi :: NodeId -> TableQuery -> Cmd err FacetTableResult
postTableApi cId (TableQuery o l order ft "") = getTable cId (Just ft) (Just o) (Just l) (Just order) Nothing
postTableApi cId (TableQuery o l order ft "") = getTable cId (Just ft) (Just o) (Just l) (Just order) Nothing Nothing
postTableApi cId (TableQuery o l order ft q) = case ft of
Docs -> searchInCorpus' cId False [q] (Just o) (Just l) (Just order)
Trash -> searchInCorpus' cId True [q] (Just o) (Just l) (Just order)
......@@ -121,7 +124,7 @@ postTableApi cId (TableQuery o l order ft q) = case ft of
getTableHashApi :: NodeId -> Maybe TabType -> Cmd err Text
getTableHashApi cId tabType = do
HashedResponse { hash = h } <- getTableApi cId tabType Nothing Nothing Nothing Nothing Nothing
HashedResponse { hash = h } <- getTableApi cId tabType Nothing Nothing Nothing Nothing Nothing Nothing
pure h
searchInCorpus' :: CorpusId
......@@ -143,10 +146,11 @@ getTable :: NodeId
-> Maybe Limit
-> Maybe OrderBy
-> Maybe Text
-> Maybe Text
-> Cmd err FacetTableResult
getTable cId ft o l order query = do
docs <- getTable' cId ft o l order query
docsCount <- runCountDocuments cId (ft == Just Trash) query
getTable cId ft o l order query year = do
docs <- getTable' cId ft o l order query year
docsCount <- runCountDocuments cId (ft == Just Trash) query year
pure $ TableResult { tr_docs = docs, tr_count = docsCount }
getTable' :: NodeId
......@@ -155,11 +159,12 @@ getTable' :: NodeId
-> Maybe Limit
-> Maybe OrderBy
-> Maybe Text
-> Maybe Text
-> Cmd err [FacetDoc]
getTable' cId ft o l order query =
getTable' cId ft o l order query year =
case ft of
(Just Docs) -> runViewDocuments cId False o l order query
(Just Trash) -> runViewDocuments cId True o l order query
(Just Docs) -> runViewDocuments cId False o l order query year
(Just Trash) -> runViewDocuments cId True o l order query year
(Just MoreFav) -> moreLike cId o l order IsFav
(Just MoreTrash) -> moreLike cId o l order IsTrash
x -> panic $ "not implemented in getTable: " <> (cs $ show x)
......
src/Gargantext/API/ThrowAll.hs
View file @ b7c7b416
......@@ -18,12 +18,12 @@ module Gargantext.API.ThrowAll where
import Control.Monad.Except (MonadError(..))
import Control.Lens ((#))
import Data.Aeson
import Servant
import Servant.Auth.Server (AuthResult(..))
import Gargantext.Prelude
import Gargantext.API.Prelude (GargServerM, _ServerError)
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Prelude
import Gargantext.API.Routes (GargPrivateAPI, serverPrivateGargAPI')
class ThrowAll' e a | a -> e where
......@@ -46,7 +46,8 @@ instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
throwAll' = throwError
serverPrivateGargAPI :: ToJSON err => GargServerM env err GargPrivateAPI
serverPrivateGargAPI
:: ServerT GargPrivateAPI (GargM Env GargError)
serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
serverPrivateGargAPI _ = throwAll' (_ServerError # err401)
-- Here throwAll' requires a concrete type for the monad.
src/Gargantext/Core/Mail.hs
View file @ b7c7b416
......@@ -17,7 +17,7 @@ import Data.Text (Text, unlines, splitOn)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Schema.User (UserLight(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_url)
import Gargantext.Prelude.Config (gc_url, gc_backend_name)
import Gargantext.Database.Prelude
-- import Gargantext.Prelude.Config (gc_url)
import Gargantext.Prelude.Mail (gargMail, GargMail(..))
......@@ -34,7 +34,9 @@ data SendEmail = SendEmail Bool
type EmailAddress = Text
type Name = Text
type ServerAddress = Text
data ServerAddress = ServerAddress { sa_name :: Text
, sa_url :: Text
}
data MailModel = Invitation { invitation_user :: NewUser GargPassword }
| PassUpdate { passUpdate_user :: NewUser GargPassword }
......@@ -50,7 +52,7 @@ mail mailCfg model = do
let
(m,u) = email_to model
subject = email_subject model
body = emailWith (view gc_url cfg) model
body = emailWith (ServerAddress (view gc_backend_name cfg) (view gc_url cfg)) model
liftBase $ gargMail mailCfg (GargMail { gm_to = m
, gm_name = Just u
, gm_subject = subject
......@@ -76,14 +78,14 @@ email_to' (NewUser u m _) = (m,u)
------------------------------------------------------------------------
bodyWith :: ServerAddress -> MailModel -> [Text]
bodyWith server (Invitation u) = [ "Congratulation, you have been granted a user account to test the"
, "new GarganText platform!"
bodyWith server@(ServerAddress name _url) (Invitation u) = [ "Congratulation, you have been granted a user account to test the"
, "new GarganText platform called " <> name <> " !"
] <> (email_credentials server u)
bodyWith server (PassUpdate u) = [ "Your account password have been updated on the GarganText platform!"
] <> (email_credentials server u)
bodyWith server (MailInfo _ _) = [ "Your last analysis is over on the server: " <> server]
bodyWith (ServerAddress _ url) (MailInfo _ _) = [ "Your last analysis is over on the server: " <> url]
bodyWith _server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Nothing }}) =
[ "Cannot send you link to forgot password, no UUID" ]
bodyWith server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Just uuid }}) =
......@@ -91,7 +93,7 @@ bodyWith server (ForgotPassword { user = UserLight { userLight_forgot_password_u
, forgot_password_link server uuid ]
forgot_password_link :: ServerAddress -> Text -> Text
forgot_password_link server uuid = server <> "/#/forgotPassword?uuid=" <> uuid <> "&server=" <> encodeText server
forgot_password_link (ServerAddress _ server) uuid = server <> "/#/forgotPassword?uuid=" <> uuid <> "&server=" <> encodeText server
------------------------------------------------------------------------
email_subject :: MailModel -> Text
......@@ -102,7 +104,7 @@ email_subject (ForgotPassword _) = "[GarganText] Forgot Password"
email_credentials :: ServerAddress -> NewUser GargPassword -> [Text]
email_credentials server (NewUser u _ (GargPassword p)) =
email_credentials (ServerAddress _ server) (NewUser u _ (GargPassword p)) =
[ ""
, "You can log in to: " <> server
, "Your username is: " <> u
......@@ -113,22 +115,20 @@ email_credentials server (NewUser u _ (GargPassword p)) =
email_disclaimer :: [Text]
email_disclaimer =
[ ""
, "If you log in you agree with the following terms of use:"
, " https://gitlab.iscpif.fr/humanities/tofu/tree/master"
, ""
, ""
, "/!\\ Please note that your account is opened for beta tester only. Hence"
, "we cannot guarantee neither the perenniality nor the stability of the"
, "service at this stage. It is therefore advisable to back up important"
, "data regularly."
, ""
, "/!\\ Gargantext is an academic service supported by ISC-PIF partners."
, "/!\\ Gargantext is an academic service supported by CNRS/ISC-PIF partners."
, "In case of congestion on this service, access to members of the ISC-PIF"
, "partners will be privileged."
, ""
, "If you log in you agree with the following terms of use:"
, " https://gitlab.iscpif.fr/humanities/tofu/tree/master"
, ""
, "Your feedback will be valuable for further development of the platform,"
, "do not hesitate to contact us and to contribute on our forum:"
, ""
, " https://discourse.iscpif.fr/c/gargantext"
, ""
]
......
src/Gargantext/Core/Methods/Graph/MaxClique.hs
View file @ b7c7b416
......@@ -62,7 +62,7 @@ import Data.Set (fromList, toList, isSubsetOf)
import Data.Graph.Inductive hiding (Graph, neighbors, subgraph, (&))
import Gargantext.Core.Viz.Graph.FGL (Graph_Undirected, degree, neighbors, mkGraphUfromEdges)
import Gargantext.Core.Viz.Graph.Tools (cooc2graph',cooc2graph'', Threshold)
import Gargantext.Core.Methods.Distances (Distance)
import Gargantext.Core.Methods.Similarities (Similarity)
import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex)
import Gargantext.Core.Viz.Phylo
-- import Debug.Trace (trace)
......@@ -70,9 +70,9 @@ type Graph = Graph_Undirected
type Neighbor = Node
-- | getMaxCliques
-- TODO chose distance order
-- TODO chose similarity order
getMaxCliques :: Ord a => MaxCliqueFilter -> Distance -> Threshold -> Map (a, a) Int -> [[a]]
getMaxCliques :: Ord a => MaxCliqueFilter -> Similarity -> Threshold -> Map (a, a) Int -> [[a]]
getMaxCliques f d t m = map fromIndices $ getMaxCliques' t m'
where
m' = toIndex to m
......
src/Gargantext/Core/Methods/Distances.hs → src/Gargantext/Core/Methods/Similarities.hs
View file @ b7c7b416
{-|
Module : Gargantext.Graph.Distances
Description : Distance management tools
Module : Gargantext.Graph.Similarities
Description : Similarity management tools
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
......@@ -11,32 +11,32 @@ Portability : POSIX
{-# LANGUAGE Strict #-}
module Gargantext.Core.Methods.Distances
module Gargantext.Core.Methods.Similarities
where
import Data.Aeson
import Data.Array.Accelerate (Matrix)
import Data.Swagger
import GHC.Generics (Generic)
import Gargantext.Core.Methods.Distances.Accelerate.Conditional (measureConditional)
import Gargantext.Core.Methods.Distances.Accelerate.Distributional (logDistributional)
import Gargantext.Core.Methods.Similarities.Accelerate.Conditional (measureConditional)
import Gargantext.Core.Methods.Similarities.Accelerate.Distributional (logDistributional)
import Gargantext.Prelude (Ord, Eq, Int, Double, Show)
import Prelude (Enum, Bounded, minBound, maxBound)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
------------------------------------------------------------------------
data Distance = Conditional | Distributional
data Similarity = Conditional | Distributional
deriving (Show, Eq)
measure :: Distance -> Matrix Int -> Matrix Double
measure :: Similarity -> Matrix Int -> Matrix Double
measure Conditional x = measureConditional x
measure Distributional x = y
where
y = logDistributional x
------------------------------------------------------------------------
withMetric :: GraphMetric -> Distance
withMetric :: GraphMetric -> Similarity
withMetric Order1 = Conditional
withMetric Order2 = Distributional
......
src/Gargantext/Core/Methods/Distances/Accelerate/Conditional.hs → src/Gargantext/Core/Methods/Similarities/Accelerate/Conditional.hs
View file @ b7c7b416
{-|
Module : Gargantext.Core.Methods.Distances.Accelerate.Conditional
Module : Gargantext.Core.Methods.Similarities.Accelerate.Conditional
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -20,7 +20,7 @@ See Gargantext.Core.Methods.Graph.Accelerate)
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.Core.Methods.Distances.Accelerate.Conditional
module Gargantext.Core.Methods.Similarities.Accelerate.Conditional
where
-- import qualified Data.Foldable as P (foldl1)
......@@ -28,7 +28,7 @@ module Gargantext.Core.Methods.Distances.Accelerate.Conditional
import Data.Array.Accelerate
import Data.Array.Accelerate.Interpreter (run)
import Gargantext.Core.Methods.Matrix.Accelerate.Utils
import Gargantext.Core.Methods.Distances.Accelerate.SpeGen
import Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
import qualified Gargantext.Prelude as P
......
src/Gargantext/Core/Methods/Distances/Accelerate/Distributional.hs → src/Gargantext/Core/Methods/Similarities/Accelerate/Distributional.hs
View file @ b7c7b416
{-|
Module : Gargantext.Core.Methods.Distances.Accelerate.Distributional
Module : Gargantext.Core.Methods.Similarities.Accelerate.Distributional
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -8,7 +8,7 @@ Stability : experimental
Portability : POSIX
* Distributional Distance metric
* Distributional Similarity metric
__Definition :__ Distributional metric is a relative metric which depends on the
selected list, it represents structural equivalence of mutual information.
......@@ -41,7 +41,7 @@ where $n_{ij}$ is the cooccurrence between term $i$ and term $j$
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}
module Gargantext.Core.Methods.Distances.Accelerate.Distributional
module Gargantext.Core.Methods.Similarities.Accelerate.Distributional
where
-- import qualified Data.Foldable as P (foldl1)
......
src/Gargantext/Core/Methods/Distances/Accelerate/SpeGen.hs → src/Gargantext/Core/Methods/Similarities/Accelerate/SpeGen.hs
View file @ b7c7b416
{-|
Module : Gargantext.Core.Methods.Distances.Accelerate.SpeGen
Module : Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -20,7 +20,7 @@ See Gargantext.Core.Methods.Graph.Accelerate)
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.Core.Methods.Distances.Accelerate.SpeGen
module Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
where
-- import qualified Data.Foldable as P (foldl1)
......
src/Gargantext/Core/Methods/Distances/Conditional.hs → src/Gargantext/Core/Methods/Similarities/Conditional.hs
View file @ b7c7b416
{-|
Module : Gargantext.Core.Methods.Distances
Module : Gargantext.Core.Methods.Similarities
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -12,7 +12,7 @@ Motivation and definition of the @Conditional@ distance.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Strict #-}
module Gargantext.Core.Methods.Distances.Conditional
module Gargantext.Core.Methods.Similarities.Conditional
where
import Control.DeepSeq (NFData)
......
src/Gargantext/Core/Methods/Distances/Distributional.hs → src/Gargantext/Core/Methods/Similarities/Distributional.hs
View file @ b7c7b416
{-|
Module : Gargantext.Core.Methods.Distances.Distributional
Module : Gargantext.Core.Methods.Similarities.Distributional
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -14,7 +14,7 @@ Motivation and definition of the @Distributional@ distance.
{-# LANGUAGE Strict #-}
module Gargantext.Core.Methods.Distances.Distributional
module Gargantext.Core.Methods.Similarities.Distributional
where
import Data.Matrix hiding (identity)
......
src/Gargantext/Core/NodeStory.hs
View file @ b7c7b416
......@@ -455,7 +455,7 @@ insertArchiveList c nodeId a = do
where
query :: PGS.Query
query = [sql| INSERT INTO node_stories(node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
SELECT ?, ?, ?, ngrams.id, ? FROM ngrams WHERE terms = ? |]
SELECT * WHERE EXISTS (SELECT ?, ?, ?, ngrams.id, ? FROM ngrams WHERE terms = ?) |]
deleteArchiveList :: PGS.Connection -> NodeId -> ArchiveList -> IO ()
deleteArchiveList c nodeId a = do
......
src/Gargantext/Core/Text/Metrics.hs
View file @ b7c7b416
......@@ -23,7 +23,7 @@ import Data.Map (Map)
import Data.Monoid (Monoid, mempty)
import Data.HashMap.Strict (HashMap)
import Data.Semigroup (Semigroup)
import Gargantext.Core.Methods.Distances.Accelerate.SpeGen
import Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
import Gargantext.Core.Statistics (pcaReduceTo, Dimension(..))
import Gargantext.Core.Viz.Graph.Index
import Gargantext.Prelude
......
src/Gargantext/Core/Text/Metrics/CharByChar.hs
View file @ b7c7b416
......@@ -39,7 +39,7 @@ import Gargantext.Prelude
-- starting as an API rexporting main functions of the great lib
-- text-metrics of Mark Karpov
-- | Levenshtein Distance
-- | Levenshtein Similarity
-- In information theory, Linguistics and computer science,
-- the Levenshtein distance is a string metric for measuring
-- the difference between two sequences.
......@@ -86,7 +86,7 @@ overlap = DTM.overlap
jaccard :: Text -> Text -> Ratio Int
jaccard = DTM.jaccard
-- | Hamming Distance
-- | Hamming Similarity
-- In information theory, the Hamming distance between two strings of
-- equal length is the number of positions at which the corresponding
-- symbols are different. In other words, it measures the minimum number of
......
src/Gargantext/Core/Viz/Graph.hs
View file @ b7c7b416
This diff is collapsed.
src/Gargantext/Core/Viz/Graph/API.hs
View file @ b7c7b416
......@@ -23,10 +23,11 @@ import Data.Swagger
import Data.Text hiding (head)
import Debug.Trace (trace)
import GHC.Generics (Generic)
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Prelude
import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
import Gargantext.Core.Methods.Similarities (Similarity(..), GraphMetric(..), withMetric)
import Gargantext.Core.NodeStory
import Gargantext.Core.Types.Main
import Gargantext.Core.Viz.Graph
......@@ -46,8 +47,9 @@ import Gargantext.Database.Query.Table.Node.User (getNodeUser)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Ngrams
import Gargantext.Prelude
import Gargantext.Utils.Jobs (serveJobsAPI)
import Servant
import Servant.Job.Async
import Servant.Job.Async (AsyncJobsAPI)
import Servant.XML
import qualified Data.HashMap.Strict as HashMap
......@@ -72,7 +74,7 @@ instance FromJSON GraphVersions
instance ToJSON GraphVersions
instance ToSchema GraphVersions
graphAPI :: UserId -> NodeId -> GargServer GraphAPI
graphAPI :: UserId -> NodeId -> ServerT GraphAPI (GargM Env GargError)
graphAPI u n = getGraph u n
:<|> graphAsync u n
:<|> graphClone u n
......@@ -99,13 +101,14 @@ getGraph _uId nId = do
listId <- defaultList cId
repo <- getRepo [listId]
-- TODO Distance in Graph params
-- TODO Similarity in Graph params
case graph of
Nothing -> do
let defaultMetric = Order1
let defaultPartitionMethod = Spinglass
let defaultEdgesStrength = Strong
graph' <- computeGraph cId defaultPartitionMethod (withMetric defaultMetric) defaultEdgesStrength NgramsTerms repo
let defaultBridgenessMethod = BridgenessMethod_Basic
graph' <- computeGraph cId defaultPartitionMethod defaultBridgenessMethod (withMetric defaultMetric) defaultEdgesStrength (NgramsTerms, NgramsTerms) repo
mt <- defaultGraphMetadata cId "Title" repo defaultMetric defaultEdgesStrength
let
graph'' = set graph_metadata (Just mt) graph'
......@@ -123,20 +126,23 @@ recomputeGraph :: FlowCmdM env err m
=> UserId
-> NodeId
-> PartitionMethod
-> BridgenessMethod
-> Maybe GraphMetric
-> Maybe Strength
-> NgramsType
-> NgramsType
-> Bool
-> m Graph
recomputeGraph _uId nId method maybeDistance maybeStrength force = do
recomputeGraph _uId nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt1 nt2 force = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let
graph = nodeGraph ^. node_hyperdata . hyperdataGraph
camera = nodeGraph ^. node_hyperdata . hyperdataCamera
graphMetadata = graph ^? _Just . graph_metadata . _Just
listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
graphMetric = case maybeDistance of
graphMetric = case maybeSimilarity of
Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
_ -> maybeDistance
_ -> maybeSimilarity
similarity = case graphMetric of
Nothing -> withMetric Order1
Just m -> withMetric m
......@@ -155,14 +161,14 @@ recomputeGraph _uId nId method maybeDistance maybeStrength force = do
let v = repo ^. unNodeStory . at listId . _Just . a_version
let computeG mt = do
!g <- computeGraph cId method similarity strength NgramsTerms repo
!g <- computeGraph cId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo
let g' = set graph_metadata mt g
_nentries <- updateHyperdata nId (HyperdataGraph (Just g') camera)
pure g'
case graph of
Nothing -> do
mt <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance) strength
mt <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeSimilarity) strength
g <- computeG $ Just mt
pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" g
Just graph' -> if (listVersion == Just v) && (not force)
......@@ -172,34 +178,54 @@ recomputeGraph _uId nId method maybeDistance maybeStrength force = do
pure $ trace "[G.V.G.API] Graph exists, recomputing" g
-- TODO remove repo
computeGraph :: FlowCmdM env err m
=> CorpusId
-> PartitionMethod
-> Distance
-> BridgenessMethod
-> Similarity
-> Strength
-> NgramsType
-> (NgramsType, NgramsType)
-> NodeListStory
-> m Graph
computeGraph cId method d strength nt repo = do
lId <- defaultList cId
computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo = do
-- Getting the Node parameters
lId <- defaultList corpusId
lIds <- selectNodesWithUsername NodeList userMaster
let ngs = filterListWithRoot [MapTerm]
$ mapTermListRoot [lId] nt repo
!myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
<$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs
<$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
graph <- liftBase $ cooc2graphWith method d 0 strength myCooc
--listNgrams <- getListNgrams [lId] nt
--let graph' = mergeGraphNgrams graph (Just listNgrams)
-- saveAsFileDebug "/tmp/graphWithNodes" graph'
-- Getting the Ngrams to compute with and grouping it according to the lists
let
groupedContextsByNgrams nt corpusId' (lists_master, lists_user) = do
let
ngs = filterListWithRoot [MapTerm] $ mapTermListRoot lists_user nt repo
groupNodesByNgrams ngs <$> getContextsByNgramsOnlyUser corpusId'
(lists_user <> lists_master) nt (HashMap.keys ngs)
-- Optim if nt1 == nt2 : do not compute twice
(m1,m2) <- do
m1 <- groupedContextsByNgrams nt1 corpusId (lIds, [lId])
if nt1 == nt2
then
pure (m1,m1)
else do
m2 <- groupedContextsByNgrams nt2 corpusId (lIds, [lId])
pure (m1,m2)
-- Removing the hapax (ngrams with 1 cooc)
let !myCooc = HashMap.filter (>1)
$ getCoocByNgrams'' (Diagonal True) (identity, identity) (m1,m2)
-- TODO MultiPartite Here
graph <- liftBase
$ cooc2graphWith partitionMethod bridgeMethod (MultiPartite (Partite (HashMap.keysSet m1) nt1)
(Partite (HashMap.keysSet m2) nt2)
)
similarity 0 strength myCooc
pure graph
defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> Text
......@@ -231,16 +257,17 @@ type GraphAsyncAPI = Summary "Recompute graph"
:> AsyncJobsAPI JobLog () JobLog
graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
graphAsync :: UserId -> NodeId -> ServerT GraphAsyncAPI (GargM Env GargError)
graphAsync u n =
serveJobsAPI $
JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
serveJobsAPI RecomputeGraphJob $ \_ log' ->
graphRecompute u n (liftBase . log')
--graphRecompute :: UserId
-- -> NodeId
-- -> (JobLog -> GargNoServer ())
-- -> GargNoServer JobLog
-- TODO get Graph Metadata to recompute
graphRecompute :: FlowCmdM env err m
=> UserId
-> NodeId
......@@ -252,7 +279,7 @@ graphRecompute u n logStatus = do
, _scst_remaining = Just 1
, _scst_events = Just []
}
_g <- recomputeGraph u n Spinglass Nothing Nothing False
_g <- recomputeGraph u n Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
pure JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 0
......@@ -307,7 +334,7 @@ recomputeVersions :: FlowCmdM env err m
=> UserId
-> NodeId
-> m Graph
recomputeVersions uId nId = recomputeGraph uId nId Spinglass Nothing Nothing False
recomputeVersions uId nId = recomputeGraph uId nId Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
------------------------------------------------------------
graphClone :: UserId
......
src/Gargantext/Core/Viz/Graph/Bridgeness.hs
View file @ b7c7b416
......@@ -7,62 +7,83 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Let be a graph with partitions (from Louvain algo), Bridgeness uniformly
Let be a graph Bridgeness filters inter-communities links in two ways.
If the partitions are known, filtering is uniform to expose the communities clearly for the beginners.
But
uniformly
filters inter-communities links.
TODO rewrite Bridgeness with "equivalence structurale" metrics (Confluence)
TODO use Map LouvainNodeId (Map LouvainNodeId)
-}
{-# LANGUAGE BangPatterns #-}
module Gargantext.Core.Viz.Graph.Bridgeness -- (bridgeness)
where
import Data.List (concat, sortOn)
import Gargantext.Core.Methods.Similarities (Similarity(..))
-- import Data.IntMap (IntMap)
import Data.Map (Map, fromListWith, lookup, toList, mapWithKey, elems)
import Data.Maybe (catMaybes)
import Data.Ord (Down(..))
import Debug.Trace (trace)
import Gargantext.Prelude
import Graph.Types (ClusterNode(..))
import qualified Data.Map as DM
-- import qualified Data.IntMap as IntMap
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
----------------------------------------------------------------------
type Partitions a = Map (Int, Int) Double -> IO [a]
type Partitions = Map (Int, Int) Double -> IO [ClusterNode]
----------------------------------------------------------------------
class ToComId a where
nodeId2comId :: a -> (NodeId,CommunityId)
nodeId2comId :: ClusterNode -> (NodeId, CommunityId)
nodeId2comId (ClusterNode i1 i2) = (i1, i2)
type NodeId = Int
type CommunityId = Int
----------------------------------------------------------------------
instance ToComId ClusterNode where
nodeId2comId (ClusterNode i1 i2) = (i1, i2)
----------------------------------------------------------------------
----------------------------------------------------------------------
type Bridgeness = Double
bridgeness :: ToComId a => Bridgeness
-> [a]
-> Map (NodeId, NodeId) Double
-> Map (NodeId, NodeId) Double
bridgeness = bridgeness' nodeId2comId
bridgeness' :: (a -> (Int, Int))
-> Bridgeness
-> [a]
-> Map (Int, Int) Double
-> Map (Int, Int) Double
bridgeness' f b ns = DM.fromList
. concat
. DM.elems
. filterComs b
. groupEdges (DM.fromList $ map f ns)
data Bridgeness = Bridgeness_Basic { bridgeness_partitions :: [ClusterNode]
, bridgeness_filter :: Double
}
| Bridgeness_Advanced { bridgeness_similarity :: Similarity
, bridgness_confluence :: Confluence
}
type Confluence = Map (NodeId, NodeId) Double
bridgeness :: Bridgeness
-> Map (NodeId, NodeId) Double
-> Map (NodeId, NodeId) Double
bridgeness (Bridgeness_Advanced sim c) m = Map.fromList
$ map (\(ks, (v1,_v2)) -> (ks,v1))
$ List.take (if sim == Conditional then 2*n else 3*n)
$ List.sortOn (Down . (snd . snd))
$ Map.toList
$ trace ("bridgeness3 m c" <> show (m,c)) $ Map.intersectionWithKey (\k v1 v2 -> trace ("intersectionWithKey " <> (show (k, v1, v2))) (v1, v2)) m c
where
!m' = Map.toList m
n :: Int
!n = trace ("bridgeness m size: " <> (show $ List.length m'))
$ round
$ (fromIntegral $ List.length m') / (log $ fromIntegral nodesNumber :: Double)
nodesNumber :: Int
nodesNumber = Set.size $ Set.fromList $ as <> bs
where
(as, bs) = List.unzip $ Map.keys m
bridgeness (Bridgeness_Basic ns b) m = Map.fromList
$ List.concat
$ Map.elems
$ filterComs b
$ groupEdges (Map.fromList $ map nodeId2comId ns) m
groupEdges :: (Ord a, Ord b1)
=> Map b1 a
......@@ -71,7 +92,7 @@ groupEdges :: (Ord a, Ord b1)
groupEdges m = fromListWith (<>)
. catMaybes
. map (\((n1,n2), d)
-> let
-> let
n1n2_m = (,) <$> lookup n1 m <*> lookup n2 m
n1n2_d = Just [((n1,n2),d)]
in (,) <$> n1n2_m <*> n1n2_d
......@@ -79,19 +100,57 @@ groupEdges m = fromListWith (<>)
. toList
-- | TODO : sortOn Confluence
filterComs :: (Ord n1, Eq n2)
filterComs :: (Ord n1, Eq n2)
=> p
-> Map (n2, n2) [(a3, n1)]
-> Map (n2, n2) [(a3, n1)]
filterComs _b m = DM.filter (\n -> length n > 0) $ mapWithKey filter' m
filterComs _b m = Map.filter (\n -> length n > 0) $ mapWithKey filter' m
where
filter' (c1,c2) a
| c1 == c2 = a
-- TODO use n here
| otherwise = take 1 $ sortOn (Down . snd) a
| otherwise = take 1 $ List.sortOn (Down . snd) a
where
_n :: Int
_n = round $ 100 * a' / t
a'= fromIntegral $ length a
t :: Double
t = fromIntegral $ length $ concat $ elems m
t = fromIntegral $ length $ List.concat $ elems m
--------------------------------------------------------------
-- Utils
{--
map2intMap :: Map (Int, Int) a -> IntMap (IntMap a)
map2intMap m = IntMap.fromListWith (<>)
$ map (\((k1,k2), v) -> if k1 < k2
then (k1, IntMap.singleton k2 v)
else (k2, IntMap.singleton k1 v)
)
$ Map.toList m
look :: (Int,Int) -> IntMap (IntMap a) -> Maybe a
look (k1,k2) m = if k1 < k2
then case (IntMap.lookup k1 m) of
Just m' -> IntMap.lookup k2 m'
_ -> Nothing
else look (k2,k1) m
{-
Compute the median of a list
From: https://hackage.haskell.org/package/dsp-0.2.5.1/docs/src/Numeric.Statistics.Median.html
Compute the center of the list in a more lazy manner
and thus halves memory requirement.
-}
median :: (Ord a, Fractional a) => [a] -> a
median [] = panic "medianFast: empty list has no median"
median zs =
let recurse (x0:_) (_:[]) = x0
recurse (x0:x1:_) (_:_:[]) = (x0+x1)/2
recurse (_:xs) (_:_:ys) = recurse xs ys
recurse _ _ =
panic "median: this error cannot occur in the way 'recurse' is called"
in recurse zs zs
-}
src/Gargantext/Core/Viz/Graph/Index.hs
View file @ b7c7b416
{-|
Module : Gargantext.Graph.Distances.Utils
Module : Gargantext.Graph.Similarities.Utils
Description : Tools to compute distances from Cooccurrences
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......
src/Gargantext/Core/Viz/Graph/Tools.hs
View file @ b7c7b416
......@@ -22,14 +22,15 @@ import Data.Swagger hiding (items)
import GHC.Float (sin, cos)
import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.Core.Methods.Distances (Distance(..), measure)
import Gargantext.Core.Methods.Distances.Conditional (conditional)
import Gargantext.Core.Methods.Similarities (Similarity(..), measure)
import Gargantext.Core.Methods.Similarities.Conditional (conditional)
import Gargantext.Core.Statistics
import Gargantext.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness, Partitions, ToComId(..))
import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness, Bridgeness(..), Partitions, nodeId2comId)
import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index, MatrixShape(..))
import Gargantext.Core.Viz.Graph.Tools.IGraph (mkGraphUfromEdges, spinglass)
import Gargantext.Core.Viz.Graph.Tools.Infomap (infomap)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Core.Viz.Graph.Utils (edgesFilter, nodesFilter)
import Gargantext.Prelude
import Graph.Types (ClusterNode)
......@@ -40,6 +41,7 @@ import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.HashSet as HashSet
import qualified Data.Text as Text
import qualified Data.Vector.Storable as Vec
import qualified Graph.BAC.ProxemyOptim as BAC
......@@ -55,6 +57,14 @@ instance ToSchema PartitionMethod
instance Arbitrary PartitionMethod where
arbitrary = elements [ minBound .. maxBound ]
data BridgenessMethod = BridgenessMethod_Basic | BridgenessMethod_Advanced
deriving (Generic, Eq, Ord, Enum, Bounded, Show)
instance FromJSON BridgenessMethod
instance ToJSON BridgenessMethod
instance ToSchema BridgenessMethod
instance Arbitrary BridgenessMethod where
arbitrary = elements [ minBound .. maxBound ]
-------------------------------------------------------------
defaultClustering :: Map (Int, Int) Double -> IO [ClusterNode]
......@@ -65,7 +75,7 @@ defaultClustering x = spinglass 1 x
type Threshold = Double
cooc2graph' :: Ord t => Distance
cooc2graph' :: Ord t => Similarity
-> Double
-> Map (t, t) Int
-> Map (Index, Index) Double
......@@ -87,26 +97,30 @@ cooc2graph' distance threshold myCooc
-- coocurrences graph computation
cooc2graphWith :: PartitionMethod
-> Distance
-> BridgenessMethod
-> MultiPartite
-> Similarity
-> Threshold
-> Strength
-> HashMap (NgramsTerm, NgramsTerm) Int
-> IO Graph
cooc2graphWith Spinglass = cooc2graphWith' (spinglass 1)
cooc2graphWith Confluence= cooc2graphWith' (\x -> pure $ BAC.defaultClustering x)
cooc2graphWith Infomap = cooc2graphWith' (infomap "--silent --two-level -N2")
cooc2graphWith Infomap = cooc2graphWith' (infomap "-v -N2")
--cooc2graphWith Infomap = cooc2graphWith' (infomap "--silent --two-level -N2")
-- TODO: change these options, or make them configurable in UI?
cooc2graphWith' :: ToComId a
=> Partitions a
-> Distance
-> Threshold
-> Strength
-> HashMap (NgramsTerm, NgramsTerm) Int
-> IO Graph
cooc2graphWith' doPartitions distance threshold strength myCooc = do
let (distanceMap, diag, ti) = doDistanceMap distance threshold strength myCooc
cooc2graphWith' :: Partitions
-> BridgenessMethod
-> MultiPartite
-> Similarity
-> Threshold
-> Strength
-> HashMap (NgramsTerm, NgramsTerm) Int
-> IO Graph
cooc2graphWith' doPartitions bridgenessMethod multi similarity threshold strength myCooc = do
let (distanceMap, diag, ti) = doSimilarityMap similarity threshold strength myCooc
distanceMap `seq` diag `seq` ti `seq` return ()
--{- -- Debug
......@@ -122,19 +136,18 @@ cooc2graphWith' doPartitions distance threshold strength myCooc = do
, "Tutorial: link todo"
]
length partitions `seq` return ()
let
nodesApprox :: Int
nodesApprox = n'
where
(as, bs) = List.unzip $ Map.keys distanceMap
n' = Set.size $ Set.fromList $ as <> bs
!bridgeness' = bridgeness (fromIntegral nodesApprox) partitions distanceMap
!confluence' = BAC.computeConfluences 3 (Map.keys bridgeness') True
pure $ data2graph ti diag bridgeness' confluence' partitions
!confluence' = BAC.computeConfluences 3 (Map.keys distanceMap) True
!bridgeness' = if bridgenessMethod == BridgenessMethod_Basic
then bridgeness (Bridgeness_Basic partitions 1.0) distanceMap
else bridgeness (Bridgeness_Advanced similarity confluence') distanceMap
pure $ data2graph multi ti diag bridgeness' confluence' partitions
type Reverse = Bool
doDistanceMap :: Distance
doSimilarityMap :: Similarity
-> Threshold
-> Strength
-> HashMap (NgramsTerm, NgramsTerm) Int
......@@ -142,7 +155,7 @@ doDistanceMap :: Distance
, Map (Index, Index) Int
, Map NgramsTerm Index
)
doDistanceMap Distributional threshold strength myCooc = (distanceMap, toIndex ti diag, ti)
doSimilarityMap Distributional threshold strength myCooc = (distanceMap, toIndex ti diag, ti)
where
-- TODO remove below
(diag, theMatrix) = Map.partitionWithKey (\(x,y) _ -> x == y)
......@@ -168,11 +181,11 @@ doDistanceMap Distributional threshold strength myCooc = (distanceMap, toIndex t
$ (\m -> m `seq` Map.filter (> threshold) m)
$ similarities `seq` mat2map similarities
doDistanceMap Conditional threshold strength myCooc = (distanceMap, toIndex ti myCooc', ti)
doSimilarityMap Conditional threshold strength myCooc = (distanceMap, toIndex ti myCooc', ti)
where
myCooc' = Map.fromList $ HashMap.toList myCooc
(ti, _it) = createIndices myCooc'
links = round (let n :: Double = fromIntegral (Map.size ti) in n * log n)
links = round (let n :: Double = fromIntegral (Map.size ti) in n * (log n)^(2::Int))
distanceMap = toIndex ti
$ Map.fromList
$ List.take links
......@@ -184,36 +197,45 @@ doDistanceMap Conditional threshold strength myCooc = (distanceMap, toIndex ti m
----------------------------------------------------------
-- | From data to Graph
type Occurrences = Int
data2graph :: ToComId a
=> Map NgramsTerm Int
nodeTypeWith :: MultiPartite -> NgramsTerm -> NgramsType
nodeTypeWith (MultiPartite (Partite s1 t1) (Partite _s2 t2)) t =
if HashSet.member t s1
then t1
else t2
data2graph :: MultiPartite
-> Map NgramsTerm Int
-> Map (Int, Int) Occurrences
-> Map (Int, Int) Double
-> Map (Int, Int) Double
-> [a]
-> [ClusterNode]
-> Graph
data2graph labels' occurences bridge conf partitions = Graph { _graph_nodes = nodes
, _graph_edges = edges
, _graph_metadata = Nothing
}
where
data2graph multi labels' occurences bridge conf partitions =
Graph { _graph_nodes = nodes
, _graph_edges = edges
, _graph_metadata = Nothing
}
where
nodes = map (setCoord ForceAtlas labels bridge)
[ (n, Node { node_size = maybe 0 identity (Map.lookup (n,n) occurences)
, node_type = Terms -- or Unknown
, node_id = cs (show n)
, node_label = unNgramsTerm l
, node_type = nodeTypeWith multi label
, node_id = (cs . show) n
, node_label = unNgramsTerm label
, node_x_coord = 0
, node_y_coord = 0
, node_attributes = Attributes { clust_default = fromMaybe 0
(Map.lookup n community_id_by_node_id)
}
, node_attributes =
Attributes { clust_default = fromMaybe 0
(Map.lookup n community_id_by_node_id)
}
, node_children = []
}
)
| (l, n) <- labels
| (label, n) <- labels
, Set.member n toKeep
]
......@@ -302,7 +324,7 @@ layout m n gen = maybe (panic "") identity $ Map.lookup n $ coord
-----------------------------------------------------------------------------
-- MISC Tools
cooc2graph'' :: Ord t => Distance
cooc2graph'' :: Ord t => Similarity
-> Double
-> Map (t, t) Int
-> Map (Index, Index) Double
......
src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
View file @ b7c7b416
......@@ -21,7 +21,7 @@ import Data.Vector (Vector)
import Debug.Trace (trace)
import Prelude (floor)
import Gargantext.Core.Methods.Distances (Distance(Conditional))
import Gargantext.Core.Methods.Similarities (Similarity(Conditional))
import Gargantext.Core.Methods.Graph.MaxClique (getMaxCliques)
import Gargantext.Core.Text.Context (TermList)
import Gargantext.Core.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, fisWithSizePolyMap', Size(..))
......
src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
View file @ b7c7b416
......@@ -210,8 +210,8 @@ synchronicClustering phylo =
in toNextScale phylo $ levelUpAncestors $ concat newBranches'
-- synchronicDistance :: Phylo -> Level -> String
-- synchronicDistance phylo lvl =
-- synchronicSimilarity :: Phylo -> Level -> String
-- synchronicSimilarity phylo lvl =
-- foldl' (\acc branch ->
-- acc <> (foldl' (\acc' period ->
-- acc' <> let prox = phyloProximity $ getConfig phylo
......
src/Gargantext/Database/Action/Learn.hs
View file @ b7c7b416
......@@ -44,10 +44,10 @@ getPriors :: HasDBid NodeType => FavOrTrash -> CorpusId -> Cmd err (Events Bool)
getPriors ft cId = do
docs_fav <- filter (\(FacetDoc _ _ _ _ f _ _) -> f == Just 2)
<$> runViewDocuments cId False Nothing Nothing Nothing Nothing
<$> runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
docs_trash <- List.take (List.length docs_fav)
<$> runViewDocuments cId True Nothing Nothing Nothing Nothing
<$> runViewDocuments cId True Nothing Nothing Nothing Nothing Nothing
let priors = priorEventsWith text (fav2bool ft) ( List.zip (repeat False) docs_fav
......@@ -62,7 +62,7 @@ moreLikeWith :: HasDBid NodeType
moreLikeWith cId o l order ft priors = do
docs_test <- filter (\(FacetDoc _ _ _ _ f _ _) -> f == Just 1)
<$> runViewDocuments cId False o Nothing order Nothing
<$> runViewDocuments cId False o Nothing order Nothing Nothing
let results = map fst
$ filter ((==) (Just $ not $ fav2bool ft) . snd)
......
src/Gargantext/Database/Action/Metrics/NgramsByContext.hs
View file @ b7c7b416
......@@ -20,7 +20,6 @@ module Gargantext.Database.Action.Metrics.NgramsByContext
--import Data.Map.Strict.Patch (PatchMap, Replace, diff)
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Text (Text)
import Data.Tuple.Extra (first, second, swap)
......@@ -31,8 +30,7 @@ import Gargantext.Core
import Gargantext.Data.HashMap.Strict.Utils as HM
import Gargantext.Database.Admin.Types.Node (ListId, CorpusId, NodeId(..), ContextId, MasterCorpusId, NodeType(NodeDocument), UserCorpusId, DocId)
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
import Gargantext.Database.Query.Table.Ngrams (selectNgramsId)
import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..), NgramsId)
import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..))
import Gargantext.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as Map
......@@ -107,48 +105,42 @@ getOccByNgramsOnlyFast_withSample cId int nt ngs =
HM.fromListWith (+) <$> selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt ngs
getOccByNgramsOnlyFast' :: CorpusId
getOccByNgramsOnlyFast :: CorpusId
-> ListId
-> NgramsType
-> [NgramsTerm]
-> Cmd err (HashMap NgramsTerm Int)
getOccByNgramsOnlyFast' cId lId nt tms = do -- trace (show (cId, lId)) $
mapNgramsIds <- selectNgramsId $ map unNgramsTerm tms
HM.fromListWith (+) <$> catMaybes
<$> map (\(nId, s) -> (,) <$> (NgramsTerm <$> (Map.lookup nId mapNgramsIds)) <*> (Just $ round s) )
<$> run cId lId nt (Map.keys mapNgramsIds)
getOccByNgramsOnlyFast cId lId nt = do
HM.fromList <$> map (\(t,n) -> (NgramsTerm t, round n)) <$> run cId lId nt
where
run :: CorpusId
-> ListId
-> NgramsType
-> [NgramsId]
-> Cmd err [(NgramsId, Double)]
run cId' lId' nt' tms' = runPGSQuery query
( Values fields ((DPS.Only) <$> tms')
, cId'
-> Cmd err [(Text, Double)]
run cId' lId' nt' = runPGSQuery query
( cId'
, lId'
, ngramsTypeId nt'
)
fields = [QualifiedIdentifier Nothing "int4"]
query :: DPS.Query
query = [sql|
WITH input_ngrams(id) AS (?)
SELECT ngi.id, nng.weight FROM nodes_contexts nc
JOIN node_node_ngrams nng ON nng.node1_id = nc.node_id
JOIN input_ngrams ngi ON nng.ngrams_id = ngi.id
WHERE nng.node1_id = ?
AND nng.node2_id = ?
AND nng.ngrams_type = ?
AND nc.category > 0
GROUP BY ngi.id, nng.weight
SELECT ng.terms
-- , ng.id
, round(nng.weight)
-- , ns.version
-- , nng.ngrams_type
-- , ns.ngrams_type_id
FROM ngrams ng
JOIN node_stories ns ON ng.id = ns.ngrams_id
JOIN node_node_ngrams nng ON ns.node_id = nng.node2_id
WHERE nng.node1_id = ?
AND nng.node2_id = ?
AND nng.ngrams_type = ?
AND nng.ngrams_id = ng.id
AND nng.ngrams_type = ns.ngrams_type_id
ORDER BY ng.id ASC;
|]
selectNgramsOccurrencesOnlyByContextUser_withSample :: HasDBid NodeType
......@@ -188,6 +180,43 @@ queryNgramsOccurrencesOnlyByContextUser_withSample = [sql|
GROUP BY cng.node_id, ng.terms
|]
selectNgramsOccurrencesOnlyByContextUser_withSample' :: HasDBid NodeType
=> CorpusId
-> Int
-> NgramsType
-> Cmd err [(NgramsTerm, Int)]
selectNgramsOccurrencesOnlyByContextUser_withSample' cId int nt =
fmap (first NgramsTerm) <$>
runPGSQuery queryNgramsOccurrencesOnlyByContextUser_withSample
( int
, toDBid NodeDocument
, cId
, cId
, ngramsTypeId nt
)
queryNgramsOccurrencesOnlyByContextUser_withSample' :: DPS.Query
queryNgramsOccurrencesOnlyByContextUser_withSample' = [sql|
WITH contexts_sample AS (SELECT c.id FROM contexts c TABLESAMPLE SYSTEM_ROWS (?)
JOIN nodes_contexts nc ON c.id = nc.context_id
WHERE c.typename = ?
AND nc.node_id = ?)
SELECT ng.terms, COUNT(cng.context_id) FROM context_node_ngrams cng
JOIN ngrams ng ON cng.ngrams_id = ng.id
JOIN node_stories ns ON ns.ngrams_id = ng.id
JOIN nodes_contexts nc ON nc.context_id = cng.context_id
JOIN contexts_sample c ON nc.context_id = c.id
WHERE nc.node_id = ? -- CorpusId
AND cng.ngrams_type = ? -- NgramsTypeId
AND nc.category > 0
GROUP BY ng.id
|]
------------------------------------------------------------------------
getContextsByNgramsOnlyUser :: HasDBid NodeType
......
src/Gargantext/Database/Query/Facet.hs
View file @ b7c7b416
......@@ -301,26 +301,28 @@ runViewDocuments :: HasDBid NodeType
-> Maybe Limit
-> Maybe OrderBy
-> Maybe Text
-> Maybe Text
-> Cmd err [FacetDoc]
runViewDocuments cId t o l order query = do
runViewDocuments cId t o l order query year = do
printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
runOpaQuery $ filterWith o l order sqlQuery
where
sqlQuery = viewDocuments cId t (toDBid NodeDocument) query
sqlQuery = viewDocuments cId t (toDBid NodeDocument) query year
runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Cmd err Int
runCountDocuments cId t mQuery = do
runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Maybe Text -> Cmd err Int
runCountDocuments cId t mQuery mYear = do
runCountOpaQuery sqlQuery
where
sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery
sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery mYear
viewDocuments :: CorpusId
-> IsTrash
-> NodeTypeId
-> Maybe Text
-> Maybe Text
-> Select FacetDocRead
viewDocuments cId t ntId mQuery = viewDocumentsQuery cId t ntId mQuery >>> proc (c, nc) -> do
viewDocuments cId t ntId mQuery mYear = viewDocumentsQuery cId t ntId mQuery mYear >>> proc (c, nc) -> do
returnA -< FacetDoc { facetDoc_id = _cs_id c
, facetDoc_created = _cs_date c
, facetDoc_title = _cs_name c
......@@ -334,8 +336,9 @@ viewDocumentsQuery :: CorpusId
-> IsTrash
-> NodeTypeId
-> Maybe Text
-> Maybe Text
-> Select (ContextSearchRead, NodeContextRead)
viewDocumentsQuery cId t ntId mQuery = proc () -> do
viewDocumentsQuery cId t ntId mQuery mYear = proc () -> do
c <- queryContextSearchTable -< ()
nc <- queryNodeContextTable -< ()
restrict -< c^.cs_id .== nc^.nc_context_id
......@@ -346,14 +349,20 @@ viewDocumentsQuery cId t ntId mQuery = proc () -> do
let
query = (fromMaybe "" mQuery)
year = (fromMaybe "" mYear)
iLikeQuery = T.intercalate "" ["%", query, "%"]
abstractLHS h = fromNullable (sqlStrictText "")
$ toNullable h .->> (sqlStrictText "abstract")
yearLHS h = fromNullable (sqlStrictText "")
$ toNullable h .->> (sqlStrictText "publication_year")
restrict -<
if query == "" then sqlBool True
else ((c^.cs_name) `ilike` (sqlStrictText iLikeQuery))
.|| ((abstractLHS (c^.cs_hyperdata)) `ilike` (sqlStrictText iLikeQuery))
restrict -<
if year == "" then sqlBool True
else (yearLHS (c^.cs_hyperdata)) .== (sqlStrictText year)
returnA -< (c, nc)
......
src/Gargantext/Database/Schema/Ngrams.hs
View file @ b7c7b416
......@@ -23,20 +23,21 @@ module Gargantext.Database.Schema.Ngrams
import Codec.Serialise (Serialise())
import Control.Lens (over)
import Control.Monad (mzero)
import Data.Maybe (fromMaybe)
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Data.Aeson
import Data.Aeson.Types (toJSONKeyText)
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Data.Map (fromList, lookup)
import Database.PostgreSQL.Simple.FromField (returnError, ResultError(..))
import Data.Maybe (fromMaybe)
import Data.Text (Text, splitOn, pack, strip)
import Database.PostgreSQL.Simple.FromField (returnError, ResultError(..))
import Gargantext.Core (HasDBid(..))
import Gargantext.Core.Types (TODO(..), Typed(..))
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Types
import Gargantext.Prelude
import Servant (FromHttpApiData(..), Proxy(..), ToHttpApiData(..))
import Gargantext.Core (HasDBid(..))
import Gargantext.Database.Types
import Gargantext.Database.Schema.Prelude
import Test.QuickCheck (elements)
import Text.Read (read)
import qualified Data.ByteString.Char8 as B
import qualified Data.HashMap.Strict as HashMap
......@@ -84,11 +85,26 @@ ngramsTable = Table "ngrams" (pNgramsDb NgramsDB { _ngrams_id = optionalTable
-- ngrams in text fields of documents has Terms Type (i.e. either title or abstract)
data NgramsType = Authors | Institutes | Sources | NgramsTerms
deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
instance Serialise NgramsType
instance FromJSON NgramsType
where
parseJSON (String "Authors") = pure Authors
parseJSON (String "Institutes") = pure Institutes
parseJSON (String "Sources") = pure Sources
parseJSON (String "Terms") = pure NgramsTerms
parseJSON _ = mzero
instance FromJSONKey NgramsType where
fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
instance ToJSON NgramsType
where
toJSON Authors = String "Authors"
toJSON Institutes = String "Institutes"
toJSON Sources = String "Sources"
toJSON NgramsTerms = String "Terms"
instance ToJSONKey NgramsType where
toJSONKey = toJSONKeyText (pack . show)
instance FromHttpApiData NgramsType where
......@@ -97,6 +113,9 @@ instance ToHttpApiData NgramsType where
toUrlPiece = pack . show
instance ToParamSchema NgramsType where
toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
instance Arbitrary NgramsType where
arbitrary = elements [ minBound .. maxBound ]
-- map NgramsType to its assigned id
instance FromField NgramsType where
fromField fld mdata =
......
src/Gargantext/Utils/Jobs.hs 0 → 100644
View file @ b7c7b416
module Gargantext.Utils.Jobs where
import Control.Monad.Except
import Control.Monad.Reader
import Prelude
import System.Directory (doesFileExist)
import Text.Read (readMaybe)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Orchestrator.Types (JobLog)
import Gargantext.API.Prelude
import qualified Gargantext.Utils.Jobs.API as API
import Gargantext.Utils.Jobs.Map
import Gargantext.Utils.Jobs.Monad
import qualified Servant.Job.Async as SJ
jobErrorToGargError
:: JobError -> GargError
jobErrorToGargError = GargJobError
serveJobsAPI
:: Foldable callbacks
=> GargJob
-> (input -> Logger JobLog -> GargM Env GargError JobLog)
-> JobsServerAPI ctI ctO callbacks input
serveJobsAPI t f = API.serveJobsAPI ask t jobErrorToGargError $ \env i l -> do
putStrLn ("Running job of type: " ++ show t)
runExceptT $ runReaderT (f i l) env
type JobsServerAPI ctI ctO callbacks input =
SJ.AsyncJobsServerT' ctI ctO callbacks JobLog input JobLog
(GargM Env GargError)
parseGargJob :: String -> Maybe GargJob
parseGargJob s = case s of
"tablengrams" -> Just TableNgramsJob
"forgotpassword" -> Just ForgotPasswordJob
"updatengramslistjson" -> Just UpdateNgramsListJobJSON
"updatengramslistcsv" -> Just UpdateNgramsListJobCSV
"addcontact" -> Just AddContactJob
"addfile" -> Just AddFileJob
"documentfromwritenode" -> Just DocumentFromWriteNodeJob
"updatenode" -> Just UpdateNodeJob
"updateframecalc" -> Just UploadFrameCalcJob
"updatedocument" -> Just UploadDocumentJob
"newnode" -> Just NewNodeJob
"addcorpusquery" -> Just AddCorpusQueryJob
"addcorpusform" -> Just AddCorpusFormJob
"addcorpusfile" -> Just AddCorpusFileJob
"addannuaireform" -> Just AddAnnuaireFormJob
"recomputegraph" -> Just RecomputeGraphJob
_ -> Nothing
parsePrios :: [String] -> IO [(GargJob, Int)]
parsePrios [] = return []
parsePrios (x : xs) = (:) <$> go x <*> parsePrios xs
where go s = case break (=='=') s of
([], _) -> error "parsePrios: empty jobname?"
(prop, valS)
| Just val <- readMaybe (tail valS)
, Just j <- parseGargJob prop -> return (j, val)
| otherwise -> error $
"parsePrios: invalid input. " ++ show (prop, valS)
readPrios :: FilePath -> IO [(GargJob, Int)]
readPrios fp = do
exists <- doesFileExist fp
case exists of
False -> do
putStrLn $
"Warning: " ++ fp ++ " doesn't exist, using default job priorities."
return []
True -> parsePrios . lines =<< readFile fp
src/Gargantext/Utils/Jobs/API.hs 0 → 100644
View file @ b7c7b416
{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
module Gargantext.Utils.Jobs.API where
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception
import Control.Lens
import Control.Monad
import Control.Monad.Except
import Data.Aeson (ToJSON)
import Data.Monoid
import Data.Kind (Type)
import Prelude
import Servant.API
import Gargantext.Utils.Jobs.Map
import Gargantext.Utils.Jobs.Monad
import qualified Data.Text as T
import qualified Servant.Client as C
import qualified Servant.Job.Async as SJ
import qualified Servant.Job.Client as SJ
import qualified Servant.Job.Types as SJ
serveJobsAPI
:: ( Ord t, Exception e, MonadError e m
, MonadJob m t (Dual [event]) output
, ToJSON e, ToJSON event, ToJSON output
, Foldable callback
)
=> m env
-> t
-> (JobError -> e)
-> (env -> input -> Logger event -> IO (Either e output))
-> SJ.AsyncJobsServerT' ctI ctO callback event input output m
serveJobsAPI getenv t joberr f
= newJob getenv t f (SJ.JobInput undefined Nothing)
:<|> newJob getenv t f
:<|> serveJobAPI t joberr
serveJobAPI
:: forall (m :: Type -> Type) e t event output.
(Ord t, MonadError e m, MonadJob m t (Dual [event]) output)
=> t
-> (JobError -> e)
-> SJ.JobID 'SJ.Unsafe
-> SJ.AsyncJobServerT event output m
serveJobAPI t joberr jid' = wrap' (killJob t)
:<|> wrap' pollJob
:<|> wrap (waitJob joberr)
where wrap
:: forall a.
(SJ.JobID 'SJ.Safe -> JobEntry (SJ.JobID 'SJ.Safe) (Dual [event]) output -> m a)
-> m a
wrap g = do
jid <- handleIDError joberr (checkJID jid')
job <- maybe (throwError $ joberr UnknownJob) pure =<< findJob jid
g jid job
wrap' g limit offset = wrap (g limit offset)
newJob
:: ( Ord t, Exception e, MonadJob m t (Dual [event]) output
, ToJSON e, ToJSON event, ToJSON output
, Foldable callbacks
)
=> m env
-> t
-> (env -> input -> Logger event -> IO (Either e output))
-> SJ.JobInput callbacks input
-> m (SJ.JobStatus 'SJ.Safe event)
newJob getenv jobkind f input = do
je <- getJobEnv
env <- getenv
let postCallback m = forM_ (input ^. SJ.job_callback) $ \url ->
C.runClientM (SJ.clientMCallback m)
(C.mkClientEnv (jeManager je) (url ^. SJ.base_url))
pushLog logF e = do
postCallback (SJ.mkChanEvent e)
logF e
f' inp logF = do
r <- f env inp (pushLog logF . Dual . (:[]))
case r of
Left e -> postCallback (SJ.mkChanError e) >> throwIO e
Right a -> postCallback (SJ.mkChanResult a) >> return a
jid <- queueJob jobkind (input ^. SJ.job_input) f'
return (SJ.JobStatus jid [] SJ.IsPending Nothing)
pollJob
:: MonadJob m t (Dual [event]) output
=> Maybe SJ.Limit
-> Maybe SJ.Offset
-> SJ.JobID 'SJ.Safe
-> JobEntry (SJ.JobID 'SJ.Safe) (Dual [event]) output
-> m (SJ.JobStatus 'SJ.Safe event)
pollJob limit offset jid je = do
(Dual logs, status, merr) <- case jTask je of
QueuedJ _ -> pure (mempty, SJ.IsPending, Nothing)
RunningJ rj -> (,,) <$> liftIO (rjGetLog rj)
<*> pure SJ.IsRunning
<*> pure Nothing
DoneJ ls r ->
let st = either (const SJ.IsFailure) (const SJ.IsFinished) r
me = either (Just . T.pack . show) (const Nothing) r
in pure (ls, st, me)
pure $ SJ.jobStatus jid limit offset logs status merr
waitJob
:: (MonadError e m, MonadJob m t (Dual [event]) output)
=> (JobError -> e)
-> SJ.JobID 'SJ.Safe
-> JobEntry (SJ.JobID 'SJ.Safe) (Dual [event]) output
-> m (SJ.JobOutput output)
waitJob joberr jid je = do
r <- case jTask je of
QueuedJ _qj -> do
m <- getJobsMap
erj <- waitTilRunning
case erj of
Left res -> return res
Right rj -> do
(res, _logs) <- liftIO (waitJobDone jid rj m)
return res
RunningJ rj -> do
m <- getJobsMap
(res, _logs) <- liftIO (waitJobDone jid rj m)
return res
DoneJ _ls res -> return res
either (throwError . joberr . JobException) (pure . SJ.JobOutput) r
where waitTilRunning =
findJob jid >>= \mjob -> case mjob of
Nothing -> error "impossible"
Just je' -> case jTask je' of
QueuedJ _qj -> do
liftIO $ threadDelay 50000 -- wait 50ms
waitTilRunning
RunningJ rj -> return (Right rj)
DoneJ _ls res -> return (Left res)
killJob
:: (Ord t, MonadJob m t (Dual [event]) output)
=> t
-> Maybe SJ.Limit
-> Maybe SJ.Offset
-> SJ.JobID 'SJ.Safe
-> JobEntry (SJ.JobID 'SJ.Safe) (Dual [event]) output
-> m (SJ.JobStatus 'SJ.Safe event)
killJob t limit offset jid je = do
(Dual logs, status, merr) <- case jTask je of
QueuedJ _ -> do
removeJob True t jid
return (mempty, SJ.IsKilled, Nothing)
RunningJ rj -> do
liftIO $ cancel (rjAsync rj)
lgs <- liftIO (rjGetLog rj)
removeJob False t jid
return (lgs, SJ.IsKilled, Nothing)
DoneJ lgs r -> do
let st = either (const SJ.IsFailure) (const SJ.IsFinished) r
me = either (Just . T.pack . show) (const Nothing) r
removeJob False t jid
pure (lgs, st, me)
pure $ SJ.jobStatus jid limit offset logs status merr
src/Gargantext/Utils/Jobs/Map.hs 0 → 100644
View file @ b7c7b416
{-# LANGUAGE GADTs #-}
module Gargantext.Utils.Jobs.Map where
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Map (Map)
import Data.Time.Clock
import Prelude
import qualified Data.Map as Map
import Gargantext.Utils.Jobs.Settings
-- | (Mutable) 'Map' containing job id -> job info mapping.
newtype JobMap jid w a = JobMap
{ jobMap :: TVar (Map jid (JobEntry jid w a))
}
-- | Information associated to a job ID
data JobEntry jid w a = JobEntry
{ jID :: jid
, jTask :: J w a
, jTimeoutAfter :: Maybe UTCTime
, jRegistered :: UTCTime
, jStarted :: Maybe UTCTime
, jEnded :: Maybe UTCTime
}
-- | A job computation, which has a different representation depending on the
-- status of the job.
--
-- A queued job consists of the input to the computation and the computation.
-- A running job consists of an 'Async' as well as an action to get the current logs.
-- A done job consists of the result of the computation and the final logs.
data J w a
= QueuedJ (QueuedJob w a)
| RunningJ (RunningJob w a)
| DoneJ w (Either SomeException a)
-- | An unexecuted job is an input paired with a computation
-- to run with it. Input type is "hidden" to
-- be able to store different job types together.
data QueuedJob w r where
QueuedJob :: a -> (a -> Logger w -> IO r) -> QueuedJob w r
-- | A running job points to the async computation for the job and provides a
-- function to peek at the current logs.
data RunningJob w a = RunningJob
{ rjAsync :: Async a
, rjGetLog :: IO w
}
-- | A @'Logger' w@ is a function that can do something with "messages" of type
-- @w@ in IO.
type Logger w = w -> IO ()
newJobMap :: IO (JobMap jid w a)
newJobMap = JobMap <$> newTVarIO Map.empty
-- | Lookup a job by ID
lookupJob
:: Ord jid
=> jid
-> JobMap jid w a
-> IO (Maybe (JobEntry jid w a))
lookupJob jid (JobMap mvar) = Map.lookup jid <$> readTVarIO mvar
-- | Ready to use GC thread
gcThread :: Ord jid => JobSettings -> JobMap jid w a -> IO ()
gcThread js (JobMap mvar) = go
where go = do
now <- getCurrentTime
candidateEntries <- Map.filter (expired now) <$> readTVarIO mvar
forM_ candidateEntries $ \je -> do
mrunningjob <- atomically $ do
case jTask je of
RunningJ rj -> modifyTVar' mvar (Map.delete (jID je))
>> return (Just rj)
_ -> return Nothing
case mrunningjob of
Nothing -> return ()
Just a -> killJ a
threadDelay (jsGcPeriod js * 1000000)
go
expired now jobentry = case jTimeoutAfter jobentry of
Just t -> now >= t
_ -> False
-- | Make a 'Logger' that 'mappend's monoidal values in a 'TVar'.
jobLog :: Semigroup w => TVar w -> Logger w -- w -> IO ()
jobLog logvar = \w -> atomically $ modifyTVar' logvar (\old_w -> old_w <> w)
-- | Generating new 'JobEntry's.
addJobEntry
:: Ord jid
=> jid
-> a
-> (a -> Logger w -> IO r)
-> JobMap jid w r
-> IO (JobEntry jid w r)
addJobEntry jid input f (JobMap mvar) = do
now <- getCurrentTime
let je = JobEntry
{ jID = jid
, jTask = QueuedJ (QueuedJob input f)
, jRegistered = now
, jTimeoutAfter = Nothing
, jStarted = Nothing
, jEnded = Nothing
}
atomically $ modifyTVar' mvar (Map.insert jid je)
return je
deleteJob :: Ord jid => jid -> JobMap jid w a -> STM ()
deleteJob jid (JobMap mvar) = modifyTVar' mvar (Map.delete jid)
runJob
:: (Ord jid, Monoid w)
=> jid
-> QueuedJob w a
-> JobMap jid w a
-> JobSettings
-> IO (RunningJob w a)
runJob jid qj (JobMap mvar) js = do
rj <- runJ qj
now <- getCurrentTime
atomically $ modifyTVar' mvar $
flip Map.adjust jid $ \je ->
je { jTask = RunningJ rj
, jStarted = Just now
, jTimeoutAfter = Just $ addUTCTime (fromIntegral (jsJobTimeout js)) now
}
return rj
waitJobDone
:: Ord jid
=> jid
-> RunningJob w a
-> JobMap jid w a
-> IO (Either SomeException a, w)
waitJobDone jid rj (JobMap mvar) = do
r <- waitJ rj
now <- getCurrentTime
logs <- rjGetLog rj
atomically $ modifyTVar' mvar $
flip Map.adjust jid $ \je ->
je { jEnded = Just now, jTask = DoneJ logs r }
return (r, logs)
-- | Turn a queued job into a running job by setting up the logging of @w@s and
-- firing up the async action.
runJ :: Monoid w => QueuedJob w a -> IO (RunningJob w a)
runJ (QueuedJob a f) = do
logs <- newTVarIO mempty
act <- async $ f a (jobLog logs)
let readLogs = readTVarIO logs
return (RunningJob act readLogs)
-- | Wait for a running job to return (blocking).
waitJ :: RunningJob w a -> IO (Either SomeException a)
waitJ (RunningJob act _) = waitCatch act
-- | Poll a running job to see if it's done.
pollJ :: RunningJob w a -> IO (Maybe (Either SomeException a))
pollJ (RunningJob act _) = poll act
-- | Kill a running job by cancelling the action.
killJ :: RunningJob w a -> IO ()
killJ (RunningJob act _) = cancel act
src/Gargantext/Utils/Jobs/Monad.hs 0 → 100644
View file @ b7c7b416
{-# LANGUAGE MultiWayIf, FunctionalDependencies, MultiParamTypeClasses #-}
module Gargantext.Utils.Jobs.Monad where
import Gargantext.Utils.Jobs.Settings
import Gargantext.Utils.Jobs.Map
import Gargantext.Utils.Jobs.Queue
import Gargantext.Utils.Jobs.State
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Except
import Data.Map (Map)
import Data.Time.Clock
import Network.HTTP.Client (Manager)
import Prelude
import qualified Servant.Job.Core as SJ
import qualified Servant.Job.Types as SJ
data JobEnv t w a = JobEnv
{ jeSettings :: JobSettings
, jeState :: JobsState t w a
, jeManager :: Manager
}
newJobEnv
:: (EnumBounded t, Monoid w)
=> JobSettings
-> Map t Prio
-> Manager
-> IO (JobEnv t w a)
newJobEnv js prios mgr = JobEnv js <$> newJobsState js prios <*> pure mgr
type NumRunners = Int
defaultJobSettings :: NumRunners -> SJ.SecretKey -> JobSettings
defaultJobSettings numRunners k = JobSettings
{ jsNumRunners = numRunners
, jsJobTimeout = 30 * 60 -- 30 minutes
, jsIDTimeout = 30 * 60 -- 30 minutes
, jsGcPeriod = 1 * 60 -- 1 minute
, jsSecretKey = k
}
genSecret :: IO SJ.SecretKey
genSecret = SJ.generateSecretKey
class MonadIO m => MonadJob m t w a | m -> t w a where
getJobEnv :: m (JobEnv t w a)
getJobsSettings :: MonadJob m t w a => m JobSettings
getJobsSettings = jeSettings <$> getJobEnv
getJobsState :: MonadJob m t w a => m (JobsState t w a)
getJobsState = jeState <$> getJobEnv
getJobsMap :: MonadJob m t w a => m (JobMap (SJ.JobID 'SJ.Safe) w a)
getJobsMap = jobsData <$> getJobsState
getJobsQueue :: MonadJob m t w a => m (Queue t (SJ.JobID 'SJ.Safe))
getJobsQueue = jobsQ <$> getJobsState
queueJob
:: (MonadJob m t w a, Ord t)
=> t
-> i
-> (i -> Logger w -> IO a)
-> m (SJ.JobID 'SJ.Safe)
queueJob jobkind input f = do
js <- getJobsSettings
st <- getJobsState
liftIO (pushJob jobkind input f js st)
findJob
:: MonadJob m t w a
=> SJ.JobID 'SJ.Safe
-> m (Maybe (JobEntry (SJ.JobID 'SJ.Safe) w a))
findJob jid = do
jmap <- getJobsMap
liftIO $ lookupJob jid jmap
data JobError
= InvalidIDType
| IDExpired
| InvalidMacID
| UnknownJob
| JobException SomeException
deriving Show
checkJID
:: MonadJob m t w a
=> SJ.JobID 'SJ.Unsafe
-> m (Either JobError (SJ.JobID 'SJ.Safe))
checkJID (SJ.PrivateID tn n t d) = do
now <- liftIO getCurrentTime
js <- getJobsSettings
if | tn /= "job" -> return (Left InvalidIDType)
| now > addUTCTime (fromIntegral $ jsIDTimeout js) t -> return (Left IDExpired)
| d /= SJ.macID tn (jsSecretKey js) t n -> return (Left InvalidMacID)
| otherwise -> return $ Right (SJ.PrivateID tn n t d)
withJob
:: MonadJob m t w a
=> SJ.JobID 'SJ.Unsafe
-> (SJ.JobID 'SJ.Safe -> JobEntry (SJ.JobID 'SJ.Safe) w a -> m r)
-> m (Either JobError (Maybe r))
withJob jid f = do
r <- checkJID jid
case r of
Left e -> return (Left e)
Right jid' -> do
mj <- findJob jid'
case mj of
Nothing -> return (Right Nothing)
Just j -> Right . Just <$> f jid' j
handleIDError
:: MonadError e m
=> (JobError -> e)
-> m (Either JobError a)
-> m a
handleIDError toE act = act >>= \r -> case r of
Left err -> throwError (toE err)
Right a -> return a
removeJob
:: (Ord t, MonadJob m t w a)
=> Bool -- is it queued (and we have to remove jid from queue)
-> t
-> SJ.JobID 'SJ.Safe
-> m ()
removeJob queued t jid = do
q <- getJobsQueue
m <- getJobsMap
liftIO . atomically $ do
when queued $
deleteQueue t jid q
deleteJob jid m
src/Gargantext/Utils/Jobs/Queue.hs 0 → 100644
View file @ b7c7b416
{-# LANGUAGE ConstraintKinds, TypeFamilies, ScopedTypeVariables #-}
module Gargantext.Utils.Jobs.Queue where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Data.Function
import Data.List
import Data.Ord
import Data.Maybe
import Prelude
import System.IO
import qualified Data.Map as Map
import qualified Data.Vector as Vector
type EnumBounded t = (Ord t, Enum t, Bounded t)
data Q a = Q [a] [a] !Int
emptyQ :: Q a
emptyQ = Q [] [] 0
singletonQ :: a -> Q a
singletonQ a = Q [a] [] 1
snocQ :: a -> Q a -> Q a
snocQ a (Q xs ys sz) = Q xs (a:ys) (sz+1)
normalizeQ :: Q a -> Q a
normalizeQ (Q [] ys sz) = Q (reverse ys) [] sz
normalizeQ q = q
deleteQ :: Eq a => a -> Q a -> Q a
deleteQ x (Q xs ys sz) = Q xs' ys' sz'
where (xs_num_x, xs') = go xs (0, [])
(ys_num_x, ys') = go ys (0, [])
sz' = sz - xs_num_x - ys_num_x
go [] (n, bs) = (n, reverse bs)
go (a:as) (n, bs)
| a == x = go as (n+1, bs)
| otherwise = go as (n, a:bs)
popQ :: Q a -> Maybe (a, Q a)
popQ q@(Q as bs sz) = case as of
x:xs -> Just (x, Q xs bs (sz-1))
_ -> case normalizeQ q of
Q (x:xs) ys sz' -> Just (x, Q xs ys (sz'-1))
_ -> Nothing
sizeQ :: Q a -> Int
sizeQ (Q _ _ sz) = sz
peekQ :: Q a -> Maybe a
peekQ (Q _ _ 0) = Nothing
peekQ q = case normalizeQ q of
Q (x:_) _ _ -> Just x
_ -> Nothing
dropQ :: Q a -> Q a
dropQ (Q [] [] _) = Q [] [] 0
dropQ (Q (_x:xs) ys sz) = Q xs ys (sz-1)
dropQ q@(Q [] _ _) = dropQ (normalizeQ q)
-- | A priority is just a number. The greater, the earlier the job will get picked.
type Prio = Int
applyPrios
:: Ord t
=> [(t, Prio)] -> Map.Map t Prio -> Map.Map t Prio
applyPrios changes prios = foldl' (\m (t, p) -> Map.insert t p m) prios changes
-- | A queue with different kinds of values, described by @t@, where each
-- kind can have a higher or lower priority than other kinds, as described
-- by the 'queuePrios' field.
data Queue t a = Queue
{ queueData :: Vector.Vector (TVar (Q a))
, queueIndices :: Map.Map t Int -- indices into queueData
, queuePrios :: Map.Map t Prio
}
-- | Default priorities for the enumeration of job types @t@: everyone at 0.
defaultPrios :: EnumBounded t => Map.Map t Prio
defaultPrios = Map.fromList [ (t, 0) | t <- [minBound..maxBound] ]
-- | Create a new queue that'll apply the given priorities
newQueue :: EnumBounded t => Map.Map t Prio -> IO (Queue t a)
newQueue prios = do
let allTs = [ minBound .. maxBound ]
indices = Map.fromList (zip allTs [0..])
n = Map.size indices
vars <- Vector.replicateM n (newTVarIO emptyQ)
return $ Queue vars indices prios
-- | Add a new element to the queue, with the given kind.
addQueue :: Ord t => t -> a -> Queue t a -> IO ()
addQueue jobkind a q = case Map.lookup jobkind (queueIndices q) of
Just i -> atomically $ modifyTVar (queueData q Vector.! i) (snocQ a)
Nothing -> error "addQueue: couldn't find queue for given job kind"
deleteQueue :: (Eq a, Ord t) => t -> a -> Queue t a -> STM ()
deleteQueue jobkind a q = case Map.lookup jobkind (queueIndices q) of
Just i -> modifyTVar (queueData q Vector.! i) (deleteQ a)
Nothing -> error "deleteQueue: queue type not found?!"
type Picker a = [(a, STM ())] -> STM (a, STM ())
-- | Figure out the candidates for being popped from the various queues.
-- We always look at highest priority queues first, and will pick between
-- equal priority items of different queues (candidates, elements of the
-- returned lists) by choosing the one that was queued first.
popQueue :: forall a t. Ord t => Picker a -> Queue t a -> IO (Maybe a)
popQueue picker q = atomically $ select prioLevels
where -- TODO: cache this in the 'Queue' data structure?
prioLevels :: [[(t, Prio)]]
prioLevels = groupBy ((==) `on` snd) . sortOn (Down . snd) $
Map.toList (queuePrios q)
select :: [[(t, Prio)]] -> STM (Maybe a)
select [] = return Nothing
select (level:levels) = do
mres <- selectLevel level
case mres of
Nothing -> select levels
Just res -> return (Just res)
selectLevel :: [(t, Prio)] -> STM (Maybe a)
selectLevel xs = do
let indices = catMaybes $ map (flip Map.lookup (queueIndices q) . fst) xs
queues = map (queueData q Vector.!) indices
go qvar = readTVar qvar >>= \qu ->
return (peekQ qu, modifyTVar' qvar dropQ)
mtopItems <- catMaybesFst <$> traverse go queues
case mtopItems of
Nothing -> return Nothing
Just [] -> return Nothing
Just topItems -> do
(earliestItem, popItem) <- picker topItems
popItem
return (Just earliestItem)
catMaybesFst ((Nothing, _b) : xs) = catMaybesFst xs
catMaybesFst ((Just a, b) : xs) = ((a, b) :) <$> catMaybesFst xs
catMaybesFst [] = Just []
-- | A ready-to-use runner that pops the highest priority item off the queue
-- and processes it using the given function.
queueRunner :: Ord t => Picker a -> (a -> IO ()) -> Queue t a -> IO ()
queueRunner picker f q = go
where go = do
mres <- popQueue picker q
case mres of
Just a -> f a `catch` exc
Nothing -> return ()
threadDelay 5000 -- 5ms
go
exc :: SomeException -> IO ()
exc e = hPutStrLn stderr ("Queue runner exception: " ++ show e)
-- | Create a queue and @n@ runner actions for it, with the given priorities
-- for the runners to apply when picking a new item.
newQueueWithRunners
:: EnumBounded t
=> Int -- ^ number of runners
-> Map.Map t Prio -- ^ priorities
-> Picker a -- ^ how to pick between equal priority items
-> (a -> IO ()) -- ^ what to do with each item
-> IO (Queue t a, [IO ()])
newQueueWithRunners n prios picker f = do
q <- newQueue prios
let runners = replicate n (queueRunner picker f q)
return (q, runners)
src/Gargantext/Utils/Jobs/Settings.hs 0 → 100644
View file @ b7c7b416
module Gargantext.Utils.Jobs.Settings where
import Prelude
import qualified Servant.Job.Core as SJ
-- | A few control knobs for the job system.
data JobSettings = JobSettings
{ jsNumRunners :: Int
, jsJobTimeout :: Int -- in seconds. TODO: timeout per job type? Map t Int
, jsIDTimeout :: Int -- in seconds, how long a job ID is valid
, jsGcPeriod :: Int -- in seconds, how long between each GC
, jsSecretKey :: SJ.SecretKey
}
src/Gargantext/Utils/Jobs/State.hs 0 → 100644
View file @ b7c7b416
module Gargantext.Utils.Jobs.State where
import Gargantext.Utils.Jobs.Map
import Gargantext.Utils.Jobs.Queue
import Gargantext.Utils.Jobs.Settings
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import Data.List
import Data.Map (Map)
import Data.Maybe
import Data.Ord
import Data.Proxy
import Data.Time.Clock
import Prelude
import qualified Data.Map as Map
import qualified Servant.Job.Core as SJ
import qualified Servant.Job.Types as SJ
type IDGenerator = TVar Int
data JobsState t w a = JobsState
{ jobsData :: JobMap (SJ.JobID 'SJ.Safe) w a
, jobsQ :: Queue t (SJ.JobID 'SJ.Safe)
, jobsIdGen :: IDGenerator
, jsGC :: Async ()
, jsRunners :: [Async ()]
}
nextID :: JobSettings -> JobsState t w a -> IO (SJ.JobID 'SJ.Safe)
nextID js st = do
now <- getCurrentTime
n <- atomically $ stateTVar (jobsIdGen st) $ \i -> (i, i+1)
return $ SJ.newID (Proxy :: Proxy "job") (jsSecretKey js) now n
newJobsState
:: forall t w a.
(EnumBounded t, Monoid w)
=> JobSettings
-> Map t Prio
-> IO (JobsState t w a)
newJobsState js prios = do
jmap <- newJobMap
idgen <- newTVarIO 0
(q, runners) <- newQueueWithRunners (jsNumRunners js) prios (picker jmap) $ \jid -> do
mje <- lookupJob jid jmap
case mje of
Nothing -> return ()
Just je -> case jTask je of
QueuedJ qj -> do
rj <- runJob jid qj jmap js
(_res, _logs) <- waitJobDone jid rj jmap
return ()
_ -> return ()
putStrLn $ "Starting " ++ show (jsNumRunners js) ++ " job runners."
gcAsync <- async $ gcThread js jmap
runnersAsyncs <- traverse async runners
return (JobsState jmap q idgen gcAsync runnersAsyncs)
where picker
:: JobMap (SJ.JobID 'SJ.Safe) w a
-> Picker (SJ.JobID 'SJ.Safe)
picker (JobMap jmap) xs = do
jinfos <- fmap catMaybes . forM xs $ \(jid, popjid) -> do
mje <- Map.lookup jid <$> readTVar jmap
case mje of
Nothing -> return Nothing
Just je -> return $ Just (jid, popjid, jRegistered je)
let (jid, popjid, _) = minimumBy (comparing _3) jinfos
return (jid, popjid)
_3 (_, _, c) = c
pushJob
:: Ord t
=> t
-> a
-> (a -> Logger w -> IO r)
-> JobSettings
-> JobsState t w r
-> IO (SJ.JobID 'SJ.Safe)
pushJob jobkind input f js st@(JobsState jmap jqueue _idgen _ _) = do
jid <- nextID js st
_je <- addJobEntry jid input f jmap
addQueue jobkind jid jqueue
return jid
stack.yaml
View file @ b7c7b416
......@@ -33,7 +33,7 @@ ghc-options:
extra-deps:
- git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
commit: 08096a4913572cf22762fa77613340207ec6d9fd
commit: 03c3c381ba9df6da02a7a3c8d7b78cde9a380d04
- git: https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
commit: 588e104fe7593210956610cab0041fd16584a4ce
# Data Mining Libs
......@@ -85,9 +85,8 @@ extra-deps:
#- arxiv-0.0.3@sha256:02de1114091d11f1f3ab401d104d125ad4301260806feb7f63b3dcefc7db88cf,1588
# NP libs
#- git: https://github.com/np/servant-job.git # waiting for PR
- git: https://github.com/alpmestan/servant-job.git
commit: ceb251b91e8ec1804198422a3cdbdab08d843b79
commit: b4182487cfe479777c11ca19f3c0d47840b376f6
#- git: https://github.com/np/patches-map
- git: https://github.com/delanoe/patches-map
commit: 76cae88f367976ff091e661ee69a5c3126b94694
......
tests/queue/Main.hs 0 → 100644
View file @ b7c7b416
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Data.Either
import Data.List
import Prelude
import Test.Hspec
import Gargantext.Utils.Jobs.Map
import Gargantext.Utils.Jobs.Monad
import Gargantext.Utils.Jobs.Queue (applyPrios, defaultPrios)
import Gargantext.Utils.Jobs.State
data JobT = A | B deriving (Eq, Ord, Show, Enum, Bounded)
data Counts = Counts { countAs :: Int, countBs :: Int }
deriving (Eq, Show)
inc, dec :: JobT -> Counts -> Counts
inc A cs = cs { countAs = countAs cs + 1 }
inc B cs = cs { countBs = countBs cs + 1 }
dec A cs = cs { countAs = countAs cs - 1 }
dec B cs = cs { countBs = countBs cs - 1 }
jobDuration, initialDelay :: Int
jobDuration = 100000
initialDelay = 20000
testMaxRunners :: IO ()
testMaxRunners = do
-- max runners = 2 with default settings
k <- genSecret
let settings = defaultJobSettings 2 k
st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
runningJs <- newTVarIO []
let j num _inp _l = do
atomically $ modifyTVar runningJs (\xs -> ("Job #" ++ show num) : xs)
threadDelay jobDuration
atomically $ modifyTVar runningJs (\xs -> filter (/=("Job #" ++ show num)) xs)
jobs = [ j n | n <- [1..4::Int] ]
_jids <- forM jobs $ \f -> pushJob A () f settings st
threadDelay initialDelay
r1 <- readTVarIO runningJs
sort r1 `shouldBe` ["Job #1", "Job #2"]
threadDelay jobDuration
r2 <- readTVarIO runningJs
sort r2 `shouldBe` ["Job #3", "Job #4"]
threadDelay jobDuration
r3 <- readTVarIO runningJs
r3 `shouldBe` []
testPrios :: IO ()
testPrios = do
k <- genSecret
let settings = defaultJobSettings 2 k
st :: JobsState JobT [String] () <- newJobsState settings $
applyPrios [(B, 10)] defaultPrios -- B has higher priority
runningJs <- newTVarIO (Counts 0 0)
let j jobt _inp _l = do
atomically $ modifyTVar runningJs (inc jobt)
threadDelay jobDuration
atomically $ modifyTVar runningJs (dec jobt)
jobs = [ (A, j A)
, (A, j A)
, (B, j B)
, (B, j B)
]
_jids <- forM jobs $ \(t, f) -> do
pushJob t () f settings st
threadDelay initialDelay
r1 <- readTVarIO runningJs
r1 `shouldBe` (Counts 0 2)
threadDelay jobDuration
r2 <- readTVarIO runningJs
r2 `shouldBe` (Counts 2 0)
threadDelay jobDuration
r3 <- readTVarIO runningJs
r3 `shouldBe` (Counts 0 0)
testExceptions :: IO ()
testExceptions = do
k <- genSecret
let settings = defaultJobSettings 2 k
st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
jid <- pushJob A ()
(\_inp _log -> readFile "/doesntexist.txt" >>= putStrLn)
settings st
threadDelay initialDelay
mjob <- lookupJob jid (jobsData st)
case mjob of
Nothing -> error "boo"
Just je -> case jTask je of
DoneJ _ r -> isLeft r `shouldBe` True
_ -> error "boo2"
return ()
testFairness :: IO ()
testFairness = do
k <- genSecret
let settings = defaultJobSettings 2 k
st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
runningJs <- newTVarIO (Counts 0 0)
let j jobt _inp _l = do
atomically $ modifyTVar runningJs (inc jobt)
threadDelay jobDuration
atomically $ modifyTVar runningJs (dec jobt)
jobs = [ (A, j A)
, (A, j A)
, (B, j B)
, (A, j A)
, (A, j A)
]
_jids <- forM jobs $ \(t, f) -> do
pushJob t () f settings st
threadDelay initialDelay
r1 <- readTVarIO runningJs
r1 `shouldBe` (Counts 2 0)
threadDelay jobDuration
r2 <- readTVarIO runningJs
r2 `shouldBe` (Counts 1 1) -- MOST IMPORTANT CHECK: the B got picked after the
-- two As, because it was inserted right after them
-- and has equal priority.
threadDelay jobDuration
r3 <- readTVarIO runningJs
r3 `shouldBe` (Counts 1 0)
threadDelay jobDuration
r4 <- readTVarIO runningJs
r4 `shouldBe` (Counts 0 0)
main :: IO ()
main = hspec $ do
describe "job queue" $ do
it "respects max runners limit" $
testMaxRunners
it "respects priorities" $
testPrios
it "can handle exceptions" $
testExceptions
it "fairly picks equal-priority-but-different-kind jobs" $
testFairness
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