Skip to content

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

Merge branch 'dev' into 304-dev-toml-config-rewrite

parents 0d0b33f0 6d02842f
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 90 additions and 3681 deletions
CHANGELOG.md
View file @ 7056810c
## Version 0.0.7.2.5
* [BACK][CLEAN][Remove dead code (#387)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/387)
Code that could be reused later but removed since it is understood
as dead code. In fact it not used yet:
- Contact Type (for Annuaire and what we call community explorer)
- Train model to improve the Map List terms
- scrapy Orchestrator to gather data in the web
- see commit: d85b11280b36ca55857d2faaba63c0684542b1df
- some similarity confluence matrix
- see commit: d85b11280b36ca55857d2faaba63c0684542b1df
- distributional similiarity
- see commit: d85b11280b36ca55857d2faaba63c0684542b1df
- see commit: d85b11280b36ca55857d2faaba63c0684542b1df
- Telegram/Gitlab issue/Wikidata/Wikimedia parser
- see commit: d85b11280b36ca55857d2faaba63c0684542b1df
## Version 0.0.7.2.4
* [FRONT][FIX][Star on documents when reading through it (#687)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/687)
* [BACK][FEAT][[Node terms] institutes missing with HAL request (#330)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/330)
## Version 0.0.7.2.3
* [FRONT][FIX][Star on documents when reading through it (#687)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/687)
* [BACK][FIX][[Meta] Mistmatch between compound words representation in frontend and in database. (#386)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/386)
* [BACK][FIX][[API OpenAlex] Fix: adapt ngrams_url field following an API change causing an ExternalAPIError (#393)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/393)
* [BACK][FIX][Update and Improve Weeder File (#389)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/389)
## Version 0.0.7.2.2
* [BACK][FIX][Write Frame microservice proxy improvements (#364)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/364)
## Version 0.0.7.2.1
* [FRONT][DESIGN][[Graph explorer] Search and associated documents (#262)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/262)
......
bin/gargantext-cbor2json/Main.hs deleted 100644 → 0
View file @ 0d0b33f0
import Prelude (IO, id, (.))
import Data.Aeson (encode)
import Codec.Serialise (deserialise)
import qualified Data.ByteString.Lazy as L
import Gargantext.Core.NodeStory (NodeListStory)
main :: IO ()
main = L.interact (encode . (id :: NodeListStory -> NodeListStory) . deserialise)
bin/gargantext-cli/CLI/CleanCsvCorpus.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : CleanCsvCorpus.hs
Description : Gargantext starter
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Given a Gargantext CSV File and its Query This script cleans and
compress the contexts around the main terms of the query.
-}
module CLI.CleanCsvCorpus where
import Data.SearchEngine qualified as S
import Data.Set qualified as S
import Data.Text (pack)
import Data.Vector (Vector)
import Data.Vector qualified as V
import Gargantext.Core.Text.Corpus.Parsers.TSV qualified as TSV
import Gargantext.Core.Text.Search
import Gargantext.Prelude
------------------------------------------------------------------------
type Query = [S.Term]
filterDocs :: [DocId] -> Vector TSV.TsvGargV3 -> Vector TSV.TsvGargV3
filterDocs docIds = V.filter (\doc -> S.member (TSV.d_docId doc) $ S.fromList docIds )
main :: IO ()
main = do
let rPath = "/tmp/Gargantext_Corpus.csv"
let wPath = "/tmp/Gargantext_Corpus_bis.csv"
--let q = ["water", "scarcity", "morocco", "shortage","flood"]
let q = ["gratuit", "gratuité", "culture", "culturel"]
eDocs <- TSV.readTSVFile rPath
case eDocs of
Right (h, tsvDocs) -> do
putStrLn ("Number of documents before:" <> show (V.length tsvDocs) :: Text)
putStrLn ("Mean size of docs:" <> show ( TSV.docsSize tsvDocs) :: Text)
let docs = TSV.toDocs tsvDocs
let engine = S.insertDocs docs initialDocSearchEngine
let docIds = S.query engine (map pack q)
let docs' = TSV.fromDocs $ filterDocs docIds (V.fromList docs)
putStrLn ("Number of documents after:" <> show (V.length docs') :: Text)
putStrLn ("Mean size of docs:" <> show (TSV.docsSize docs') :: Text)
TSV.writeFile wPath (h, docs')
Left e -> panicTrace $ "Error: " <> e
bin/gargantext-cli/CLI/Utils.hs deleted 100644 → 0
View file @ 0d0b33f0
module CLI.Utils (
mapMP
, mapConcurrentlyChunked
) where
import Control.Concurrent.Async as CCA (mapConcurrently)
import Data.List.Split (chunksOf)
import Gargantext.Prelude
import System.IO (hFlush)
------------------------------------------------------------------------
-- | Tools
mapMP :: MonadIO m => (a -> m b) -> [a] -> m [b]
mapMP f xs = do
bs <- zipWithM g (cycle "-\\|/") xs
liftIO $ hPutStr stderr ("\rDone\n" :: Text)
pure bs
where
g c x = do
liftIO $ hPutStr stderr ['\r',c]
liftIO $ hFlush stderr
f x
-- | Optimi that need further developments (not used yet)
mapConcurrentlyChunked :: (a -> IO b) -> [a] -> IO [b]
mapConcurrentlyChunked f ts = do
caps <- getNumCapabilities
let n = 1 `max` (length ts `div` caps)
concat <$> mapConcurrently (mapM f) (chunksOf n ts)
cabal.project
View file @ 7056810c
......@@ -93,7 +93,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/hal.git
tag: d54812d52c9d1f86d331a991b3a87c9a8b4379cf
tag: 229fdf40b8ccecd527fca5a7bbb554b0deb540dc
source-repository-package
type: git
......@@ -108,7 +108,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
tag: c673924bce3283c4fb2d1b3a2f95eb3f1a9cd0b0
tag: d2df0130575cfd32d6863d77e2ce34c48a1c32fa
source-repository-package
type: git
......
cabal.project.freeze
View file @ 7056810c
......@@ -20,7 +20,6 @@ constraints: any.Cabal ==3.8.1.0,
any.SHA ==1.6.4.4,
SHA -exe,
any.StateVar ==1.2.2,
any.Unique ==0.4.7.8,
any.abstract-deque ==0.3,
abstract-deque -usecas,
any.accelerate ==1.3.0.0,
......@@ -79,7 +78,6 @@ constraints: any.Cabal ==3.8.1.0,
any.blaze-builder ==0.4.2.3,
any.blaze-html ==0.9.1.2,
any.blaze-markup ==0.8.3.0,
any.blaze-svg ==0.3.7,
any.boolexpr ==0.3,
any.boring ==0.2.1,
boring +tagged,
......@@ -131,8 +129,6 @@ constraints: any.Cabal ==3.8.1.0,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.cookie ==0.4.6,
any.cpphs ==1.20.9.1,
cpphs -old-locale,
any.cprng-aes ==0.6.1,
any.crawlerArxiv ==0.1.0.0,
any.crawlerHAL ==0.1.0.0,
......@@ -169,7 +165,6 @@ constraints: any.Cabal ==3.8.1.0,
any.deepseq ==1.4.8.0,
any.deferred-folds ==0.9.18.6,
any.dense-linear-algebra ==0.1.0.0,
any.deriving-aeson ==0.2.9,
any.digest ==0.0.1.7,
digest +pkg-config,
any.directory ==1.3.7.1,
......@@ -197,14 +192,11 @@ constraints: any.Cabal ==3.8.1.0,
any.extra ==1.7.14,
any.fail ==4.9.0.0,
any.fast-logger ==3.2.2,
any.fclabels ==2.0.5.1,
any.fgl ==5.8.0.0,
fgl +containers042,
any.file-embed ==0.0.15.0,
any.file-embed-lzma ==0.0.1,
any.filelock ==0.1.1.7,
any.filepath ==1.4.2.2,
any.filepattern ==0.1.3,
any.fmt ==0.6.3.0,
any.focus ==1.0.3.2,
any.foldable1-classes-compat ==0.1,
......@@ -226,15 +218,7 @@ constraints: any.Cabal ==3.8.1.0,
any.ghc-boot ==9.4.7,
any.ghc-boot-th ==9.4.7,
any.ghc-heap ==9.4.7,
any.ghc-lib-parser ==9.4.7.20230826,
ghc-lib-parser +threaded-rts,
any.ghc-lib-parser-ex ==9.4.0.0,
ghc-lib-parser-ex -auto -no-ghc-lib,
any.ghc-parser ==0.2.6.0,
any.ghc-paths ==0.1.0.12,
any.ghc-prim ==0.9.1,
any.ghc-syntax-highlighter ==0.0.9.0,
ghc-syntax-highlighter -dev,
any.ghci ==9.4.7,
any.githash ==0.1.7.0,
any.graphviz ==2999.20.1.0,
......@@ -248,7 +232,6 @@ constraints: any.Cabal ==3.8.1.0,
hashable +integer-gmp -random-initial-seed,
any.hashtables ==1.3.1,
hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks,
any.haskeline ==0.8.2,
any.haskell-igraph ==0.10.4,
any.haskell-lexer ==1.1.1,
any.haskell-src-exts ==1.23.1,
......@@ -257,8 +240,6 @@ constraints: any.Cabal ==3.8.1.0,
any.hedgehog ==1.2,
any.hgal ==2.0.0.2,
any.hlcm ==0.2.2,
any.hlint ==3.5,
hlint +ghc-lib +gpl -hsyaml +threaded,
any.hmatrix ==0.20.2,
hmatrix -disable-default-paths -no-random_r -openblas,
any.hmatrix-gsl-stats ==0.4.1.8,
......@@ -267,7 +248,6 @@ constraints: any.Cabal ==3.8.1.0,
any.hpc ==0.6.1.0,
any.hsc2hs ==0.68.10,
hsc2hs -in-ghc-tree,
any.hscolour ==1.24.4,
any.hsinfomap ==0.1,
any.hslogger ==1.3.1.0,
hslogger +network--gt-3_0_0,
......@@ -300,8 +280,6 @@ constraints: any.Cabal ==3.8.1.0,
any.hxt-regex-xmlschema ==9.2.0.7,
hxt-regex-xmlschema -profile,
any.hxt-unicode ==9.0.2.4,
any.ihaskell ==0.11.0.0,
ihaskell +use-hlint,
any.indexed-profunctors ==0.1.1.1,
any.indexed-traversable ==0.1.3,
any.indexed-traversable-instances ==0.1.1.2,
......@@ -313,8 +291,6 @@ constraints: any.Cabal ==3.8.1.0,
any.invariant ==0.6.2,
any.iproute ==1.7.12,
any.ipynb ==0.2,
any.ipython-kernel ==0.11.0.0,
ipython-kernel -examples,
any.iso639 ==0.1.0.3,
any.jira-wiki-markup ==1.5.1,
any.jose ==0.10,
......@@ -339,9 +315,7 @@ constraints: any.Cabal ==3.8.1.0,
any.llvm-hs ==12.0.0,
llvm-hs -debug -llvm-with-rtti +shared-llvm,
any.llvm-hs-pure ==12.0.0,
any.located-base ==0.1.1.1,
any.lockfree-queue ==0.2.4,
any.logging-effect ==1.3.12,
any.logict ==0.8.0.0,
any.loop ==0.3.0,
any.lzma ==0.0.1.0,
......@@ -377,7 +351,6 @@ constraints: any.Cabal ==3.8.1.0,
any.morpheus-graphql-core ==0.24.3,
any.morpheus-graphql-server ==0.24.3,
any.morpheus-graphql-subscriptions ==0.24.3,
any.morpheus-graphql-tests ==0.24.3,
any.mtl ==2.2.2,
any.mtl-compat ==0.2.2,
mtl-compat -two-point-one -two-point-two,
......@@ -419,10 +392,6 @@ constraints: any.Cabal ==3.8.1.0,
any.password-types ==1.0.0.0,
any.patches-class ==0.1.0.1,
any.patches-map ==0.1.0.1,
any.path ==0.9.5,
path -dev,
any.path-io ==1.8.1,
path-io -dev,
any.pem ==0.2.4,
any.polyparse ==1.13,
any.port-utils ==0.2.1.0,
......@@ -440,16 +409,12 @@ constraints: any.Cabal ==3.8.1.0,
any.primitive ==0.8.0.0,
any.primitive-extras ==0.10.1.10,
any.primitive-unlifted ==2.1.0.0,
any.probability ==0.2.8,
probability +splitbase,
any.process ==1.6.17.0,
any.product-profunctors ==0.11.1.1,
any.profunctors ==5.6.2,
any.promises ==0.3,
any.protolude ==0.3.3,
any.psqueues ==0.2.7.3,
any.pureMD5 ==2.1.4,
pureMD5 -test,
any.qrcode-core ==0.9.9,
any.qrcode-juicypixels ==0.8.5,
any.quickcheck-instances ==0.3.30,
......@@ -462,7 +427,6 @@ constraints: any.Cabal ==3.8.1.0,
any.rdf4h ==3.1.1,
any.recover-rtti ==0.4.3,
any.recv ==0.1.0,
any.refact ==0.3.0.2,
any.reflection ==2.1.7,
reflection -slow +template-haskell,
any.regex ==1.1.0.2,
......@@ -501,7 +465,6 @@ constraints: any.Cabal ==3.8.1.0,
any.servant-auth-server ==0.4.8.0,
any.servant-auth-swagger ==0.2.10.2,
any.servant-blaze ==0.9.1,
any.servant-cassava ==0.10.2,
any.servant-client ==0.19,
any.servant-client-core ==0.20,
any.servant-docs ==0.12,
......@@ -520,7 +483,6 @@ constraints: any.Cabal ==3.8.1.0,
any.servant-xml-conduit ==0.1.0.4,
any.shelly ==1.12.1,
shelly -build-examples -lifted,
any.simple-reflect ==0.3.3,
any.simple-sendfile ==0.2.32,
simple-sendfile +allow-bsd -fallback,
any.singleton-bool ==0.1.6,
......@@ -550,7 +512,6 @@ constraints: any.Cabal ==3.8.1.0,
any.stm ==2.5.1.0,
any.stm-chans ==3.0.0.9,
any.stm-containers ==1.2.0.3,
any.stm-delay ==0.1.1.1,
any.stm-hamt ==1.2.0.14,
any.storable-complex ==0.2.3.0,
any.streaming-commons ==0.2.2.6,
......@@ -608,7 +569,6 @@ constraints: any.Cabal ==3.8.1.0,
any.time-locale-compat ==0.1.1.5,
time-locale-compat -old-locale,
any.time-manager ==0.0.1,
any.timezone-series ==0.1.13,
any.tls ==1.6.0,
tls +compat -hans +network,
any.tmp-postgres ==1.34.1.0,
......@@ -690,7 +650,6 @@ constraints: any.Cabal ==3.8.1.0,
any.xml-types ==0.3.8,
any.yaml ==0.11.11.2,
yaml +no-examples +no-exe,
any.zeromq4-haskell ==0.8.0,
any.zip ==2.0.0,
zip -dev -disable-bzip2 -disable-zstd,
any.zip-archive ==0.4.3,
......
gargantext.cabal
View file @ 7056810c
This diff is collapsed.
src/Gargantext/API.hs
View file @ 7056810c
......@@ -46,13 +46,13 @@ import Data.Validity
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes (Env, Mode(..), _env_config)
import Gargantext.API.Admin.Settings (newEnv)
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microservicesSettings)
import Gargantext.API.Admin.Types (FireWall(..), MicroServicesProxyStatus(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microServicesProxyStatus)
import Gargantext.API.Middleware (logStdoutDevSanitised)
import Gargantext.API.Routes.Named (API)
import Gargantext.API.Routes.Named.EKG
import Gargantext.API.Server.Named (server)
import Gargantext.Core.Config (_gc_notifications_config)
import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, NotificationsConfig(..), SettingsFile(..), corsAllowedOrigins, msProxyPort)
import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, NotificationsConfig(..), SettingsFile(..), corsAllowedOrigins)
import Gargantext.Database.Prelude qualified as DB
import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.Prelude hiding (putStrLn)
......@@ -73,18 +73,22 @@ import System.Cron.Schedule qualified as Cron
startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mode $ \logger -> do
env <- newEnv logger port sf
let proxyPort = env ^. settings.microservicesSettings.msProxyPort
let proxyStatus = microServicesProxyStatus (env ^. settings)
runDbCheck env
portRouteInfo (_gc_notifications_config $ _env_config env) port proxyPort
portRouteInfo (_gc_notifications_config $ _env_config env) port proxyStatus
app <- makeApp env
mid <- makeGargMiddleware (env ^. settings.corsSettings) mode
periodicActions <- schedulePeriodicActions env
let runServer = run port (mid app) `finally` stopGargantext periodicActions
proxyCache <- InMemory.newCache (Just oneHour)
let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env))
Async.race_ runServer runProxy
case proxyStatus of
PXY_disabled
-> runServer -- the proxy is disabled, do not spawn the application
PXY_enabled proxyPort
-> do
proxyCache <- InMemory.newCache (Just oneHour)
let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env))
Async.race_ runServer runProxy
where runDbCheck env = do
r <- runExceptT (runReaderT DB.dbCheck env) `catch`
......@@ -96,19 +100,26 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
"' before running gargantext-server (only the first time)."
oneHour = Clock.fromNanoSecs 3600_000_000_000
portRouteInfo :: NotificationsConfig -> PortNumber -> PortNumber -> IO ()
portRouteInfo nc mainPort proxyPort = do
portRouteInfo :: NotificationsConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
portRouteInfo nc mainPort proxyStatus = do
putStrLn "=========================================================================================================="
putStrLn " GarganText Main Routes"
putStrLn "=========================================================================================================="
putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece mainPort <> "/index.html"
putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
putStrLn $ " - Microservices proxy .....................: " <> "http://localhost:" <> toUrlPiece proxyPort
-- putStrLn $ " - Microservices proxy .....................: " <> "http://localhost:" <> toUrlPiece proxyStatus
putStrLn renderProxyStatus
putStrLn $ " - Central exchange.........................: " <> "nanomsg: " <> _nc_central_exchange_bind nc
putStrLn $ " - Dispatcher internal......................: " <> "nanomsg: " <> _nc_dispatcher_bind nc
putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
putStrLn "=========================================================================================================="
where
renderProxyStatus = case proxyStatus of
PXY_disabled ->
" - Microservices proxy .....................: DISABLED (enable in gargantext-settings.toml)"
PXY_enabled proxyPort ->
" - Microservices proxy .....................: http://localhost:" <> toUrlPiece proxyPort
-- | Stops the gargantext server and cancels all the periodic actions
-- scheduled to run up to that point.
......
src/Gargantext/API/Admin/Orchestrator.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.API.Admin.Orchestrator
Description : Jobs Orchestrator
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.API.Admin.Orchestrator where
import Control.Lens hiding (elements)
import Data.Aeson
import Data.ByteString.Lazy.Char8 qualified as LBS
import Gargantext.API.Admin.Orchestrator.Scrapy.Schedule
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.Prelude hiding (to)
import Servant
import Servant.Job.Async
import Servant.Job.Client
callJobScrapy :: (ToJSON e, FromJSON e, FromJSON o, MonadClientJob m)
=> JobServerURL e Schedule o
-> (URL -> Schedule)
-> m o
callJobScrapy jurl schedule = do
progress $ NewTask jurl
out <- view job_output <$>
retryOnTransientFailure (clientCallbackJob' jurl
(fmap (const ()) . scrapySchedule . schedule))
progress $ Finished jurl Nothing
pure out
logConsole :: ToJSON a => a -> IO ()
logConsole = LBS.putStrLn . encode
callScraper :: MonadClientJob m => URL -> ScraperInput -> m JobLog
callScraper url input =
callJobScrapy jurl $ \cb ->
Schedule
{ s_project = "gargantext"
, s_spider = input ^. scin_spider
, s_setting = []
, s_jobid = Nothing
, s_version = Nothing
, s_extra =
[("query", input ^.. scin_query . _Just)
,("user", [input ^. scin_user])
,("corpus", [input ^. scin_corpus . to toUrlPiece])
,("report_every", input ^.. scin_report_every . _Just . to toUrlPiece)
,("limit", input ^.. scin_limit . _Just . to toUrlPiece)
,("url", input ^.. scin_local_file . _Just)
,("count_only", input ^.. scin_count_only . _Just . to toUrlPiece)
,("callback", [toUrlPiece cb])]
}
where
jurl :: JobServerURL JobLog Schedule JobLog
jurl = JobServerURL url Callback
pipeline :: FromJSON e => URL -> ClientEnv -> ScraperInput
-> (e -> IO ()) -> IO JobLog
pipeline scrapyurl client_env input log_status = do
e <- runJobMLog client_env log_status $ callScraper scrapyurl input
either (panicTrace . show) pure e -- TODO throwError
-- TODO integrate to ServerT
-- use:
-- * serveJobsAPI instead of simpleServeJobsAPI
-- * JobFunction instead of simpleJobFunction
-- TODO:
-- * HasSelfUrl or move self_url to settings
-- * HasScrapers or move scrapers to settings
-- * EnvC env
{- NOT USED YET
import Data.Text
import Servant.Job.Server
import Servant.Job.Utils (extendBaseUrl)
import Gargantext.API.Admin.Types
scrapyOrchestrator :: Env -> IO (Server (WithCallbacks ScraperAPI))
scrapyOrchestrator env = do
apiWithCallbacksServer (Proxy :: Proxy ScraperAPI)
defaultSettings (extendBaseUrl ("scraper" :: Text) $ env ^. env_self_url)
(env ^. env_manager) (LogEvent logConsole) $
simpleServeJobsAPI (env ^. env_scrapers) .
simpleJobFunction . pipeline (URL $ env ^. settings . scrapydUrl)
-}
src/Gargantext/API/Admin/Orchestrator/Scrapy/Schedule.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.API.Admin.Orchestartor.Scrapy.Schedule
Description : Server API Auth Module
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Admin.Orchestrator.Scrapy.Schedule
where
import Control.Lens
import Data.Aeson
import GHC.Generics
import Protolude
import Servant
import Servant.Client
import Servant.Job.Utils (jsonOptions)
import Web.FormUrlEncoded hiding (parseMaybe)
import qualified Data.HashMap.Strict as H
------------------------------------------------------------------------
data Schedule = Schedule
{ s_project :: !Text
, s_spider :: !Text
, s_setting :: ![Text]
, s_jobid :: !(Maybe Text)
, s_version :: !(Maybe Text)
, s_extra :: ![(Text,[Text])]
}
deriving (Generic)
data ScheduleResponse = ScheduleResponse
{ r_status :: !Text
, r_jobid :: !Text
}
deriving (Generic)
instance FromJSON ScheduleResponse where
parseJSON = genericParseJSON (jsonOptions "r_")
instance ToForm Schedule where
toForm s =
Form . H.fromList $
[("project", [s_project s])
,("spider", [s_spider s])
,("setting", s_setting s)
,("jobid", s_jobid s ^.. _Just)
,("_version", s_version s ^.. _Just)
] ++ s_extra s
type Scrapy =
"schedule.json" :> ReqBody '[FormUrlEncoded] Schedule
:> Post '[JSON] ScheduleResponse
scrapyAPI :: Proxy Scrapy
scrapyAPI = Proxy
scrapySchedule :: Schedule -> ClientM ScheduleResponse
scrapySchedule = client scrapyAPI
src/Gargantext/API/Admin/Types.hs
View file @ 7056810c
......@@ -33,6 +33,17 @@ data Settings = Settings
makeLenses ''Settings
data MicroServicesProxyStatus
= PXY_enabled PortNumber
| PXY_disabled
deriving (Show, Eq)
microServicesProxyStatus :: Settings -> MicroServicesProxyStatus
microServicesProxyStatus stgs =
if stgs ^. microservicesSettings.msProxyEnabled
then PXY_enabled (stgs ^. microservicesSettings.msProxyPort)
else PXY_disabled
class HasSettings env where
settings :: Getter env Settings
......
src/Gargantext/API/Admin/Utils.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.API.Admin.Utils
Description : Server API main Types
Copyright : (c) CNRS, 2017-Present
License : BSD3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Mainly copied from Servant.Job.Utils (Thanks)
-}
module Gargantext.API.Admin.Utils
where
import Gargantext.Prelude
import Prelude (String)
import qualified Data.Text as T
infixr 4 ?|
-- Reverse infix form of "fromMaybe"
(?|) :: Maybe a -> a -> a
(?|) = flip fromMaybe
infixr 4 ?!
-- Reverse infix form of "fromJust" with a custom error message
(?!) :: Maybe a -> String -> a
(?!) ma' msg = ma' ?| panicTrace (T.pack msg)
src/Gargantext/API/Context.hs
View file @ 7056810c
......@@ -9,8 +9,6 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
......
src/Gargantext/API/Flow.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.API.Flow
Description : Main Flow API DataTypes
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Gargantext.API.Flow
where
-- import Gargantext.API.Prelude
import Gargantext.Prelude
data InputFlow = TextsInput
| NgramsInput
| ListInput
data Flow = EndFlow
| Texts InputFlow [Flow]
| Ngrams InputFlow [Flow]
| Lists InputFlow [Flow]
data OutputFlow
flow :: Flow -> OutputFlow
flow = undefined
src/Gargantext/API/GraphQL/Contact.sh deleted 100644 → 0
View file @ 0d0b33f0
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Gargantext.API.GraphQL.Contact where
import Control.Lens
import Data.Morpheus.Types
( GQLType
, Resolver
, ResolverM
, QUERY
, lift
)
import Data.Text (Text)
import qualified Data.Text as T
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Database.Admin.Types.Hyperdata
( HyperdataUser(..)
, hc_source
, hc_title
, hu_shared)
import Gargantext.Database.Admin.Types.Hyperdata.Contact
( HyperdataContact
, ContactWho
, ContactWhere
, cw_city
, cw_country
, cw_firstName
, cw_lastName
, cw_labTeamDepts
, cw_office
, cw_organization
, cw_role
, cw_touch
, ct_mail
, ct_phone
, hc_who
, hc_where)
import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata)
import Gargantext.Database.Schema.User (UserLight(..))
import Gargantext.Database.Schema.Node (node_id, node_hyperdata)
import Gargantext.Prelude
import GHC.Generics (Generic)
data UserInfo = UserInfo
{ ui_id :: Int
, ui_username :: Text
, ui_email :: Text
, ui_title :: Maybe Text
, ui_source :: Maybe Text
, ui_cwFirstName :: Maybe Text
, ui_cwLastName :: Maybe Text
, ui_cwCity :: Maybe Text
, ui_cwCountry :: Maybe Text
, ui_cwOrganization :: [Text]
, ui_cwLabTeamDepts :: [Text]
, ui_cwOffice :: Maybe Text
, ui_cwRole :: Maybe Text
, ui_cwTouchPhone :: Maybe Text
, ui_cwTouchMail :: Maybe Text }
deriving (Generic, GQLType, Show)
-- | Arguments to the "user info" query.
data UserInfoArgs
= UserInfoArgs
{ user_id :: Int
} deriving (Generic, GQLType)
-- | Arguments to the "user info" mutation,
data UserInfoMArgs
= UserInfoMArgs
{ ui_id :: Int
, ui_username :: Maybe Text
, ui_email :: Maybe Text
, ui_title :: Maybe Text
, ui_source :: Maybe Text
, ui_cwFirstName :: Maybe Text
, ui_cwLastName :: Maybe Text
, ui_cwCity :: Maybe Text
, ui_cwCountry :: Maybe Text
, ui_cwOrganization :: Maybe [Text]
, ui_cwLabTeamDepts :: Maybe [Text]
, ui_cwOffice :: Maybe Text
, ui_cwRole :: Maybe Text
, ui_cwTouchPhone :: Maybe Text
, ui_cwTouchMail :: Maybe Text
} deriving (Generic, GQLType)
type GqlM e env = Resolver QUERY e (GargM env GargError)
-- | Function to resolve user from a query.
resolveUserInfos
:: (HasConnectionPool env, HasConfig env, HasMail env)
=> UserInfoArgs -> GqlM e env [UserInfo]
resolveUserInfos UserInfoArgs { user_id } = do
lift $ printDebug "[resolveUserInfo] ui_id" user_id
dbUsers user_id
-- | Mutation for user info
updateUserInfo
:: (HasConnectionPool env, HasConfig env, HasMail env)
=> UserInfoMArgs -> ResolverM e (GargM env GargError) Int
updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
lift $ printDebug "[updateUserInfo] ui_id" ui_id
users <- lift (getUsersWithNodeHyperdata ui_id)
case users of
[] -> panicTrace $ "[updateUserInfo] User with id " <> (T.pack $ show ui_id) <> " doesn't exist."
((_u, node_u):_) -> do
let u_hyperdata = node_u ^. node_hyperdata
-- lift $ printDebug "[updateUserInfo] u" u
let u_hyperdata' = uh ui_titleL ui_title $
uh ui_sourceL ui_source $
uh ui_cwFirstNameL ui_cwFirstName $
uh ui_cwLastNameL ui_cwLastName $
uh ui_cwCityL ui_cwCity $
uh ui_cwCountryL ui_cwCountry $
uh' ui_cwLabTeamDeptsL ui_cwLabTeamDepts $
uh' ui_cwOrganizationL ui_cwOrganization $
uh ui_cwOfficeL ui_cwOffice $
uh ui_cwRoleL ui_cwRole $
uh ui_cwTouchMailL ui_cwTouchMail $
uh ui_cwTouchPhoneL ui_cwTouchPhone $
u_hyperdata
-- lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
_ <- lift $ updateHyperdata (node_u ^. node_id) u_hyperdata'
--let _newUser = toUser (u, u_hyperdata')
pure 1
where
uh _ Nothing u_hyperdata = u_hyperdata
uh lens' (Just val) u_hyperdata = u_hyperdata & lens' .~ Just val
uh' _ Nothing u_hyperdata = u_hyperdata
uh' lens' (Just val) u_hyperdata = u_hyperdata & lens' .~ val
-- | Inner function to fetch the user from DB.
dbUsers
:: (HasConnectionPool env, HasConfig env, HasMail env)
=> Int -> GqlM e env [UserInfo]
dbUsers user_id = do
-- lift $ printDebug "[dbUsers]" user_id
-- user <- getUsersWithId user_id
-- hyperdata <- getUserHyperdata user_id
-- lift (map toUser <$> zip user hyperdata)
lift (map toUser <$> (getUsersWithHyperdata user_id))
toUser :: (UserLight, HyperdataUser) -> UserInfo
toUser (UserLight { .. }, u_hyperdata) =
UserInfo { ui_id = userLight_id
, ui_username = userLight_username
, ui_email = userLight_email
, ui_title = u_hyperdata ^. ui_titleL
, ui_source = u_hyperdata ^. ui_sourceL
, ui_cwFirstName = u_hyperdata ^. ui_cwFirstNameL
, ui_cwLastName = u_hyperdata ^. ui_cwLastNameL
, ui_cwCity = u_hyperdata ^. ui_cwCityL
, ui_cwCountry = u_hyperdata ^. ui_cwCountryL
, ui_cwLabTeamDepts = u_hyperdata ^. ui_cwLabTeamDeptsL
, ui_cwOrganization = u_hyperdata ^. ui_cwOrganizationL
, ui_cwOffice = u_hyperdata ^. ui_cwOfficeL
, ui_cwRole = u_hyperdata ^. ui_cwRoleL
, ui_cwTouchMail = u_hyperdata ^. ui_cwTouchMailL
, ui_cwTouchPhone = u_hyperdata ^. ui_cwTouchPhoneL }
sharedL :: Traversal' HyperdataUser HyperdataContact
sharedL = hu_shared . _Just
ui_titleL :: Traversal' HyperdataUser (Maybe Text)
ui_titleL = sharedL . hc_title
ui_sourceL :: Traversal' HyperdataUser (Maybe Text)
ui_sourceL = sharedL . hc_source
contactWhoL :: Traversal' HyperdataUser ContactWho
contactWhoL = sharedL . hc_who . _Just
ui_cwFirstNameL :: Traversal' HyperdataUser (Maybe Text)
ui_cwFirstNameL = contactWhoL . cw_firstName
ui_cwLastNameL :: Traversal' HyperdataUser (Maybe Text)
ui_cwLastNameL = contactWhoL . cw_lastName
contactWhereL :: Traversal' HyperdataUser ContactWhere
contactWhereL = sharedL . hc_where . (ix 0)
ui_cwCityL :: Traversal' HyperdataUser (Maybe Text)
ui_cwCityL = contactWhereL . cw_city
ui_cwCountryL :: Traversal' HyperdataUser (Maybe Text)
ui_cwCountryL = contactWhereL . cw_country
ui_cwLabTeamDeptsL :: Traversal' HyperdataUser [Text]
ui_cwLabTeamDeptsL = hu_shared . _Just . (hc_where . (ix 0) . cw_labTeamDepts)
ui_cwOrganizationL :: Traversal' HyperdataUser [Text]
ui_cwOrganizationL = hu_shared . _Just . (hc_where . (ix 0) . cw_organization)
ui_cwOfficeL :: Traversal' HyperdataUser (Maybe Text)
ui_cwOfficeL = contactWhereL . cw_office
ui_cwRoleL :: Traversal' HyperdataUser (Maybe Text)
ui_cwRoleL = contactWhereL . cw_role
ui_cwTouchMailL :: Traversal' HyperdataUser (Maybe Text)
ui_cwTouchMailL = hu_shared . _Just . (hc_where . (ix 0) . cw_touch . _Just . ct_mail)
--ui_cwTouchMailL = contactWhereL . cw_touch . _Just . ct_mail
ui_cwTouchPhoneL :: Traversal' HyperdataUser (Maybe Text)
ui_cwTouchPhoneL = hu_shared . _Just . (hc_where . (ix 0) . cw_touch . _Just . ct_phone)
--ui_cwTouchPhoneL = contactWhereL . cw_touch . _Just . ct_phone
src/Gargantext/API/Metrics.hs
View file @ 7056810c
......@@ -11,9 +11,7 @@ Metrics API
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Metrics
where
......
src/Gargantext/API/Node/Contact.hs
View file @ 7056810c
......@@ -9,8 +9,6 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
......
src/Gargantext/API/Node/Corpus/New/File.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.API.Node.Corpus.New.File
Description : Server API
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Node.Corpus.New.File
where
import Control.Lens ((?~))
import Data.Swagger
import Gargantext.API.Node.Corpus.New.Types (FileFormat, FileType)
import Gargantext.Core.Types (TODO)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Prelude hiding (hash)
import Gargantext.Prelude.Crypto.Hash (hash)
import Servant ( JSON, type (:>), Post, QueryParam, Summary )
import Servant.Multipart ( Input(iName), Mem, MultipartData(inputs), MultipartForm )
import Servant.Swagger.Internal ( addParam, HasSwagger(..) )
-------------------------------------------------------------
type Hash = Text
instance ToParamSchema (MultipartData Mem) where toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
instance (ToParamSchema a, HasSwagger sub) =>
HasSwagger (MultipartForm tag a :> sub) where
-- TODO
toSwagger _ = toSwagger (Proxy :: Proxy sub)
& addParam param
where
param = mempty
& required ?~ True
& schema .~ ParamOther sch
sch = mempty
& in_ .~ ParamFormData
& paramSchema .~ toParamSchema (Proxy :: Proxy a)
type WithUpload' = Summary "Upload file(s) to a corpus"
:> QueryParam "fileType" FileType
:> QueryParam "fileFormat" FileFormat
:> MultipartForm Mem (MultipartData Mem)
:> Post '[JSON] [Hash]
--postUpload :: NodeId -> Maybe FileType -> GargServer UploadAPI
--postUpload :: NodeId -> GargServer UploadAPI
postUpload :: NodeId
-> Maybe FileType
-> Maybe FileFormat
-> MultipartData Mem
-> Cmd err [Hash]
postUpload _ Nothing _ _ = panicTrace "fileType is a required parameter"
postUpload _ _ Nothing _ = panicTrace "fileFormat is a required parameter"
postUpload _ (Just _fileType) (Just _fileFormat) multipartData = do
-- printDebug "File Type: " fileType
-- printDebug "File format: " fileFormat
is <- liftBase $ do
-- printDebug "Inputs:" ()
forM (inputs multipartData) $ \input -> do
-- printDebug "iName " (iName input)
-- printDebug "iValue " (iValue input)
pure $ iName input
{-
_ <- forM (files multipartData) $ \file -> do
-- let content = fdPayload file
-- printDebug "XXX " (fdFileName file)
-- printDebug "YYY " content
pure () -- $ cs content
-- is <- inputs multipartData
-}
pure $ map hash is
-------------------------------------------------------------------
src/Gargantext/API/Node/File.hs
View file @ 7056810c
......@@ -8,7 +8,7 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeOperators #-}
......
src/Gargantext/API/Node/Get.hs
View file @ 7056810c
......@@ -11,7 +11,6 @@ Polymorphic Get Node API
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE TemplateHaskell #-}
......
src/Gargantext/API/Node/New.hs
View file @ 7056810c
......@@ -14,7 +14,6 @@ Async new node feature
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE IncoherentInstances #-}
module Gargantext.API.Node.New
......
src/Gargantext/API/Node/Update.hs
View file @ 7056810c
......@@ -9,8 +9,7 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Node.Update
where
......
src/Gargantext/API/Routes.hs
View file @ 7056810c
......@@ -16,7 +16,6 @@ Portability : POSIX
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance HasSwagger (WithCustomErrorScheme GargAPI)
module Gargantext.API.Routes
where
......
src/Gargantext/API/Table.hs
View file @ 7056810c
......@@ -22,8 +22,6 @@ Node API
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
......
src/Gargantext/Core/Methods/Graph/BAC/Proxemy.hs deleted 100644 → 0
View file @ 0d0b33f0
This diff is collapsed.
src/Gargantext/Core/Methods/Similarities/Distributional.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Methods.Similarities.Distributional
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Motivation and definition of the @Distributional@ distance.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Strict #-}
module Gargantext.Core.Methods.Similarities.Distributional
where
import Data.Matrix hiding (identity)
import qualified Data.Map as M
import Data.Vector (Vector)
import qualified Data.Vector as V
import Gargantext.Prelude
import Gargantext.Core.Viz.Graph.Utils
distributional' :: (Floating a, Ord a) => Matrix a -> [((Int, Int), a)]
distributional' m = filter (\((x,y), d) -> foldl' (&&) True (conditions x y d) ) distriList
where
conditions x y d = [ (x /= y)
, (d > miniMax')
, ((M.lookup (x,y) distriMap) > (M.lookup (y,x) distriMap))
]
distriList = toListsWithIndex distriMatrix
distriMatrix = ri (mi m)
distriMap = M.fromList $ distriList
miniMax' = miniMax distriMatrix
ri :: (Ord a, Fractional a) => Matrix a -> Matrix a
ri m = matrix c r doRi
where
doRi (x,y) = doRi' x y m
doRi' x y mi'' = sumMin x y mi'' / (V.sum $ ax Col x y mi'')
sumMin x y mi' = V.sum $ V.map (\(a,b) -> min a b )
$ V.zip (ax Col x y mi') (ax Row x y mi')
(c,r) = (nOf Col m, nOf Row m)
mi :: (Ord a, Floating a) => Matrix a -> Matrix a
mi m = matrix c r createMat
where
(c,r) = (nOf Col m, nOf Row m)
createMat (x,y) = doMi x y m
doMi x y m' = if x == y then 0 else (max (log (doMi' x y m')) 0 )
doMi' x y m' = (getElem x y m) / ( cross x y m / total m' )
cross x y m' = (V.sum $ ax Col x y m) * (V.sum $ ax Row x y m')
ax :: Axis -> Int -> Int -> Matrix a -> Vector a
ax a i j m = dropAt j' $ axis a i' m
where
i' = div i c + 1
j' = mod r j + 1
(c,r) = (nOf Col m, nOf Row m)
miniMax :: (Ord a) => Matrix a -> a
miniMax m = V.minimum $ V.map (\c -> V.maximum $ getCol c m) (V.enumFromTo 1 (nOf Col m))
src/Gargantext/Core/NodeStoryFile.hs.old deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.API.Ngrams.Types
Description : Ngrams List Types
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
NOTE This is legacy code. It keeps node stories in a directory
repo. We now have migrated to the DB. However this code is needed to
make the migration (see Gargantext.API.Ngrams.Tools)
-}
module Gargantext.Core.NodeStoryFile where
import Codec.Serialise (serialise, deserialise)
import Codec.Serialise.Class
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Control.Lens (view)
import Data.ByteString.Lazy qualified as DBL
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Gargantext.Core.NodeStory hiding (fromDBNodeStoryEnv)
import Gargantext.Core.Types (ListId, NodeId(..))
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
import Gargantext.Prelude
import Gargantext.Core.Config (gc_repofilepath)
import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
import System.IO (hClose)
import System.IO.Temp (withTempFile)
getRepo :: HasNodeStory env err m
=> [ListId] -> m NodeListStory
getRepo listIds = do
g <- getNodeListStory
liftBase $ do
v <- g listIds
readMVar v
-- v <- liftBase $ f listIds
-- v' <- liftBase $ readMVar v
-- pure $ v'
getRepoReadConfig :: (HasNodeStory env err m)
=> [ListId] -> m NodeListStory
getRepoReadConfig listIds = do
repoFP <- view $ hasConfig . gc_repofilepath
env <- liftBase $ readNodeStoryEnv repoFP
let g = view nse_getter env
liftBase $ do
v <- g listIds
readMVar v
getNodeListStory :: HasNodeStory env err m
=> m ([NodeId] -> IO (MVar NodeListStory))
getNodeListStory = do
env <- view hasNodeStory
pure $ view nse_getter env
readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
readNodeStoryEnv nsd = do
mvar <- nodeStoryVar nsd Nothing []
saver <- mkNodeStorySaver nsd mvar
let saver_immediate = withMVar mvar (writeNodeStories nsd)
let archive_saver_immediate ns = pure ns
pure $ NodeStoryEnv { _nse_var = mvar
, _nse_saver = saver
, _nse_saver_immediate = saver_immediate
, _nse_archive_saver_immediate = archive_saver_immediate
, _nse_getter = nodeStoryVar nsd (Just mvar) }
------------------------------------------------------------------------
mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
mkNodeStorySaver nsd mvns = mkDebounce settings
where
settings = defaultDebounceSettings
{ debounceAction = withMVar mvns (writeNodeStories nsd)
, debounceFreq = 1 * minute
-- , debounceEdge = trailingEdge -- Trigger on the trailing edge
}
minute = 60 * sec
sec = 10^(6 :: Int)
nodeStoryVar :: NodeStoryDir
-> Maybe (MVar NodeListStory)
-> [NodeId]
-> IO (MVar NodeListStory)
nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
nodeStoryVar nsd (Just mv) ni = do
_ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
pure mv
nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
case Map.lookup ni nls of
Nothing -> do
(NodeStory nls') <- nodeStoryRead nsd ni
pure $ NodeStory $ Map.union nls nls'
Just _ -> pure ns
nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
nodeStoryIncs :: NodeStoryDir
-> Maybe NodeListStory
-> [NodeId]
-> IO NodeListStory
nodeStoryIncs _ Nothing [] = pure $ NodeStory $ Map.empty
nodeStoryIncs nsd (Just nls) ns = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
nodeStoryIncs nsd Nothing (ni:ns) = do
m <- nodeStoryRead nsd ni
nodeStoryIncs nsd (Just m) ns
nodeStoryDec :: NodeStoryDir
-> NodeListStory
-> NodeId
-> IO NodeListStory
nodeStoryDec nsd ns@(NodeStory nls) ni = do
case Map.lookup ni nls of
Nothing -> do
-- we make sure the corresponding file repo is really removed
_ <- nodeStoryRemove nsd ni
pure ns
Just _ -> do
let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
_ <- nodeStoryRemove nsd ni
pure $ NodeStory ns'
-- | TODO lock
nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead nsd ni = do
_repoDir <- createDirectoryIfMissing True nsd
let nsp = nodeStoryPath nsd ni
exists <- doesFileExist nsp
if exists
then deserialise <$> DBL.readFile nsp
else pure (initNodeStory ni)
nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
nodeStoryRemove nsd ni = do
let nsp = nodeStoryPath nsd ni
exists <- doesFileExist nsp
if exists
then removeFile nsp
else pure ()
nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
$ fmap Map.keys
$ fmap _a_state
$ Map.lookup ni
$ _unNodeStory n
------------------------------------------------------------------------
type NodeStoryDir = FilePath
writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
writeNodeStories fp nls = do
_done <- mapM (writeNodeStory fp) $ splitByNode nls
-- printDebug "[writeNodeStories]" done
pure ()
writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
splitByNode (NodeStory m) =
List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
saverAction' repoDir nId a = do
withTempFile repoDir ((show nId) <> "-tmp-repo.cbor") $ \fp h -> do
-- printDebug "[repoSaverAction]" fp
DBL.hPut h $ serialise a
hClose h
renameFile fp (nodeStoryPath repoDir nId)
nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
nodeStoryPath repoDir nId = repoDir <> "/" <> filename
where
filename = "repo" <> "-" <> (show nId) <> ".cbor"
------------------------------------------------------------------------
-- TODO : repo Migration TODO TESTS
{-
repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
repoToNodeListStory :: NgramsRepo -> NodeListStory
repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
where
s' = ngramsState_migration s
h' = ngramsStatePatch_migration h
ns = List.map (\(n,ns')
-> (n, let hs = fromMaybe [] (Map.lookup n h') in
Archive { _a_version = List.length hs
, _a_state = ns'
, _a_history = hs }
)
) $ Map.toList s'
ngramsState_migration :: NgramsState
-> Map NodeId NgramsState'
ngramsState_migration ns =
Map.fromListWith (Map.union) $
List.concat $
map (\(nt, nTable)
-> map (\(nid, table)
-> (nid, Map.singleton nt table)
) $ Map.toList nTable
) $ Map.toList ns
ngramsStatePatch_migration :: [NgramsStatePatch]
-> Map NodeId [NgramsStatePatch']
ngramsStatePatch_migration np' = Map.fromListWith (<>)
$ List.concat
$ map toPatch np'
where
toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
toPatch p =
List.concat $
map (\(nt, nTable)
-> map (\(nid, table)
-> (nid, [fst $ Patch.singleton nt table])
) $ Patch.toList nTable
) $ Patch.toList p
-}
src/Gargantext/Core/Text/Convert.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.Convert
Description : All parsers of Gargantext in one file.
Copyright : (c) CNRS, 2017
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Format Converter.
-}
{-# LANGUAGE PackageImports #-}
module Gargantext.Core.Text.Convert (risPress2tsvWrite)
where
import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat(..), FileType(..))
import Gargantext.Core.Text.Corpus.Parsers.TSV (writeDocs2Tsv)
import Gargantext.Prelude
risPress2tsvWrite :: FilePath -> IO ()
risPress2tsvWrite f = do
eContents <- parseFile RisPresse Plain (f <> ".ris")
case eContents of
Right contents -> writeDocs2Tsv (f <> ".csv") contents
Left e -> panicTrace $ "Error: " <> e
src/Gargantext/Core/Text/Corpus/API/Arxiv.hs
View file @ 7056810c
......@@ -9,7 +9,7 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-top-binds #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.Core.Text.Corpus.API.Arxiv
......
src/Gargantext/Core/Text/Corpus/Parsers/Date/Parsec.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.Corpus.Parsers.Date
Description : Some utils to parse dates
Copyright : (c) CNRS 2017-present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.Core.Text.Corpus.Parsers.Date.Parsec
where
import Data.Fixed (Fixed (MkFixed))
import Data.String (String)
import Data.Text qualified as T
import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..), TimeOfDay(..))
import Data.Time.Calendar (Day, fromGregorian)
import Gargantext.Prelude
import Text.Parsec.Error (ParseError)
import Text.Parsec.Prim (Stream, ParsecT)
import Text.Parsec.String (Parser)
import Text.ParserCombinators.Parsec (many1, noneOf, anyChar, char, oneOf)
import Text.ParserCombinators.Parsec qualified (parse)
import Text.XML.HXT.DOM.Util (decimalStringToInt)
-- | Permit to transform a String to an Int in a monadic context
wrapDST :: Monad m => String -> m Int
wrapDST = pure . decimalStringToInt
-- | Generic parser which take at least one element not given in argument
many1NoneOf :: Stream s m Char => [Char] -> ParsecT s u m [Char]
many1NoneOf = (many1 . noneOf)
getMultiplicator :: Int -> Int
getMultiplicator a
| 0 >= a = 1
| otherwise = 10 * (getMultiplicator $ div a 10)
-- | Parser for date format y-m-d
parseGregorian :: Parser Day
parseGregorian = do
y <- wrapDST =<< many1NoneOf ['-']
_ <- char '-'
m <- wrapDST =<< many1NoneOf ['-']
_ <- char '-'
d <- wrapDST =<< many1NoneOf ['T']
_ <- char 'T'
pure $ fromGregorian (toInteger y) m d
---- | Parser for time format h:m:s
parseTimeOfDay :: Parser TimeOfDay
parseTimeOfDay = do
h <- wrapDST =<< many1NoneOf [':']
_ <- char ':'
m <- wrapDST =<< many1NoneOf [':']
_ <- char ':'
r <- many1NoneOf ['.']
_ <- char '.'
dec <- many1NoneOf ['+', '-']
let (nb, l) = (decimalStringToInt $ r ++ dec, length dec)
seconds = nb * 10^(12-l)
pure $ TimeOfDay h m (MkFixed . toInteger $ seconds)
-- | Parser for timezone format +hh:mm
parseTimeZone :: Parser TimeZone
parseTimeZone = do
sign <- oneOf ['+', '-']
h <- wrapDST =<< many1NoneOf [':']
_ <- char ':'
m <- wrapDST =<< (many1 $ anyChar)
let timeInMinute = if sign == '+' then h * 60 + m else -h * 60 - m
in pure $ TimeZone timeInMinute False "CET"
---- | Parser which use parseGregorian, parseTimeOfDay and parseTimeZone to create a ZonedTime
parseZonedTime :: Parser ZonedTime
parseZonedTime= do
d <- parseGregorian
tod <- parseTimeOfDay
tz <- parseTimeZone
pure $ ZonedTime (LocalTime d (tod)) tz
---- | Opposite of toRFC3339
fromRFC3339 :: Text -> Either ParseError ZonedTime
fromRFC3339 t = Text.ParserCombinators.Parsec.parse parseZonedTime "ERROR: Couldn't parse zoned time." input
where input = T.unpack t
src/Gargantext/Core/Text/Corpus/Parsers/Json2Csv.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.Corpus.Parsers.Json2Csv
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Json parser to export towoard CSV GargV3 format.
(Export from the Patent Database.)
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Text.Corpus.Parsers.Json2Csv (json2tsv, readPatents)
where
import Data.Aeson ( decode )
import Data.ByteString.Lazy (readFile)
import Data.Text (unpack)
import Data.Vector (fromList)
import Gargantext.Core.Text.Corpus.Parsers.TSV (TsvDoc(..), writeFile, headerTsvGargV3)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Defaults qualified as Defaults
import Gargantext.Prelude hiding (readFile, writeFile)
import Prelude (read)
data Patent = Patent { _patent_title :: Text
, _patent_abstract :: Text
, _patent_year :: Text
, _patent_id :: Text
} deriving (Show)
$(deriveJSON (unPrefix "_patent_") ''Patent)
readPatents :: FilePath -> IO (Maybe [Patent])
readPatents fp = decode <$> readFile fp
type FilePathIn = FilePath
type FilePathOut = FilePath
json2tsv :: FilePathIn -> FilePathOut -> IO ()
json2tsv fin fout = do
patents <- maybe (panicTrace "json2tsv error") identity <$> readPatents fin
writeFile fout (headerTsvGargV3, fromList $ map patent2tsvDoc patents)
patent2tsvDoc :: Patent -> TsvDoc
patent2tsvDoc (Patent { .. }) =
TsvDoc { tsv_title = _patent_title
, tsv_source = "Source"
, tsv_publication_year = Just $ read (unpack _patent_year)
, tsv_publication_month = Just $ Defaults.month
, tsv_publication_day = Just $ Defaults.day
, tsv_abstract = _patent_abstract
, tsv_authors = "Authors" }
src/Gargantext/Core/Text/Corpus/Parsers/Telegram.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.Corpus.Parsers.Telegram
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.Core.Text.Corpus.Parsers.Telegram
where
import Data.Aeson
import Data.ByteString.Lazy qualified as DBL
import Gargantext.Prelude
readFile_Telegram :: FilePath -> IO [TelegramMsg]
readFile_Telegram fp = do
raw <- DBL.readFile fp
let mayIssues = decode raw
case mayIssues of
Just is -> pure is
Nothing -> pure []
data TelegramMsg = TelegramMsg { _action_entities :: !Text
, _broadcastg :: !Text
, _buttonsg :: !Text
, _buttons_countg :: !Text
, _buttons_flatg :: !Text
, _chatg :: !Text
, _chat_peerg :: !Text
, _fileg :: !Text
, _forwardg :: !Text
, _input_chatg :: !Text
, _input_senderg :: !Text
, _linked_chatg :: !Text
, _reply_messageg :: !Text
, _senderg :: !Text
, _sender_idg :: !Text
, _textg :: !Text
, _via_botg :: !Text
, _via_input_botg :: !Text
, actiong :: !Text
, dateg :: !Text
, edit_dateg :: !Text
, edit_hideg :: !Text
, entitiesg :: !Text
, forwardsg :: !Text
, from_idg :: !Text
, from_scheduledg :: !Text
, fwd_fromg :: !Text
, grouped_idg :: !Text
, idg :: !Text
, legacyg :: !Text
, mediag :: !Text
, media_unreadg :: !Text
, mentionedg :: !Text
, messageg :: !Text
, noforwardsg :: !Text
, outg :: !Text
, peer_idg :: !Text
, pinnedg :: !Text
, postg :: !Text
, post_authorg :: !Text
, reactionsg :: !Text
, repliesg :: !Text
, reply_markupg :: !Text
, reply_tog :: !Text
, restriction_reasong :: !Text
, silentg :: !Text
, ttl_periodg :: !Text
, via_bot_idg :: !Text
, views :: !Text
}
deriving (Show, Generic)
instance FromJSON TelegramMsg
{-
gitlabIssue2hyperdataDocument :: Issue -> HyperdataDocument
gitlabIssue2hyperdataDocument issue = HyperdataDocument
{ _hd_bdd = Nothing
, _hd_doi = Nothing
, _hd_url = Nothing
, _hd_uniqId = Nothing
, _hd_uniqIdBdd = Nothing
, _hd_page = Nothing
, _hd_title = Just (_issue_title issue)
, _hd_authors = Nothing
, _hd_institutes = Nothing
, _hd_source = Nothing
, _hd_abstract = Just (_issue_content issue)
, _hd_publication_date = Just $ DT.pack $ show date
, _hd_publication_year = Just $ fromIntegral year
, _hd_publication_month = Just month
, _hd_publication_day = Just day
, _hd_publication_hour = Just (todHour tod)
, _hd_publication_minute = Just (todMin tod)
, _hd_publication_second = Just (round $ todSec tod)
, _hd_language_iso2 = Just $ (DT.pack . show) lang
}
where lang = EN
date = _issue_created issue
(year, month, day) = toGregorian $ localDay date
tod = localTimeOfDay date
-}
{-
readFile_IssuesAsDocs :: FilePath -> IO [HyperdataDocument]
readFile_IssuesAsDocs = fmap (fmap gitlabIssue2hyperdataDocument) . readFile_Issues
-}
src/Gargantext/Core/Text/Corpus/Parsers/Wikimedia.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.Corpus.Parsers.Wikimedia
Description : Parser for Wikimedia dump
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
@Gargantext.Core.Text.Corpus.Parsers.Wikimedia@:
This module provide a parser for wikipedia dump.
This include an xml parser for wikipedia's xml
and an wikimedia to plaintext converter for the wikipedia text field
-}
module Gargantext.Core.Text.Corpus.Parsers.Wikimedia
where
import Control.Monad.Catch
import Data.Conduit
import Data.Either
import Data.Text as T
import Data.XML.Types (Event, Name)
import Gargantext.Prelude hiding (force)
import Text.Pandoc
import Text.XML.Stream.Parse
-- | Use case
-- :{
-- wikimediaFile <- BL.readFile "text.xml"
-- _ <- runConduit $ parseLBS def wikimediaFile
-- .| force "mediawiki required" parseMediawiki
-- .| CL.mapM mediawikiPageToPlain
-- .| CL.mapM_ print
-- :}
-- | A simple "Page" type.
-- For the moment it takes only text and title
-- (since there is no abstract) will see if other data are relevant.
data Page =
Page { _markupFormat :: MarkupFormat
, _title :: Maybe T.Text
, _text :: Maybe T.Text
}
deriving (Show)
data MarkupFormat = Mediawiki | Plaintext
deriving (Show)
parseRevision :: MonadThrow m => ConduitT Event o m (Maybe T.Text)
parseRevision = tagNoAttr "{http://www.mediawiki.org/xml/export-0.10/}revision" $ do
text <- force "text is missing" $ ignoreExcept "{http://www.mediawiki.org/xml/export-0.10/}text" content
many_ ignoreAnyTreeContent
pure text
-- | Utility function that matches everything but the tag given
tagUntil :: Name -> NameMatcher Name
tagUntil name = matching (/= name)
-- | Utility function that consumes everything but the tag given
-- usefull because we have to consume every data.
manyTagsUntil_ :: MonadThrow m => Name -> ConduitT Event o m ()
manyTagsUntil_ n = many_ (ignoreTree (tagUntil n) ignoreAttrs)
manyTagsUntil_' :: MonadThrow m => Name -> ConduitT Event o m ()
manyTagsUntil_' = many_ . ignoreEmptyTag . tagUntil
-- | Utility function that parses nothing but the tag given,
-- usefull because we have to consume every data.
ignoreExcept :: MonadThrow m => Name
-> ConduitT Event o m b
-> ConduitT Event o m (Maybe b)
ignoreExcept name f = do
_ <- manyTagsUntil_ name
tagIgnoreAttrs (matching (== name)) f
-- TODO: remove ignoreExcept to:
-- many ignoreAnyTreeContentUntil "Article"
manyTagsUntil :: MonadThrow m => Name
-> ConduitT Event o m b
-> ConduitT Event o m (Maybe b)
manyTagsUntil name f = do
_ <- manyTagsUntil_ name
tagIgnoreAttrs (matching (== name)) f
parsePage :: MonadThrow m => ConduitT Event o m (Maybe Page)
parsePage =
tagNoAttr "{http://www.mediawiki.org/xml/export-0.10/}page" $ do
title <-
tagNoAttr "{http://www.mediawiki.org/xml/export-0.10/}title" content
_ <- manyTagsUntil_ "{http://www.mediawiki.org/xml/export-0.10/}revision"
revision <-
parseRevision
many_ $ ignoreAnyTreeContent
pure $ Page { _markupFormat = Mediawiki
, _title = title
, _text = revision }
parseMediawiki :: MonadThrow m => ConduitT Event Page m (Maybe ())
parseMediawiki =
tagIgnoreAttrs "{http://www.mediawiki.org/xml/export-0.10/}mediawiki"
$ manyYield' parsePage
-- | Convert a Mediawiki Page to a Plaintext Page.
-- Need to wrap the result in IO to parse and to combine it.
mediawikiPageToPlain :: Page -> IO Page
mediawikiPageToPlain page = do
title <- mediaToPlain $ _title page
revision <- mediaToPlain $ _text page
pure $ Page { _markupFormat = Plaintext, _title = title, _text = revision }
where mediaToPlain media =
case media of
(Nothing) -> pure Nothing
(Just med) -> do
res <- runIO $ do
doc <- readMediaWiki def med
writePlain def doc
case res of
(Left _) -> pure Nothing
(Right r) -> pure $ Just r
src/Gargantext/Core/Text/List/Learn.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.List.Learn
Description : Learn to make lists
Copyright : (c) CNRS, 2018-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
CSV parser for Gargantext corpus files.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Core.Text.List.Learn
where
import Data.IntMap qualified as IntMap
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.SVM qualified as SVM
import Data.Vector qualified as Vec
import Gargantext.Core
import Gargantext.Core.Text.Metrics.Count (occurrencesWith)
import Gargantext.Core.Types.Main (ListType(..))
import Gargantext.Database.GargDB
import Gargantext.Prelude
------------------------------------------------------------------------
train :: Double -> Double -> SVM.Problem -> IO SVM.Model
train x y = (SVM.train (SVM.CSvc x) (SVM.RBF y))
predict :: SVM.Model -> [Vec.Vector Double] -> IO [Double]
predict m vs = mapM (predict' m) vs
where
predict' m' vs' = SVM.predict m' (IntMap.fromList $ (zip [1..]) $ Vec.toList vs')
------------------------------------------------------------------------
trainList :: Double -> Double -> Map ListType [Vec.Vector Double] -> IO SVM.Model
trainList x y = (train x y) . trainList'
where
trainList' :: Map ListType [Vec.Vector Double] -> SVM.Problem
trainList' = mapVec2problem . (Map.mapKeys (fromIntegral . toDBid))
mapVec2problem :: Map Double [Vec.Vector Double] -> SVM.Problem
mapVec2problem = List.concat . (map (\(a,as) -> zip (repeat a) as)) . Map.toList . (Map.map vecs2maps)
vecs2maps :: [Vec.Vector Double] -> [IntMap.IntMap Double]
vecs2maps = map (IntMap.fromList . (zip [1..]) . Vec.toList)
predictList :: HasCallStack => Model -> [Vec.Vector Double] -> IO [Maybe ListType]
predictList (ModelSVM m _ _) vs = map (Just . fromDBid . round) <$> predict m vs
------------------------------------------------------------------------
data Model = ModelSVM { modelSVM :: SVM.Model
, param1 :: Maybe Double
, param2 :: Maybe Double
}
--{-
instance SaveFile Model
where
saveFile' fp (ModelSVM m _ _) = SVM.saveModel m fp
instance ReadFile Model
where
readFile' fp = do
m <- SVM.loadModel fp
pure $ ModelSVM m Nothing Nothing
--}
------------------------------------------------------------------------
-- | TODO
-- shuffle list
-- split list : train / test
-- grid parameters on best result on test
type Train = Map ListType [Vec.Vector Double]
type Tests = Map ListType [Vec.Vector Double]
type Score = Double
type Param = Double
grid :: (MonadBase IO m)
=> Param -> Param -> Train -> [Tests] -> m (Maybe Model)
grid _ _ _ [] = panicTrace "Gargantext.Core.Text.List.Learn.grid : empty test data"
grid s e tr te = do
let
grid' :: (MonadBase IO m)
=> Double -> Double
-> Train
-> [Tests]
-> m (Score, Model)
grid' x y tr' te' = do
model'' <- liftBase $ trainList x y tr'
let
model' = ModelSVM model'' (Just x) (Just y)
score' :: [(ListType, Maybe ListType)] -> Map (Maybe Bool) Int
score' = occurrencesWith (\(a,b) -> (==) <$> Just a <*> b)
score'' :: Map (Maybe Bool) Int -> Double
score'' m'' = maybe 0 (\t -> (fromIntegral t)/total) (Map.lookup (Just True) m'')
where
total = fromIntegral $ foldl (+) 0 $ Map.elems m''
getScore m t = do
let (res, toGuess) = List.unzip
$ List.concat
$ map (\(k,vs) -> zip (repeat k) vs)
$ Map.toList t
res' <- liftBase $ predictList m toGuess
pure $ score'' $ score' $ List.zip res res'
score <- mapM (getScore model') te'
pure (mean score, model')
r <- head . List.reverse
. (List.sortOn fst)
<$> mapM (\(x,y) -> grid' x y tr te)
[(x,y) | x <- [s..e], y <- [s..e]]
-- printDebug "GRID SEARCH" (map fst r)
-- printDebug "file" fp
--fp <- saveFile (ModelSVM model')
--save best result
pure $ snd <$> r
src/Gargantext/Core/Text/List/Management.sh deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.Ngrams.List.Management
Description : Tools to manage lists
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Text.List.Management
where
{-
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Gargantext.API.Ngrams
import Gargantext.API.Ngrams.Types (NgramsElement, NgramsTerm(..))
import Gargantext.Database.Action.Flow.Types
import Gargantext.API.Ngrams.Tools (getListNgrams)
import Gargantext.Core.NodeStory
import Gargantext.Core.Text (size)
import Gargantext.Core.Text.List.Group
import Gargantext.Core.Text.List.Group.Prelude
import Gargantext.Core.Text.List.Group.WithStem
import Gargantext.Core.Text.List.Social
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Text.Metrics (scored', Scored(..), scored_speExc, scored_genInc, normalizeGlobal, normalizeLocal, scored_terms)
import Gargantext.Core.Types (ListType(..), CorpusId, ListId)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsUser, getContextsByNgramsOnlyUser)
import Gargantext.Database.Action.Metrics.TFICF (getTficf_withSample)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (CmdM)
import Gargantext.Database.Query.Table.Ngrams (text2ngrams)
import Gargantext.Database.Query.Table.NgramsPostag (selectLems)
import Gargantext.Database.Query.Table.Node (defaultList, getClosestParentIdByType)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Database.Query.Tree.Error (HasTreeError)
import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast')
import Gargantext.Database.Schema.Ngrams (NgramsType(..), Ngrams(..))
import Gargantext.Prelude
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
restrictListSize
:: forall env err m.
(HasNodeStory env err m, FlowCmdM env err m)
=> CorpusId
-> ListId
-> NgramsType
-> ListType
-> Int -- ^ number of ngram pairs to keep
-> m ()
restrictListSize corpusId listId ngramsType listType size = do
ngrams <- getListNgrams [listId] ngramsType
-- corpus_id <- getClosestParentIdByType
occurrences <- getOccByNgramsOnlyFast' corpusId
listId
ngramsType
(HashMap.keys ngrams)
ngrams' <- filterWith listType size occurrences ngrams
_ <- setListNgrams listId ngramsType ngrams'
pure ()
where filterWith :: ListType -> Int -> HashMap NgramsTerm Int
-> HashMap NgramsTerm NgramsRepoElement
-> m (Map NgramsTerm NgramsRepoElement)
filterWith listType' size occs ngrams =
HashMap.filter with ngrams
where
with nre = case (&&) <$> Just (nre^.nre_list == listType)
<*> ( HashMap.lookup (nre^.nre_root) occs
&&
-}
src/Gargantext/Core/Text/List/Merge.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.List.Merge
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE InstanceSigs #-}
module Gargantext.Core.Text.List.Merge
where
import Control.Lens (view)
import Data.Map.Strict.Patch hiding (PatchMap)
import Gargantext.API.Ngrams
import Gargantext.API.Ngrams.Types
import Gargantext.Prelude hiding (diff)
type List = Map NgramsTerm NgramsRepoElement
type Patch = PatchMap NgramsTerm (Replace (Maybe NgramsRepoElement))
-- Question: which version of Patching increment is using the FrontEnd ?
diffList :: Versioned List -> Versioned List -> Versioned Patch
diffList l1 l2 = Versioned (1 + view v_version l1)
(diff (view v_data l1) (view v_data l2))
-- | TODO
{-
commit :: ListId -> NgramsType -> Versioned Patch -> List -> List
commit = undefined
-}
src/Gargantext/Core/Text/Metrics/Hetero.purs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Here is a longer description of this module, containing some
commentary with @some markup@.
-}
module Gargantext.Text.Hetero where
import Data.List.Split as S
import Data.Map as M
import Data.Set as S
import Database.PostgreSQL.Simple as PGS
import GHC.Real as R
import Gargantext.Database.Admin.Gargandb
import Gargantext.Database.Admin.Private
import Gargantext.Database.Simple
import Gargantext.Text.Count (occurrences)
import Gargantext.Text.Words (cleanText)
import Opaleye.Internal.Column (Column)
import Opaleye.PGTypes (PGInt4)
--main = do
-- t <- getTextquery
-- print (Prelude.map (heterogeinity . concat) $ S.chunksOf 3 t)
-- heterogeinity sur concat texts
heterogeinity' :: Int -> Int -> Int -> IO [Integer]
heterogeinity' corpus_id limit x = do
t <- getAbstract corpus_id limit
Prelude.mapM (dicoStruct . occurrences) $ (S.chunksOf x) . cleanText $ concat t
heterogeinity'' :: Int -> Int -> Int -> IO [Integer]
heterogeinity'' corpus_id limit size = do
t <- getAbstract corpus_id limit
Prelude.mapM (dicoStruct . occurrences) $ (S.chunksOf size) . cleanText $ concat t
dicoStruct :: (Integral r, Monad m) => M.Map t r -> m r
dicoStruct dict_occ = do
let keys_size = toInteger $ length $ M.keys dict_occ
let total_occ = sum $ Prelude.map (\(x, y) -> y) $ M.toList dict_occ
pure $ div total_occ (fromIntegral keys_size)
-- heterogeinity sur UCT (Unité de Context Textuel)
heterogeinity :: [Char] -> IO Integer
heterogeinity string = do
let dict_occ = occurrences $ cleanText string
let keys_size = toInteger $ length $ M.keys dict_occ
let total_occ = sum $ Prelude.map (\(x, y) -> y) $ M.toList dict_occ
pure $ div total_occ (fromIntegral keys_size)
--computeHeterogeinity
-- :: Fractional t =>
-- Opaleye.Internal.Column.Column Opaleye.PGTypes.PGInt4
-- -> IO (t, Integer, Integer)
computeHeterogeinity corpus_id = do
c <- PGS.connect infoGargandb
t <- getText c (nodeHyperdataText corpus_id)
heterogeinity $ Prelude.concat t
main2 = do
let corpus_ids = [
("ALL", 272927) -- 73
,("Histoire", 1387736) -- 28
,("Sciences Po", 1296892) -- 37
,("Phylosophie", 1170004) -- 20
,("Psychologie", 1345852) -- 37
,("Sociologie", 1246452) -- 42
]
r <- Prelude.map computeHeterogeinity $ Prelude.map (\(t,id) -> id) corpus_ids
pure r
src/Gargantext/Core/Text/Ngrams.hs
View file @ 7056810c
......@@ -8,7 +8,6 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
......
src/Gargantext/Core/Text/Search.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.Search
Description : All parsers of Gargantext in one file.
Copyright : (c) CNRS, 2017 - present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
This search Engine is first made to clean TSV file according to a query.
Starting from this model, a specific Gargantext engine will be made
(using more metrics scores/features).
-}
module Gargantext.Core.Text.Search where
import Data.Ix
import Data.SearchEngine
import Gargantext.Core.Text.Corpus.Parsers.TSV
import Gargantext.Core.Text.Terms.Mono (monoTexts)
import Gargantext.Core.Text.Terms.Mono.Stem as ST
import Gargantext.Prelude
-- Usefull to use stopwords
-- import Data.Set (Set)
-- import qualified Data.Set as Set
type DocId = Int
type DocSearchEngine = SearchEngine
TsvGargV3
DocId
DocField
NoFeatures
data DocField = TitleField
| AbstractField
deriving (Eq, Ord, Enum, Bounded, Ix, Show)
initialDocSearchEngine :: DocSearchEngine
initialDocSearchEngine =
initSearchEngine docSearchConfig defaultSearchRankParameters
docSearchConfig :: SearchConfig TsvGargV3 DocId DocField NoFeatures
docSearchConfig =
SearchConfig {
documentKey = d_docId,
extractDocumentTerms = extractTerms,
transformQueryTerm = normaliseQueryToken,
documentFeatureValue = const noFeatures
}
where
extractTerms :: TsvGargV3 -> DocField -> [Text]
extractTerms doc TitleField = monoTexts (d_title doc)
extractTerms doc AbstractField = monoTexts (d_abstract doc)
normaliseQueryToken :: Text -> DocField -> Text
normaliseQueryToken tok =
let tokStem = ST.stem ST.EN ST.PorterAlgorithm
in \field -> case field of
TitleField -> tokStem tok
AbstractField -> tokStem tok
defaultSearchRankParameters :: SearchRankParameters DocField NoFeatures
defaultSearchRankParameters =
SearchRankParameters {
paramK1,
paramB,
paramFieldWeights,
paramFeatureWeights = noFeatures,
paramFeatureFunctions = noFeatures,
paramResultsetSoftLimit = 2000,
paramResultsetHardLimit = 4000,
paramAutosuggestPrefilterLimit = 500,
paramAutosuggestPostfilterLimit = 500
}
where
paramK1 :: Float
paramK1 = 1.5
paramB :: DocField -> Float
paramB TitleField = 0.9
paramB AbstractField = 0.5
paramFieldWeights :: DocField -> Float
paramFieldWeights TitleField = 20
paramFieldWeights AbstractField = 5
src/Gargantext/Core/Text/Terms/Mono/Token.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Text.Ngrams.Token
Description : Tokens and tokenizing a text
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
In computer science, lexical analysis, lexing or tokenization is the
process of converting a sequence of characters (such as in a computer
program or web page) into a sequence of tokens (strings with an assigned
and thus identified meaning).
Source: https://en.wikipedia.org/wiki/Tokenize
-}
module Gargantext.Core.Text.Terms.Mono.Token (tokenize)
where
import Data.Text (Text)
import qualified Gargantext.Core.Text.Terms.Mono.Token.En as En
-- | Contexts depend on the lang
--import Gargantext.Core (Lang(..))
type Token = Text
-- >>> tokenize "A rose is a rose is a rose."
-- ["A","rose","is","a","rose","is","a","rose", "."]
tokenize :: Text -> [Token]
tokenize = En.tokenize
--data Context = Letter | Word | Sentence | Line | Paragraph
--
--tokenize' :: Lang -> Context -> [Token]
--tokenize' = undefined
--
src/Gargantext/Core/Text/Terms/Multi.hs
View file @ 7056810c
......@@ -11,10 +11,10 @@ Multi-terms are ngrams where n > 1.
-}
module Gargantext.Core.Text.Terms.Multi (multiterms, multiterms_rake, tokenTagsWith, tokenTags, cleanTextForNLP)
module Gargantext.Core.Text.Terms.Multi (multiterms, Terms(..), tokenTag2terms, multiterms_rake, tokenTagsWith, tokenTags, cleanTextForNLP)
where
import Data.Attoparsec.Text as DAT ( digit, space, notChar, string )
import Data.Attoparsec.Text as DAT (space, notChar, string )
import Gargantext.Core (Lang(..), NLPServerConfig(..), PosTagAlgo(..))
import Gargantext.Core.Text.Terms.Multi.Lang.En qualified as En
import Gargantext.Core.Text.Terms.Multi.Lang.Fr qualified as Fr
......@@ -82,12 +82,10 @@ groupTokens _ = Fr.groupTokens
-- TODO: make tests here
cleanTextForNLP :: Text -> Text
cleanTextForNLP = unifySpaces . removeDigitsWith "-" . removeUrls
cleanTextForNLP = unifySpaces . removeUrls
where
remove x = RAT.streamEdit x (const "")
unifySpaces = RAT.streamEdit (many DAT.space) (const " ")
removeDigitsWith x = remove (many DAT.digit *> DAT.string x <* many DAT.digit)
removeUrls = removeUrlsWith "http" . removeUrlsWith "www"
removeUrlsWith w = remove (DAT.string w *> many (DAT.notChar ' ') <* many DAT.space)
src/Gargantext/Core/Text/Terms/Multi/PosTagging.hs
View file @ 7056810c
......@@ -82,7 +82,7 @@ corenlp' :: ( FromJSON a
=> URI -> Lang -> p -> IO (Response a)
corenlp' uri lang txt = do
req <- parseRequest $
"POST " <> show (uri { uriQuery = "?properties=" <> (BSL.unpack $ encode $ toJSON $ Map.fromList properties) })
"POST " <> show (uri { uriQuery = "?properties=" <> BSL.unpack (encode $ toJSON $ Map.fromList properties) })
-- curl -XPOST 'http://localhost:9000/?properties=%7B%22annotators%22:%20%22tokenize,ssplit,pos,ner%22,%20%22outputFormat%22:%20%22json%22%7D' -d 'hello world, hello' | jq .
-- printDebug "[corenlp] sending body" $ (cs txt :: ByteString)
catch (httpJSON $ setRequestBodyLBS (cs txt) req) $ \e ->
......@@ -97,7 +97,7 @@ corenlp' uri lang txt = do
properties_ :: [(Text, Text)]
properties_ = case lang of
-- TODO: Add: Aeson.encode $ Aeson.toJSON $ Map.fromList [()] instead of these hardcoded JSON strings
EN -> [ ("annotators", "tokenize,ssplit,pos,ner" ) ]
EN -> [ ("annotators", "tokenize,ssplit,pos,ner" ), ("tokenize.options", "splitHyphenated=false") ]
FR -> [ ("annotators", "tokenize,ssplit,pos,lemma,ner")
-- , ("parse.model", "edu/stanford/nlp/models/lexparser/frenchFactored.ser.gz")
, ("pos.model", "edu/stanford/nlp/models/pos-tagger/models/french.tagger")
......
src/Gargantext/Core/Text/Upload.hs deleted 100644 → 0
View file @ 0d0b33f0
{-# LANGUAGE TypeOperators #-}
module Gargantext.Core.Text.Upload
( Host(..)
, DocId(..)
, Data(..)
, ContentType (..)
, ethercalc
, codimd
)
where
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Gargantext.Utils.Servant (TSV, Markdown)
import Network.HTTP.Client (newManager, Request(..))
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Protolude
import Servant.API
import Servant.Client
newtype Host = Host { fromHost :: Text }
newtype DocId = DocId { fromDocId :: Text }
newtype Data = Data { fromData :: Text }
data ContentType a =
CTPlain a
| CTTSV a
-- TODO SocialCalc, Excel XML ?
instance MimeRender TSV Data where
mimeRender p (Data d) = mimeRender p d
instance MimeRender PlainText Data where
mimeRender p (Data d) = mimeRender p d
instance ToHttpApiData DocId where
toUrlPiece (DocId docId) = docId
-- https://github.com/audreyt/ethercalc/blob/master/API.md
type EthercalcAPI =
"_" :> (
-- plain text
ReqBody '[PlainText] Data
:> Post '[PlainText] Text
:<|>
Capture "docId" DocId
:> ReqBody '[PlainText] Data
:> Put '[PlainText] Text
-- tsv
:<|>
ReqBody '[TSV] Data
:> Post '[PlainText, TSV] Text
:<|>
Capture "docId" DocId
:> ReqBody '[TSV] Data
:> Put '[PlainText, TSV] Text
)
ethercalcAPI :: Proxy EthercalcAPI
ethercalcAPI = Proxy
ethercalcNewPlain :: Data -> ClientM Text
ethercalcUpdatePlain :: DocId -> Data -> ClientM Text
ethercalcNewTSV :: Data -> ClientM Text
ethercalcUpdateTSV :: DocId -> Data -> ClientM Text
ethercalcNewPlain :<|> ethercalcUpdatePlain
:<|> ethercalcNewTSV :<|> ethercalcUpdateTSV = client ethercalcAPI
------------------------------
-- | Create new or update existing Ethercalc document (depending on
-- `Maybe DocId` constructor). `Data` can be in various formats (TSV,
-- etc).
ethercalc :: Host -> Maybe DocId -> ContentType Data -> IO (Either ClientError Text)
ethercalc (Host host) mDocId ctD = do
manager' <- newManager tlsManagerSettings
let env = mkClientEnv manager' (BaseUrl Https (T.unpack host) 443 "")
case (mDocId, ctD) of
(Nothing, CTPlain d) -> runClientM (ethercalcNewPlain d) env
(Nothing, CTTSV d) -> runClientM (ethercalcNewTSV d) env
(Just docId, CTPlain d) -> runClientM (ethercalcUpdatePlain docId d) env
(Just docId, CTTSV d) -> runClientM (ethercalcUpdateTSV docId d) env
-----------------------------------
type CodiMDAPI =
"new" :> (
ReqBody '[Markdown] Data
:> Post '[Markdown] Text
)
instance MimeRender Markdown Data where
mimeRender p (Data d) = mimeRender p d
codimdAPI :: Proxy CodiMDAPI
codimdAPI = Proxy
codimdAPINew :: Data -> ClientM Text
codimdAPINew = client codimdAPI
-- | Create a new CodiMD document (with Markdown contents). Please
-- note that AFAIK CodiMD update is not supported, see
-- https://github.com/hackmdio/codimd/issues/1013
codimd :: Host -> Data -> IO (Either Text Text)
codimd (Host host) d = do
manager' <- newManager tlsManagerSettings
let env' = mkClientEnv manager' (BaseUrl Https (T.unpack host) 443 "")
let env = env' { makeClientRequest = \burl req -> (defaultMakeClientRequest burl req) { redirectCount = 0 } }
eRes <- runClientM (codimdAPINew d) env
pure $ case eRes of
-- NOTE We actually expect a redirect here (a 302 with the new
-- page's URL). Hence we expect a `Left FailureResponse` because
-- we have set `redirectCount = 0` above.
Left (FailureResponse _req (Response { responseHeaders })) ->
case Map.lookup "location" (Map.fromList $ toList responseHeaders) of
Nothing -> Left "Cannot find 'Location' header in response"
Just loc -> Right $ TE.decodeUtf8 loc
err -> Left $ "Error creating codimd document: " <> show err
src/Gargantext/Core/Utils/Count.purs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Utils.Count
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Here is a longer description of this module, containing some
commentary with @some markup@.
Inspired from Gabriel Gonzales, "beautiful folds" talk.
-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE BangPatterns #-}
module Gargantext.Core.Utils.Count (head, last, all, any, sum, product, length)
where
import Data.Functor
import Control.Applicative
import qualified Data.Foldable
import Data.Monoid
import Control.Lens (Getting, foldMapOf)
import Gargantext.Prelude hiding (head, sum, length)
data Fold i o = forall m . Monoid m => Fold (i -> m) (m -> o)
instance Functor (Fold i) where
fmap k (Fold tally summarize) = Fold tally (k . summarize)
instance Applicative (Fold i) where
pure o = Fold (\_ -> ()) (\_ -> o)
Fold tallyF summarizeF <*> Fold tallyX summarizeX = Fold tally summarize
where
tally i = (tallyF i, tallyX i)
summarize (nF, nX) = summarizeF nF (summarizeX nX)
focus :: (forall m . Monoid m => Getting m b a) -> Fold a o -> Fold b o
focus lens (Fold tally summarize) = Fold (foldMapOf lens tally) summarize
fold :: Fold i o -> [i] -> o
fold (Fold tally summarize) is = summarize (reduce (map tally is))
where
reduce = Data.Foldable.foldl' (<>) mempty
--
head :: Fold a (Maybe a)
head = Fold (First . Just) getFirst
last :: Fold a (Maybe a)
last = Fold (Last . Just) getLast
--
all :: (a -> Bool) -> Fold a Bool
all predicate = Fold (All . predicate) getAll
any :: (a -> Bool) -> Fold a Bool
any predicate = Fold (Any . predicate) getAny
--
sum :: Num n => Fold n n
sum = Fold Sum getSum
product :: Num n => Fold n n
product = Fold Product getProduct
length :: Num n => Fold i n
length = Fold (\_ -> Sum 1) getSum
-- | Average function optimized (/!\ need to test it)
data Average a = Average { numerator :: !a, denominator :: !Int }
instance Num a => Monoid (Average a) where
mempty = Average 0 0
mappend (Average xL nL) (Average xR nR) = Average (xL + xR) (nL + nR)
average :: Fractional a => Fold a a
average = Fold tally summarize
where
tally x = Average x 1
summarize (Average numerator denominator) =
numerator / fromIntegral denominator
src/Gargantext/Core/Viz/Graph.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Core.Viz.Graph
Description : Graph utils
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.Core.Viz.Graph
where
import Data.Aeson qualified as DA
import Data.ByteString.Lazy as DBL (readFile, writeFile)
import Data.HashMap.Strict (HashMap, lookup)
import Data.Text qualified as Text
import Gargantext.API.Ngrams.Types (NgramsTerm(..), NgramsRepoElement(..), mSetToList)
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Core.Viz.Graph.Types
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Prelude
import Text.Read qualified as Text
-----------------------------------------------------------
graphV3ToGraph :: GraphV3 -> Graph
graphV3ToGraph (GraphV3 links nodes) = Graph { _graph_nodes = map nodeV32node nodes
, _graph_edges = zipWith linkV32edge [1..] links
, _graph_metadata = Nothing }
where
nodeV32node :: NodeV3 -> Node
nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
= Node { node_size = no_s'
, node_type = NgramsTerms
, node_id = show no_id'
, node_label = no_lb'
, node_x_coord = 0
, node_y_coord = 0
, node_attributes = Attributes cl'
, node_children = []
}
linkV32edge :: Int -> EdgeV3 -> Edge
linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') =
Edge { edge_source = show eo_s'
, edge_hidden = Just False
, edge_target = show eo_t'
, edge_weight = (Text.read $ Text.unpack eo_w') :: Double
, edge_confluence = 0.5
, edge_id = show n }
graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
graphV3ToGraphWithFiles g1 g2 = do
-- GraphV3 <- IO Fichier
graph <- DBL.readFile g1
let newGraph = case DA.decode graph :: Maybe GraphV3 of
Nothing -> panicTrace "no graph"
Just new -> new
DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
readGraphFromJson fp = do
graph <- liftBase $ DBL.readFile fp
pure $ DA.decode graph
-----------------------------------------------------------
mergeGraphNgrams :: Graph -> Maybe (HashMap NgramsTerm NgramsRepoElement) -> Graph
mergeGraphNgrams g Nothing = g
mergeGraphNgrams graph@(Graph { _graph_nodes }) (Just listNgrams) = set graph_nodes newNodes graph
where
newNodes = insertChildren <$> _graph_nodes
insertChildren (Node { node_label, .. }) = Node { node_children = children', .. }
where
-- lookup (NgramsTerm node_label) in listNgrams, then fetch (NgramsRepoElement _nre_children)
children' = case (lookup (NgramsTerm node_label) listNgrams) of
Nothing -> []
Just (NgramsRepoElement { _nre_children }) -> unNgramsTerm <$> mSetToList _nre_children
src/Gargantext/Database/Action/Flow/Utils.hs
View file @ 7056810c
......@@ -9,8 +9,6 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Action.Flow.Utils
( docNgrams
, documentIdWithNgrams
......
src/Gargantext/Database/Action/Metrics/Lists.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Lists
Description : Main requests of Node to the database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Action.Metrics.Lists
where
-- import Gargantext.API.Ngrams.Types (TabType(..))
-- import Gargantext.Core.Text.Metrics (Scored(..))
-- import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
-- import Gargantext.Core.Types.Query (Limit)
-- import Gargantext.Database.Action.Flow.Types (FlowCmdM)
-- import Gargantext.Prelude hiding (sum, head)
-- import Prelude hiding (null, id, map, sum)
-- import qualified Data.HashMap.Strict as HashMap
-- import qualified Data.Map.Strict as Map
-- import qualified Data.Vector as Vec
-- import qualified Gargantext.Database.Action.Metrics as Metrics
{-
trainModel :: FlowCmdM env ServantErr m
=> Username -> m Score
trainModel u = do
rootId <- _node_id <$> getRoot u
(id:ids) <- getCorporaWithParentId rootId
(s,_model) <- case length ids >0 of
True -> grid 100 150 (getMetrics
False -> panic "Gargantext.Database.Lists.trainModel : not enough corpora"
--}
-- getMetrics' :: FlowCmdM env err m
-- => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-- -> m (Map.Map ListType [Vec.Vector Double])
-- getMetrics' cId maybeListId tabType maybeLimit = do
-- (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
-- let
-- metrics = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores
-- listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
-- errorMsg = "API.Node.metrics: key absent"
-- {-
-- _ <- Learn.grid 100 110 metrics' metrics'
-- --}
-- pure $ Map.fromListWith (<>) $ Vec.toList metrics
src/Gargantext/Database/Action/Metrics/NgramsByContext.hs
View file @ 7056810c
......@@ -97,7 +97,7 @@ getTreeInstitutesUser :: HasDBid NodeType
-> NgramsType
-> DBCmd err (HashMap Text [Text])
getTreeInstitutesUser cId nt =
HM.unionsWith (++) . map (\(_, hd) -> HM.fromList $ map (\(p, c) -> (p, [c])) $ Map.toList $ fromMaybe Map.empty (_hd_institutes_tree hd)) <$> selectHyperDataByContextUser cId nt
HM.unionsWith (++) . map (\(_, hd) -> HM.fromList $ Map.toList $ fromMaybe Map.empty (_hd_institutes_tree hd)) <$> selectHyperDataByContextUser cId nt
selectHyperDataByContextUser :: HasDBid NodeType
=> CorpusId
......
src/Gargantext/Database/Action/Node.hs
View file @ 7056810c
......@@ -8,9 +8,6 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
......
src/Gargantext/Database/Action/TSQuery.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Action.TSQuery
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Here is a longer description of this module, containing some
commentary with @some markup@.
-}
module Gargantext.Database.Action.TSQuery where
import Data.Aeson
import Data.Maybe
import Data.String (IsString(..))
import Database.PostgreSQL.Simple (Query)
import Database.PostgreSQL.Simple.ToField
import Gargantext.Core
import Gargantext.Core.Text.Terms.Mono.Stem (stem, StemmingAlgorithm(..))
import Gargantext.Core.Types
import Gargantext.Core.Types.Query (Limit, Offset)
import Gargantext.Database.Prelude (DBCmd, runPGSQuery)
import Gargantext.Prelude
newtype TSQuery = UnsafeTSQuery [Text]
-- | TODO [""] -> panic "error"
toTSQuery :: [Text] -> TSQuery
toTSQuery txt = UnsafeTSQuery $ map (stem EN GargPorterAlgorithm) txt
instance IsString TSQuery
where
fromString = UnsafeTSQuery . words . cs
instance ToField TSQuery
where
toField (UnsafeTSQuery xs)
= Many $ intersperse (Plain " && ")
$ map (\q -> Many [ Plain "plainto_tsquery("
, Escape (cs q)
, Plain ")"
]
) xs
data Order = Asc | Desc
instance ToField Order
where
toField Asc = Plain "ASC"
toField Desc = Plain "DESC"
-- TODO
-- FIX fav
-- ADD ngrams count
-- TESTS
textSearchQuery :: Query
textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \
\ , n.hyperdata->'title' \
\ , n.hyperdata->'source' \
\ , n.hyperdata->'authors' \
\ , COALESCE(nn.score,null) \
\ FROM nodes n \
\ LEFT JOIN nodes_nodes nn ON nn.node2_id = n.id \
\ WHERE \
\ n.search @@ (?::tsquery) \
\ AND (n.parent_id = ? OR nn.node1_id = ?) \
\ AND n.typename = ? \
\ ORDER BY n.hyperdata -> 'publication_date' ? \
\ offset ? limit ?;"
-- | Text Search Function for Master Corpus
-- TODO : text search for user corpus
-- Example:
-- textSearchTest :: ParentId -> TSQuery -> Cmd err [(Int, Value, Value, Value, Value, Maybe Int)]
-- textSearchTest pId q = textSearch q pId 5 0 Asc
textSearch :: HasDBid NodeType
=> TSQuery -> ParentId
-> Limit -> Offset -> Order
-> DBCmd err [(Int,Value,Value,Value, Value, Maybe Int)]
textSearch q p l o ord' = runPGSQuery textSearchQuery (q,p,p,typeId,ord',o,l)
where
typeId = toDBid NodeDocument
src/Gargantext/Database/Admin/Bashql.hs deleted 100644 → 0
View file @ 0d0b33f0
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.Database.Bashql
Description : BASHQL to deal with Gargantext Database.
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
* BASHQL is a Domain Specific Language to deal with the Database
* BASHQL = functional (Bash * SQL)
* Which language to chose when working with a database ? To make it
simple, instead of all common Object Relational Mapping (ORM) [1]
strategy used nowadays inspired more by object logic than functional
logic, the semantics of BASHQL with focus on the function first.
* BASHQL focus on the function, i.e. use bash language function name,
and make it with SQL behind the scene. Then BASHQL is inspired more
by Bash language [2] than SQL and then follows its main commands as
specification and documentation.
* Main arguments:
1. Theoritical: database and FileSystems are each thought as a single
category, assumption based on theoretical work on databases by David Spivak [0].
2. Practical argument: basic bash commands are a daily practice among
developper community.
* How to help ?
1. Choose a command you like in Bash
2. Implement it in Haskell-SQL according to Gargantext Shema (Tree like
filesystem)
3. Translate it in BASHQL (follow previous implementations)
4. Make a pull request (enjoy the community)
* Implementation strategy: Functional adapations are made to the
gargantext languages options and SQL optimization are done continuously
during the project. For the Haskellish part, you may be inspired by
Turtle implementation written by Gabriel Gonzales [3] which shows how to
write Haskell bash translations.
* Semantics
- FileSystem is now a NodeSystem where each File is a Node in a Directed Graph (DG).
* References
[0] MIT Press has published "Category theory for the sciences". The book
can also be purchased on Amazon. Here are reviews by the MAA, by the
AMS, and by SIAM.
[1] https://en.wikipedia.org/wiki/Object-relational_mapping
[2] https://en.wikipedia.org/wiki/Bash_(Unix_shell)
[3] https://github.com/Gabriel439/Haskell-Turtle-Library
TODO-ACCESS: should the checks be done here or before.
-}
module Gargantext.Database.Admin.Bashql () {-( get
, ls
, home
, post
, del
, mv
, put
, rename
, tree
-- , mkCorpus, mkAnnuaire
)-}
where
import Control.Monad.Reader -- (Reader, ask)
import Data.List (last)
import Gargantext.Core.Types
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny)
import Gargantext.Database.Prelude (runOpaQuery, Cmd)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Update qualified as U (Update(..), update)
import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (get)
-- List of NodeId
-- type PWD a = PWD UserId [a]
type PWD = [NodeId]
--data PWD' a = a | PWD' [a]
rename :: NodeId -> Text -> Cmd err [Int]
rename n t = U.update $ U.Rename n t
mv :: NodeId -> ParentId -> Cmd err [Int]
mv n p = U.update $ U.Move n p
-- | TODO get Children or Node
get :: PWD -> Cmd err [Node HyperdataAny]
get [] = pure []
get pwd = runOpaQuery $ selectNodesWithParentID (last pwd)
-- | Home, need to filter with UserId
{-
home :: Cmd err PWD
home = map _node_id <$> getNodesWithParentId 0 Nothing
-}
-- | ls == get Children
ls :: PWD -> Cmd err [Node HyperdataAny]
ls = get
tree :: PWD -> Cmd err [Node HyperdataAny]
tree p = do
ns <- get p
children <- mapM (\n -> get [_node_id n]) ns
pure $ ns <> concat children
-- | TODO
post :: PWD -> [NodeWrite] -> Cmd err Int64
post [] _ = pure 0
post _ [] = pure 0
post pth ns = insertNodesWithParent (Just $ last pth) ns
--postR :: PWD -> [NodeWrite'] -> Cmd err [Int]
--postR [] _ _ = pure [0]
--postR _ [] _ = pure [0]
--postR pth ns c = mkNodeR (last pth) ns c
-- | WIP
-- rm : mv to trash
-- del : empty trash
--rm :: PWD -> [NodeId] -> IO Int
--rm = del
del :: [NodeId] -> Cmd err Int
del [] = pure 0
del ns = deleteNodes ns
-- | TODO
put :: U.Update -> Cmd err [Int]
put = U.update
-- | TODO
-- cd (Home UserId) | (Node NodeId)
-- cd Path
-- jump NodeId
-- touch Dir
-- type Name = Text
src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
View file @ 7056810c
......@@ -36,7 +36,7 @@ data HyperdataDocument = HyperdataDocument { _hd_bdd :: !(Maybe T
, _hd_publication_minute :: !(Maybe Int)
, _hd_publication_second :: !(Maybe Int)
, _hd_language_iso2 :: !(Maybe Text)
, _hd_institutes_tree :: !(Maybe (Map Text Text))
, _hd_institutes_tree :: !(Maybe (Map Text [Text]))
}
deriving (Show, Generic)
......
src/Gargantext/Database/Query/Filter.hs
View file @ 7056810c
......@@ -8,10 +8,6 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Query.Filter
where
......
src/Gargantext/Database/Query/Join.hs
View file @ 7056810c
......@@ -11,9 +11,6 @@ Multiple Join functions with Opaleye.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
......
src/Gargantext/Database/Query/Table/Context.hs
View file @ 7056810c
......@@ -8,11 +8,9 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Gargantext.Database.Query.Table.Context
where
......
src/Gargantext/Database/Query/Table/ContextNodeNgrams.hs
View file @ 7056810c
......@@ -9,9 +9,6 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Query.Table.ContextNodeNgrams
( module Gargantext.Database.Schema.ContextNodeNgrams
, queryContextNodeNgramsTable
......
src/Gargantext/Database/Query/Table/ContextNodeNgrams2.hs
View file @ 7056810c
......@@ -9,8 +9,6 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Query.Table.ContextNodeNgrams2
( module Gargantext.Database.Schema.ContextNodeNgrams2
, insertContextNodeNgrams2
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ 7056810c
......@@ -8,8 +8,6 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
......
src/Gargantext/Database/Query/Table/Node/Children.hs
View file @ 7056810c
......@@ -8,9 +8,7 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE Arrows #-}
module Gargantext.Database.Query.Table.Node.Children
where
......
src/Gargantext/Database/Query/Table/NodeContext.hs
View file @ 7056810c
......@@ -11,8 +11,6 @@ Here is a longer description of this module, containing some
commentary with @some markup@.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
......
src/Gargantext/Database/Query/Table/NodeNode.hs
View file @ 7056810c
......@@ -10,8 +10,6 @@ Here is a longer description of this module, containing some
commentary with @some markup@.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
......
src/Gargantext/Database/Query/Table/NodeNodeNgrams.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Schema.NodeNodeNgrams
Description : TODO: remove this module and table in database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Query.Table.NodeNodeNgrams
( module Gargantext.Database.Schema.NodeNodeNgrams
, queryNodeNodeNgramsTable
, insertNodeNodeNgrams
)
where
import Gargantext.Database.Admin.Types.Node (pgNodeId)
import Gargantext.Database.Prelude (DBCmd, mkCmd)
import Gargantext.Database.Schema.Ngrams (pgNgramsTypeId)
import Gargantext.Database.Schema.NodeNodeNgrams
import Gargantext.Database.Schema.Prelude
import Prelude
queryNodeNodeNgramsTable :: Query NodeNodeNgramsRead
queryNodeNodeNgramsTable = selectTable nodeNodeNgramsTable
-- | Insert utils
insertNodeNodeNgrams :: [NodeNodeNgrams] -> DBCmd err Int
insertNodeNodeNgrams = insertNodeNodeNgramsW
. map (\(NodeNodeNgrams n1 n2 ng nt w) ->
NodeNodeNgrams (pgNodeId n1)
(pgNodeId n2)
(sqlInt4 ng)
(pgNgramsTypeId nt)
(sqlDouble w)
)
insertNodeNodeNgramsW :: [NodeNodeNgramsWrite] -> DBCmd err Int
insertNodeNodeNgramsW nnnw =
mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
where
insertNothing = (Insert { iTable = nodeNodeNgramsTable
, iRows = nnnw
, iReturning = rCount
, iOnConflict = (Just DoNothing)
})
src/Gargantext/Database/Query/Table/Node_NodeNgramsNodeNgrams.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Schema.Node_NodeNgrams_NodeNgrams
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
lgrams: listed ngrams
Node_NodeNgrams_NodeNgrams table is used to group ngrams
- first NodeId :: Referential / space node (corpus)
- NodeNgrams where Node is List
- lgrams1_id, lgrams2_id where all lgrams2_id will be added to lgrams1_id
- weight: score the relation
Next Step benchmark:
- recursive queries of postgres
- group with: https://en.wikipedia.org/wiki/Nested_set_model
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
where
{-
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Prelude (Cmd, runOpaQuery, mkCmd)
import Gargantext.Database.Admin.Types.Node (pgNodeId)
import Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams
import Gargantext.Database.Schema.Node()
import Gargantext.Prelude
queryNode_NodeNgrams_NodeNgrams_Table :: Query Node_NodeNgrams_NodeNgrams_Read
queryNode_NodeNgrams_NodeNgrams_Table = selectTable node_NodeNgrams_NodeNgrams_Table
-- | Select NodeNgramsNgrams
-- TODO not optimized (get all ngrams without filters)
_node_Node_NodeNgrams_NodeNgrams :: Cmd err [Node_NodeNgrams_NodeNgrams]
_node_Node_NodeNgrams_NodeNgrams = runOpaQuery queryNode_NodeNgrams_NodeNgrams_Table
-- TODO: Add option on conflict
insert_Node_NodeNgrams_NodeNgrams :: [Node_NodeNgrams_NodeNgrams] -> Cmd err Int64
insert_Node_NodeNgrams_NodeNgrams = insert_Node_NodeNgrams_NodeNgrams_W
. map (\(Node_NodeNgrams_NodeNgrams n ng1 ng2 maybeWeight) ->
Node_NodeNgrams_NodeNgrams (pgNodeId n )
(sqlInt4 <$> ng1)
(sqlInt4 ng2)
(sqlDouble <$> maybeWeight)
)
insert_Node_NodeNgrams_NodeNgrams_W :: [Node_NodeNgrams_NodeNgrams_Write] -> Cmd err Int64
insert_Node_NodeNgrams_NodeNgrams_W ns =
mkCmd $ \c -> runInsert_ c Insert { iTable = node_NodeNgrams_NodeNgrams_Table
, iRows = ns
, iReturning = rCount
, iOnConflict = (Just DoNothing)
}
-}
src/Gargantext/Database/Query/Table/NodesNgramsRepo.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Schema.NodesNgramsRepo
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Query.Table.NodesNgramsRepo
where
{-
import Gargantext.Database.Schema.Prelude
import Gargantext.API.Ngrams (NgramsStatePatch)
import Gargantext.Database.Schema.NodesNgramsRepo
import Gargantext.Database.Prelude (mkCmd, Cmd, runOpaQuery)
import Gargantext.Prelude
selectPatches :: Query RepoDbRead
selectPatches = proc () -> do
repos <- selectTable repoTable -< ()
returnA -< repos
_selectRepo :: Cmd err [RepoDbNgrams]
_selectRepo = runOpaQuery selectPatches
_insertRepos :: [NgramsStatePatch] -> Cmd err Int64
_insertRepos ns = mkCmd $ \conn -> runInsert_ conn $ Insert repoTable (toWrite ns) rCount Nothing
where
toWrite :: [NgramsStatePatch] -> [RepoDbWrite]
toWrite = undefined
--ns' = map (\(RepoDbNgrams v ps) -> RepoDbWrite (sqlInt4 v) (pgJSONB ps)) ns
-}
src/Gargantext/Database/Schema/Context.hs
View file @ 7056810c
......@@ -8,8 +8,6 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
......
src/Gargantext/Database/Schema/ContextNodeNgrams.hs
View file @ 7056810c
......@@ -9,8 +9,6 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
......
src/Gargantext/Database/Schema/ContextNodeNgrams2.hs
View file @ 7056810c
......@@ -9,8 +9,6 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
......
src/Gargantext/Database/Schema/NgramsPostag.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Schema.NgramsPostag
Description : Ngrams connection to the Database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Each Ngrams has a pos-tagging version to ease the default groups of
ngrams in NgramsTerm Lists.
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NgramsPostag
where
import Database.PostgreSQL.Simple qualified as PGS
import Gargantext.Database.Schema.Prelude ( Column, SqlInt4, SqlText, ToField(toField), toRow )
import Gargantext.Prelude
data NgramsPostagPoly id
lang_id
algo_id
postag
ngrams_id
lemm_id
score
= NgramsPostagPoly { _ngramsPostag_id :: !id
, _ngramsPostag_lang_id :: !lang_id
, _ngramsPostag_algo_id :: !algo_id
, _ngramsPostag_postag :: !postag
, _ngramsPostag_ngrams_id :: !ngrams_id
, _ngramsPostag_lemm_id :: !lemm_id
, _ngramsPostag_score :: !score
} deriving (Show)
------------------------------------------------------------------------
data PosTag = PosTag { unPosTag :: !Text }
| NER { unNER :: !Text } -- TODO
------------------------------------------------------------------------
-- type NgramsPostag = NgramsPostagPoly (Maybe Int) Lang PostTagAlgo (Maybe PosTag) NgramsTerm NgramsTerm (Maybe Int)
type NgramsPostagDB = NgramsPostagPoly (Maybe Int) Int Int (Maybe Text) Int Int Int
------------------------------------------------------------------------
type NgramsPosTagWrite = NgramsPostagPoly (Maybe (Column SqlInt4))
(Column SqlInt4)
(Column SqlInt4)
(Maybe (Column SqlText))
(Column SqlInt4)
(Column SqlInt4)
(Maybe (Column SqlInt4))
type NgramsPosTagRead = NgramsPostagPoly (Column SqlInt4)
(Column SqlInt4)
(Column SqlInt4)
(Column SqlText)
(Column SqlInt4)
(Column SqlInt4)
(Column SqlInt4)
makeLenses ''NgramsPostagPoly
instance PGS.ToRow NgramsPostagDB where
toRow (NgramsPostagPoly f0 f1 f2 f3 f4 f5 f6) = [ toField f0
, toField f1
, toField f2
, toField f3
, toField f4
, toField f5
, toField f6
]
src/Gargantext/Database/Schema/Node.hs
View file @ 7056810c
......@@ -8,9 +8,6 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
......
src/Gargantext/Database/Schema/NodeContext.hs
View file @ 7056810c
......@@ -11,8 +11,6 @@ Here is a longer description of this module, containing some
commentary with @some markup@.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
......
src/Gargantext/Database/Schema/NodeContext_NodeContext.hs
View file @ 7056810c
......@@ -9,8 +9,6 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
......
src/Gargantext/Database/Schema/NodeNgrams.hs
View file @ 7056810c
......@@ -11,8 +11,6 @@ NodeNgrams register Context of Ngrams (named Cgrams then)
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
......
src/Gargantext/Database/Schema/NodeNodeNgrams.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Schema.NodeNodeNgrams
Description : TODO: remove this module and table in database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeNodeNgrams
where
import Prelude
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Schema.Ngrams (NgramsTypeId, NgramsId)
import Gargantext.Database.Admin.Types.Node
data NodeNodeNgramsPoly n1 n2 ngrams_id ngt w
= NodeNodeNgrams { _nnng_node1_id :: !n1
, _nnng_node2_id :: !n2
, _nnng_ngrams_id :: !ngrams_id
, _nnng_ngramsType :: !ngt
, _nnng_weight :: !w
} deriving (Show)
type NodeNodeNgramsWrite =
NodeNodeNgramsPoly (Column SqlInt4 )
(Column SqlInt4 )
(Column SqlInt4 )
(Column SqlInt4 )
(Column SqlFloat8)
type NodeNodeNgramsRead =
NodeNodeNgramsPoly (Column SqlInt4 )
(Column SqlInt4 )
(Column SqlInt4 )
(Column SqlInt4 )
(Column SqlFloat8)
type NodeNodeNgrams =
NodeNodeNgramsPoly CorpusId DocId NgramsId NgramsTypeId Double
$(makeAdaptorAndInstance "pNodeNodeNgrams" ''NodeNodeNgramsPoly)
makeLenses ''NodeNodeNgramsPoly
nodeNodeNgramsTable :: Table NodeNodeNgramsWrite NodeNodeNgramsRead
nodeNodeNgramsTable = Table "node_node_ngrams"
( pNodeNodeNgrams NodeNodeNgrams
{ _nnng_node1_id = requiredTableField "node1_id"
, _nnng_node2_id = requiredTableField "node2_id"
, _nnng_ngrams_id = requiredTableField "ngrams_id"
, _nnng_ngramsType = requiredTableField "ngrams_type"
, _nnng_weight = requiredTableField "weight"
}
)
src/Gargantext/Database/Schema/NodeNodeNgrams2.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Schema.NodeNodeNgrams
Description : TODO: remove this module and table in database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeNodeNgrams2
where
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Schema.NodeNgrams (NodeNgramsId)
import Gargantext.Database.Admin.Types.Node
import Prelude
data NodeNodeNgrams2Poly node_id nodengrams_id w
= NodeNodeNgrams2 { _nnng2_node_id :: !node_id
, _nnng2_nodengrams_id :: !nodengrams_id
, _nnng2_weight :: !w
} deriving (Show)
type NodeNodeNgrams2Write =
NodeNodeNgrams2Poly (Column SqlInt4 )
(Column SqlInt4 )
(Column SqlFloat8)
type NodeNodeNgrams2Read =
NodeNodeNgrams2Poly (Column SqlInt4 )
(Column SqlInt4 )
(Column SqlFloat8)
type NodeNodeNgrams2 =
NodeNodeNgrams2Poly DocId NodeNgramsId Double
$(makeAdaptorAndInstance "pNodeNodeNgrams2" ''NodeNodeNgrams2Poly)
makeLenses ''NodeNodeNgrams2Poly
nodeNodeNgrams2Table :: Table NodeNodeNgrams2Write NodeNodeNgrams2Read
nodeNodeNgrams2Table = Table "node_node_ngrams2"
( pNodeNodeNgrams2 NodeNodeNgrams2
{ _nnng2_node_id = requiredTableField "node_id"
, _nnng2_nodengrams_id = requiredTableField "nodengrams_id"
, _nnng2_weight = requiredTableField "weight"
}
)
src/Gargantext/Database/Schema/Node_NodeNgramsNodeNgrams.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Schema.Node_NodeNgrams_NodeNgrams
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
lgrams: listed ngrams
Node_NodeNgrams_NodeNgrams table is used to group ngrams
- first NodeId :: Referential / space node (corpus)
- NodeNgrams where Node is List
- lgrams1_id, lgrams2_id where all lgrams2_id will be added to lgrams1_id
- weight: score the relation
Next Step benchmark:
- recursive queries of postgres
- group with: https://en.wikipedia.org/wiki/Nested_set_model
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams
where
{-
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Admin.Types.Node (CorpusId)
import Gargantext.Database.Schema.Node()
import Gargantext.Prelude
data Node_NodeNgrams_NodeNgrams_Poly node_id nng1_id nng2_id weight =
Node_NodeNgrams_NodeNgrams { _nnn_node_id :: !node_id
, _nnn_nng1_id :: !nng1_id
, _nnn_nng2_id :: !nng2_id
, _nnn_weight :: !weight
} deriving (Show)
type Node_NodeNgrams_NodeNgrams_Write =
Node_NodeNgrams_NodeNgrams_Poly
(Column SqlInt4 )
(Maybe (Column SqlInt4 ))
(Column SqlInt4 )
(Maybe (Column SqlFloat8))
type Node_NodeNgrams_NodeNgrams_Read =
Node_NodeNgrams_NodeNgrams_Poly
(Column SqlInt4 )
(Column SqlInt4 )
(Column SqlInt4 )
(Column SqlFloat8)
type ListNgramsId = Int
type Node_NodeNgrams_NodeNgrams =
Node_NodeNgrams_NodeNgrams_Poly CorpusId (Maybe ListNgramsId) ListNgramsId (Maybe Double)
$(makeAdaptorAndInstance "pNode_NodeNgrams_NodeNgrams"
''Node_NodeNgrams_NodeNgrams_Poly)
$(makeLensesWith abbreviatedFields
''Node_NodeNgrams_NodeNgrams_Poly)
node_NodeNgrams_NodeNgrams_Table :: Table Node_NodeNgrams_NodeNgrams_Write Node_NodeNgrams_NodeNgrams_Read
node_NodeNgrams_NodeNgrams_Table =
Table "node_nodengrams_nodengrams"
( pNode_NodeNgrams_NodeNgrams Node_NodeNgrams_NodeNgrams
{ _nnn_node_id = requiredTableField "node_id"
, _nnn_nng1_id = optionalTableField "node_ngrams1_id"
, _nnn_nng2_id = requiredTableField "node_ngrams2_id"
, _nnn_weight = optionalTableField "weight"
}
)
instance DefaultFromField SqlInt4 (Maybe Int) where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlFloat8 (Maybe Double) where
defaultFromField = fromPGSFromField
-}
src/Gargantext/Database/Schema/NodesNgramsRepo.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Database.Schema.NodesNgramsRepo
Description : NodeNgram for Ngram indexation or Lists
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodesNgramsRepo
where
{-
import Data.Map.Strict.Patch (PatchMap)
import Gargantext.Database.Schema.Prelude
import Gargantext.API.Ngrams.Types (NgramsTablePatch)
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Prelude
data RepoDbPoly version patches
= RepoDbNgrams { _rdp_version :: !version
, _rdp_patches :: !patches
} deriving (Show)
type RepoDbWrite
= RepoDbPoly (Column SqlInt4)
(Column SqlJsonb)
type RepoDbRead
= RepoDbPoly (Column SqlInt4)
(Column SqlJsonb)
type RepoDbNgrams = RepoDbPoly Int NgramsStatePatch
$(makeAdaptorAndInstance "pRepoDbNgrams" ''RepoDbPoly)
makeLenses ''RepoDbPoly
instance DefaultFromField SqlJsonb
(PatchMap NgramsType
(PatchMap NodeId NgramsTablePatch))
where
defaultFromField = fromPGSFromField
repoTable :: Table RepoDbWrite RepoDbRead
repoTable = Table "nodes_ngrams_repo"
(pRepoDbNgrams RepoDbNgrams
{ _rdp_version = requiredTableField "version"
, _rdp_patches = requiredTableField "patches"
}
)
-}
src/Gargantext/Database/Schema/User.hs
View file @ 7056810c
......@@ -10,8 +10,6 @@ Portability : POSIX
Functions to deal with users, database side.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE DeriveAnyClass #-}
......
src/Gargantext/Utils/JohnSnowNLP.hs deleted 100644 → 0
View file @ 0d0b33f0
{-|
Module : Gargantext.Utils.JohnSnow
Description : John Snow NLP API connexion
Copyright : (c) CNRS, 2017
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Utils.JohnSnowNLP where
import Control.Lens ( FunctorWithIndex(imap) )
import Data.Aeson (encode, Value(..), (.:), (.:?))
import Data.Aeson.Types (prependFailure, typeMismatch)
import Data.List.Safe qualified as LS
import Data.Map.Strict qualified as Map
import Data.Text (unpack)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Terms.Multi.PosTagging.Types
import Gargantext.Core.Types (POS(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Prelude hiding (All)
import Network.HTTP.Simple (parseRequest, httpJSON, setRequestBodyLBS, getResponseBody, Response)
import Prelude (userError)
data JSSpell = JSPOS Lang | JSLemma Lang
deriving (Show)
instance ToJSON JSSpell where
toJSON (JSPOS DE) = "de.pos"
toJSON (JSPOS EL) = "el.pos"
toJSON (JSPOS EN) = "en.pos"
toJSON (JSPOS ES) = "es.pos"
toJSON (JSPOS FR) = "fr.pos"
toJSON (JSPOS IT) = "it.pos"
toJSON (JSPOS PL) = "pl.pos"
toJSON (JSPOS PT) = "pt.pos"
toJSON (JSPOS RU) = "ru.pos"
toJSON (JSPOS UK) = "uk.pos"
toJSON (JSPOS ZH) = "zh.pos"
toJSON (JSLemma DE) = "de.lemma"
toJSON (JSLemma EL) = "el.lemma"
toJSON (JSLemma EN) = "en.lemma"
toJSON (JSLemma ES) = "es.lemma"
toJSON (JSLemma FR) = "fr.lemma"
toJSON (JSLemma IT) = "it.lemma"
toJSON (JSLemma PL) = "pl.lemma"
toJSON (JSLemma PT) = "pt.lemma"
toJSON (JSLemma RU) = "ru.lemma"
toJSON (JSLemma UK) = "uk.lemma"
toJSON (JSLemma ZH) = "zh.lemma"
instance FromJSON JSSpell where
parseJSON (String "de.pos") = pure $ JSPOS DE
parseJSON (String "en.pos") = pure $ JSPOS EN
parseJSON (String "el.pos") = pure $ JSPOS EL
parseJSON (String "es.pos") = pure $ JSPOS ES
parseJSON (String "fr.pos") = pure $ JSPOS FR
parseJSON (String "it.pos") = pure $ JSPOS IT
parseJSON (String "pl.pos") = pure $ JSPOS PL
parseJSON (String "pt.pos") = pure $ JSPOS PT
parseJSON (String "ru.pos") = pure $ JSPOS RU
parseJSON (String "uk.pos") = pure $ JSPOS UK
parseJSON (String "zh.pos") = pure $ JSPOS ZH
parseJSON (String "de.lemma") = pure $ JSLemma DE
parseJSON (String "en.lemma") = pure $ JSLemma EN
parseJSON (String "el.lemma") = pure $ JSLemma EL
parseJSON (String "es.lemma") = pure $ JSLemma ES
parseJSON (String "fr.lemma") = pure $ JSLemma FR
parseJSON (String "it.lemma") = pure $ JSLemma IT
parseJSON (String "pl.lemma") = pure $ JSLemma PL
parseJSON (String "pt.lemma") = pure $ JSLemma PT
parseJSON (String "ru.lemma") = pure $ JSLemma RU
parseJSON (String "uk.lemma") = pure $ JSLemma UK
parseJSON (String "zh.lemma") = pure $ JSLemma ZH
parseJSON s =
prependFailure "parsing spell failed, "
(typeMismatch "Spell" s)
data JSRequest =
JSRequest { _jsRequest_data :: !Text
, _jsRequest_format :: !Text
, _jsRequest_grouping :: !(Maybe Text)
, _jsRequest_spell :: !JSSpell }
deriving (Show)
-- "spell" options:
-- https://nlu.johnsnowlabs.com/docs/en/spellbook
deriveJSON (unPrefix "_jsRequest_") ''JSRequest
-- | JohnSnow NLP works via asynchronous tasks: send a query and get a
-- task in response. One must poll for task status and then get it's
-- result.
data JSAsyncTask =
JSAsyncTask { _jsAsyncTask_uuid :: !Text }
deriving (Show)
deriveJSON (unPrefix "_jsAsyncTask_") ''JSAsyncTask
-- | Task status.
data JSAsyncTaskStatus =
JSAsyncTaskStatus { _jsAsyncTaskStatus_code :: !Text
, _jsAsyncTaskStatus_message :: !(Maybe Text) }
deriving (Show)
taskReady :: JSAsyncTaskStatus -> Bool
taskReady (JSAsyncTaskStatus { .. }) = _jsAsyncTaskStatus_code == "success"
--deriveJSON (unPrefix "_jsAsyncTaskStatus_") ''JSAsyncTaskStatus
instance FromJSON JSAsyncTaskStatus where
parseJSON (Object v) = do
status <- v .: "status"
code <- status .: "code"
message <- status .:? "message"
pure $ JSAsyncTaskStatus { _jsAsyncTaskStatus_code = code
, _jsAsyncTaskStatus_message = message }
parseJSON s =
prependFailure "parsing status failed"
(typeMismatch "status" s)
-- | Response for our query. The `Maybe` types are here because we
-- combine 2 types of responses into one: `pos` and `lemma`.
data JSAsyncTaskResponse =
JSAsyncTaskResponse { _jsAsyncTaskResponse_index :: Map Text Int
, _jsAsyncTaskResponse_document :: Map Text Text
, _jsAsyncTaskResponse_sentence :: Map Text [Text]
, _jsAsyncTaskResponse_lem :: Maybe (Map Text [Text])
, _jsAsyncTaskResponse_pos :: Maybe (Map Text [POS])
, _jsAsyncTaskResponse_token :: Map Text [Text] }
deriving (Show)
deriveJSON (unPrefix "_jsAsyncTaskResponse_") ''JSAsyncTaskResponse
makeLenses ''JSAsyncTaskResponse
-- | We need to combine 2 responses: `pos` and `lemma` spells.
jsAsyncTaskResponseToSentences :: JSAsyncTaskResponse -> JSAsyncTaskResponse -> PosSentences
jsAsyncTaskResponseToSentences jsPos jsLemma =
PosSentences { _sentences }
where
_sentences = Map.elems $ Map.mapWithKey mapSentence (jsPos ^. jsAsyncTaskResponse_sentence)
mapSentence idx sentence = Sentence { _sentenceIndex = sIndex
, _sentenceTokens = sTokens }
where
sIndex = Map.findWithDefault (-1) idx (jsPos ^. jsAsyncTaskResponse_index)
lemmas = fromMaybe [] $
if Just sentence == Map.lookup idx (jsLemma ^. jsAsyncTaskResponse_sentence) then
Map.lookup idx $ fromMaybe Map.empty (jsLemma ^. jsAsyncTaskResponse_lem)
else
Nothing
sTokens = imap mapPosToken $ zip (Map.findWithDefault [] idx $ fromMaybe Map.empty (jsPos ^. jsAsyncTaskResponse_pos))
(Map.findWithDefault [] idx (jsPos ^. jsAsyncTaskResponse_token))
mapPosToken idx' (pos, token) = Token { _tokenIndex = -1
, _tokenWord = token
, _tokenOriginalText = ""
, _tokenLemma = fromMaybe "" $ (LS.!!) lemmas idx'
, _tokenCharacterOffsetBegin = -1
, _tokenCharacterOffsetEnd = -1
, _tokenPos = Just pos
, _tokenNer = Nothing
, _tokenBefore = Nothing
, _tokenAfter = Nothing }
-----------------------------------------------------
jsRequest :: Text -> JSSpell -> IO JSAsyncTask
jsRequest t s = do
url <- parseRequest $ "POST http://localhost:5000/api/results"
let jsReq = JSRequest { _jsRequest_data = t
, _jsRequest_format = "text"
, _jsRequest_grouping = Nothing
, _jsRequest_spell = s }
let request = setRequestBodyLBS (encode jsReq) url
task <- httpJSON request :: IO (Response JSAsyncTask)
pure $ getResponseBody task
jsTaskStatus :: JSAsyncTask -> IO JSAsyncTaskStatus
jsTaskStatus (JSAsyncTask uuid) = do
url <- parseRequest $ unpack $ "GET http://localhost:5000/api/results/" <> uuid <> "/status"
status <- httpJSON url
pure $ getResponseBody status
jsTaskResponse :: JSAsyncTask -> IO JSAsyncTaskResponse
jsTaskResponse (JSAsyncTask uuid) = do
url <- parseRequest $ unpack $ "GET http://localhost:5000/api/results/" <> uuid
result <- httpJSON url
pure $ getResponseBody result
waitForJsTask :: HasCallStack => JSAsyncTask -> IO JSAsyncTaskResponse
waitForJsTask jsTask = wait' 0
where
wait' :: Int -> IO JSAsyncTaskResponse
wait' counter = do
status <- jsTaskStatus jsTask
if taskReady status then
jsTaskResponse jsTask
else
if counter > 60 then
throwIO $ withStacktrace $ userError "waited for 1 minute and still no answer from JohnSnow NLP"
else do
-- printDebug "[waitForJsTask] task not ready, waiting" counter
_ <- threadDelay $ 1000000*1
wait' $ counter + 1
getPosTagAndLems :: Lang -> Text -> IO PosSentences
getPosTagAndLems l t = do
jsPosTask <- jsRequest t (JSPOS l)
jsLemmaTask <- jsRequest t (JSLemma l)
-- wait for both tasks
jsPos <- waitForJsTask jsPosTask
jsLemma <- waitForJsTask jsLemmaTask
pure $ jsAsyncTaskResponseToSentences jsPos jsLemma
nlp :: Lang -> Text -> IO PosSentences
nlp = getPosTagAndLems
stack.yaml
View file @ 7056810c
......@@ -3,12 +3,9 @@
- "HSvm-0.1.1.3.22"
- "KMP-0.2.0.0"
- "MissingH-1.4.3.0"
- "Unique-0.4.7.8"
- "deferred-folds-0.9.18.6"
- "fclabels-2.0.5.1"
- "full-text-search-0.2.1.4"
- "fullstop-0.1.4"
- "ghc-parser-0.2.6.0"
- "hgal-2.0.0.2"
- "hsparql-0.3.8"
- "hspec-2.11.1"
......@@ -16,10 +13,6 @@
- "hspec-discover-2.11.1"
- "hspec-expectations-0.8.3"
- "http-accept-0.2"
- "ihaskell-0.11.0.0"
- "ipython-kernel-0.11.0.0"
- "located-base-0.1.1.1"
- "logging-effect-1.3.12"
- "morpheus-graphql-0.24.3"
- "morpheus-graphql-app-0.24.3"
- "morpheus-graphql-client-0.24.3"
......@@ -28,7 +21,6 @@
- "morpheus-graphql-core-0.24.3"
- "morpheus-graphql-server-0.24.3"
- "morpheus-graphql-subscriptions-0.24.3"
- "morpheus-graphql-tests-0.24.3"
- "opaleye-0.9.6.1"
- "primitive-unlifted-2.1.0.0"
- "rake-0.0.1"
......@@ -136,7 +128,7 @@
git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git"
subdirs:
- .
- commit: d54812d52c9d1f86d331a991b3a87c9a8b4379cf
- commit: 229fdf40b8ccecd527fca5a7bbb554b0deb540dc
git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git"
subdirs:
- .
......@@ -148,7 +140,7 @@
git: "https://gitlab.iscpif.fr/gargantext/crawlers/istex.git"
subdirs:
- .
- commit: c673924bce3283c4fb2d1b3a2f95eb3f1a9cd0b0
- commit: d2df0130575cfd32d6863d77e2ce34c48a1c32fa
git: "https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git"
subdirs:
- .
......@@ -278,8 +270,6 @@ flags:
semigroups: true
statevar: true
tagged: true
cpphs:
"old-locale": false
criterion:
"embed-data-files": false
fast: false
......@@ -332,13 +322,6 @@ flags:
gargantext:
"no-phylo-debug-logs": false
"test-crypto": false
"ghc-lib-parser":
"threaded-rts": true
"ghc-lib-parser-ex":
auto: false
"no-ghc-lib": false
"ghc-syntax-highlighter":
dev: false
graphviz:
"test-parsing": false
hashable:
......@@ -351,11 +334,6 @@ flags:
portable: false
sse42: false
"unsafe-tricks": true
hlint:
"ghc-lib": true
gpl: true
hsyaml: false
threaded: true
hmatrix:
"disable-default-paths": false
"no-random_r": false
......@@ -382,13 +360,9 @@ flags:
profile: false
"hxt-regex-xmlschema":
profile: false
ihaskell:
"use-hlint": true
"integer-logarithms":
"check-bounds": false
"integer-gmp": true
"ipython-kernel":
examples: false
jose:
demos: false
"json-stream":
......@@ -455,10 +429,6 @@ flags:
bcrypt: true
pbkdf2: true
scrypt: true
path:
dev: false
"path-io":
dev: false
"postgresql-libpq":
"use-pkg-config": false
"pretty-simple":
......@@ -467,10 +437,6 @@ flags:
prettyprinter:
buildreadme: false
text: true
probability:
splitbase: true
pureMD5:
test: false
"quickcheck-instances":
"bytestring-builder": false
reflection:
......
test/Test/Ngrams/NLP.hs
View file @ 7056810c
......@@ -21,7 +21,7 @@ import Test.Hspec
test :: Spec
test = do
describe "Text that should be cleaned before sending it to NLP tools as micro-services." $ do
let text = "This is a url http://cnrs.gargantext.org to be remove and another one www.gargantext.org and digits 343242-2332 to be remove and some to keep: 232 231 33." :: Text
let result = "This is a url to be remove and another one and digits to be remove and some to keep: 232 231 33."
let text = "This is a url http://cnrs.gargantext.org to be remove and another one www.gargantext.org"
let result = "This is a url to be remove and another one "
it "NLP Clean Text before sending to micro services:" $ cleanTextForNLP text `shouldBe` result
weeder.dhall deleted 100644 → 0
View file @ 0d0b33f0
{ roots = [ "^Main\\.main\$"
, "^Paths_.*"
], type-class-roots = True }
weeder.toml 0 → 100644
View file @ 7056810c
type-class-roots = true
roots = ['^Main\.main$', '^Paths_.*']
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