Merge branch 'dev' into 238-dev-async-job-worker

.gitlab/issue_templates/default.md

+
+## Summary
+
+(Summarize the bug encountered concisely with the version of code)
+
+## Steps to reproduce
+
+(How one can reproduce the issue - this is very important)
+
+## What is the current bug behavior?
+
+(What actually happens)
+
+## What is the expected correct behavior?
+
+(What you should see instead)
+
+## Relevant logs and/or screenshots
+
+(Paste any relevant logs - use code blocks (```) to format console output, logs, and code, as
+it's very hard to read otherwise.)
+
+## Possible fixes
+
+(If you can, link to the line of code that might be responsible for the problem)
+
+

CHANGELOG.md

+## Version 0.0.7.2.7
+
+* [BACK][FEAT][Switch from .ini to TOML? (#304)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/304)
+
+## Version 0.0.7.2.6
+
+* [FRONT][FIX] Fix quote with spaces
+
+## 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)

README.md

@@ -121,6 +121,58 @@ From inside a Nix shell:
 n$ cabal run gargantext-server -- --toml gargantext-settings.toml --run Prod
 ```
 
+#### Upgrading haskell packages
+
+We use `gargantext.cabal`, `cabal.project` and `cabal.project.freeze`
+as the source of truth. Ouf ot that, we generate the `stack.yaml` file
+for those who prefer to use Stack.
+
+Upgrading packages can be a pain sometimes, with cabal.
+
+Here are some tips:
+
+- Manually remove entries from your `cabal.project.freeze` to make the
+  build a bit more "elastic";
+- Lock the hackage-index state in the `cabal.project`, so that the
+  solver won't try to pull newer dependencies;
+- Specify constraints you want directly when building like `cabal
+  v2-build --constraint tasty==x.y.z.w`
+- Generate another `.freeze` with `cabal v2-freeze` once you got the
+  new build to compile (this is good for small, incremental upgrades)
+- Bounds in `.cabal` are definitely respected, but ofc the `.freeze`
+  takes priority, so you want to maybe use `cabal gen-bounds` when
+  your `.freeze` still exists, remove the file, try again.
+
+Also, it's helpful to build with `stack build` from time to time. The
+warnings are displayed, whenever a different stack lts package is used
+than the one defined in `.cabal` file - it's an incentive to upgrade
+the `.cabal` file versions.
+
+Occasionally, you can get issues with the `allow-newer: *` constraint
+from `cabal.project`. E.g. when I was building with GHC 9.4.7, I had
+errors with `hashable-1.5.0`. The solution is:
+```shell
+cabal v2-build --constraint hashable==1.4.3.0
+```
+(we don't depend on `hashable` directly, but `allow-newer: *` is so
+liberal that a package that is too new is used).
+
+Overall, it's preferred to specify strict constraints in
+`gargantext.cabal` file and to do that, one can use `stack ls dependencies`
+to have an idea what works.
+
+If you want to see the detailed build info for a given dependency:
+```shell
+cabal v2-build -v servant-server
+```
+
+Also, you might use the `-Wunused-packages` GHC option, to get a
+warning about unused packages (make sure though you build all targets
+with `cabal v2-build all`).
+
+Also, here is a relevant discussion:
+https://discourse.haskell.org/t/whats-your-workflow-to-update-cabal-dependencies/9475
+
 ### Initializing and running
 
 #### Start containers for database and NLP software bricks
@@ -178,6 +230,12 @@ Or, from "outside":
 ```shell
 $ nix-shell --run "cabal v2-test --test-show-details=streaming"
 ```
+
+If you want to run particular tests, use:
+```shell
+cabal v2-test garg-test-tasty --test-show-details=streaming --test-option=--pattern='/job status update and tracking/
+```
+
 ### Working on libraries
 
 When a devlopment is needed on libraries (for instance, the HAL crawler in https://gitlab.iscpif.fr/gargantext/crawlers):

bin/gargantext-cbor2json/Main.hs

-
-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

-{-|
-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

-
-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)
-
-

bin/update-project-dependencies

@@ -18,8 +18,8 @@ fi
 # with the `sha256sum` result calculated on the `cabal.project` and
 # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
 # cache can kick in.
-expected_cabal_project_hash="ebcccf8bd6ad8ea5adad45f63c7c1eb2026439fe19bd06840d5d962e8ce05c38"
-expected_cabal_project_freeze_hash="cd6fd302c204416ec84428dacab6d0e311a42ebd4b8db6227dcc57ccc8a6705a"
+expected_cabal_project_hash="967fee2ed28f46b12a629ad9821301854d3159975b7297653e50d7fc1f3b8919"
+expected_cabal_project_freeze_hash="af825192f1ec47b07e6001dd2556b59991c9e6c50094dc732ee933a41f0dc9bd"
 
 
 cabal --store-dir=$STORE_DIR v2-build --dry-run

cabal.project

 -- Generated by stack2cabal
 
-index-state: 2023-12-10T10:34:46Z
+-- index-state: 2023-12-10T10:34:46Z
+index-state: 2024-09-12T03:02:26Z
 
 with-compiler: ghc-9.4.7
 optimization: 2
@@ -63,7 +64,8 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/chessai/eigen.git
-    tag: 8fff32a43df743c8c83428a86dd566a0936a4fba
+    tag: 1790fdf9138970dde0dbabf8b270698145a4a88c
+    -- tag: 8fff32a43df743c8c83428a86dd566a0936a4fba
 
 source-repository-package
     type: git
@@ -88,12 +90,12 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git
-    tag: 9225d046083853200b9045c8d71161e6a234fc5c
+    tag: cf4e5004f3b002bdef3fcab95e3559d65cdcd858
 
 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 +110,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
-    tag: c673924bce3283c4fb2d1b3a2f95eb3f1a9cd0b0
+    tag: 4eec15855207dc74afc75b94c3764eede4de7b55
 
 source-repository-package
     type: git
@@ -207,8 +209,42 @@ source-repository-package
     tag: toml-parser-2.0.1.0
 
         
-allow-older: *
-allow-newer: *
+allow-newer:
+             accelerate-arithmetic:accelerate
+           , MissingH:base
+           , accelerate-utility:accelerate
+           , base:*
+           , crawlerHAL:servant
+           , crawlerISTEX:servant
+           , crawlerPubMed:servant
+           , crawlerPubMed:servant-client-core
+           , iso639:aeson
+           , iso639:text
+           , morpheus-graphql-app:text
+           , morpheus-graphql-client:text
+           , morpheus-graphql-code-gen-utils:text
+           , morpheus-graphql-code-gen:text
+           , morpheus-graphql-core:text
+           , morpheus-graphql-server:text
+           , morpheus-graphql-subscriptions:text
+           , morpheus-graphql:text
+           , servant-client:servant
+           , servant-client:servant-client-core
+           , servant-ekg:base
+           , servant-ekg:hashable
+           , servant-ekg:servant
+           , servant-ekg:text
+           , servant-ekg:time
+           , servant-xml-conduit:base
+           , servant-xml-conduit:bytestring
+           , servant-xml-conduit:servant
+           , stemmer:base
+allow-older: aeson:hashable
+           , crawlerHAL:servant-client
+           , haskell-bee:postgresql-libpq
+           , haskell-bee:stm
+           , haskell-throttle:time
+           , hsparql:rdf4h
 
 package gargantext
     ghc-options: -fwrite-ide-info -hiedir=".stack-work/hiedb"

server

@@ -7,4 +7,4 @@ LOGFILE=$FOLDER"/"$FILE
 
 mkdir -p $FOLDER
 
-nix-shell --run "~/.cabal/bin/gargantext-server --ini gargantext.ini --run Prod +RTS > $LOGFILE 2>&1 & tail -F $LOGFILE"
+nix-shell --run "~/.cabal/bin/gargantext-server --toml gargantext-settings.toml --run Prod +RTS > $LOGFILE 2>&1 & tail -F $LOGFILE"

src/Gargantext/API.hs

@@ -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/EnvTypes.hs

@@ -225,8 +225,8 @@ instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
 
 instance CET.HasCentralExchangeNotification Env where
   ce_notify m = do
-    nc <- asks (view env_config)
-    liftBase $ CE.notify (_gc_notifications_config nc) m
+    c <- asks (view env_config)
+    liftBase $ CE.notify (_gc_notifications_config c) m
     
 -- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
 -- constructor it's not exported, to not leak internal details of its implementation.

src/Gargantext/API/Admin/Orchestrator.hs

-{-|
-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

-{-|
-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

@@ -35,6 +35,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

-{-|
-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

@@ -9,8 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeOperators        #-}

src/Gargantext/API/Errors.hs

@@ -21,7 +21,7 @@ module Gargantext.API.Errors (
 
 import Prelude
 
-import Control.Exception
+import Control.Exception.Safe
 import Data.Aeson qualified as JSON
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL

src/Gargantext/API/Flow.hs

-{-|
-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

-{-# 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

@@ -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

@@ -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

-{-|
-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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -22,8 +22,6 @@ Node API
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeOperators        #-}

src/Gargantext/Core.hs

@@ -15,6 +15,7 @@ Portability : POSIX
 module Gargantext.Core
   where
 
+import Control.Exception.Safe (impureThrow)
 import Data.Aeson
 import Data.LanguageCodes qualified as ISO639
 import Data.Bimap qualified as Bimap
@@ -25,7 +26,6 @@ import Data.Text (pack)
 import Gargantext.Prelude hiding (All)
 import Servant.API
 import Test.QuickCheck
-import Control.Exception (throw)
 import Prelude (userError)
 
 ------------------------------------------------------------------------
@@ -180,5 +180,5 @@ fromDBid :: forall a. (HasCallStack, HasDBid a, Typeable a) => Int -> a
 fromDBid i = case lookupDBid i of
   Nothing ->
     let err = userError $ "HasDBid " <> show (typeRep (Proxy :: Proxy a)) <> " not found or not implemented."
-    in throw $ WithStacktrace callStack err
+    in impureThrow $ WithStacktrace callStack err
   Just v  -> v

src/Gargantext/Core/AsyncUpdates/CentralExchange.hs

@@ -103,5 +103,5 @@ notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do
       _ <- connect s $ T.unpack _nc_central_exchange_connect
       let str = Aeson.encode ceMessage
       withLogger () $ \ioLogger ->
-        logMsg ioLogger INFO $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
+        logMsg ioLogger DEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
       void $ sendNonblocking s $ BSL.toStrict str

src/Gargantext/Core/Config.hs

@@ -48,19 +48,20 @@ import Toml.Schema
 -- stripRight :: Char -> T.Text -> T.Text
 -- stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s
 
-data GargConfig = GargConfig { _gc_datafilepath         :: !FilePath
-                             -- , _gc_repofilepath      :: !FilePath
+-- Non-strict data so that we can use it in tests
+data GargConfig = GargConfig { _gc_datafilepath         :: ~FilePath
+                             -- , _gc_repofilepath      :: ~FilePath
 
-                             , _gc_frontend_config      :: !FrontendConfig
-                             , _gc_mail_config          :: !MailConfig
-                             , _gc_database_config      :: !PSQL.ConnectInfo
-                             , _gc_nlp_config           :: !NLPConfig
-                             , _gc_notifications_config :: !NotificationsConfig
-                             , _gc_frames               :: !FramesConfig
-                             , _gc_jobs                 :: !JobsConfig
-                             , _gc_secrets              :: !SecretsConfig
-                             , _gc_apis                 :: !APIsConfig
-                             , _gc_worker               :: !WorkerSettings
+                             , _gc_frontend_config      :: ~FrontendConfig
+                             , _gc_mail_config          :: ~MailConfig
+                             , _gc_database_config      :: ~PSQL.ConnectInfo
+                             , _gc_nlp_config           :: ~NLPConfig
+                             , _gc_notifications_config :: ~NotificationsConfig
+                             , _gc_frames               :: ~FramesConfig
+                             , _gc_jobs                 :: ~JobsConfig
+                             , _gc_secrets              :: ~SecretsConfig
+                             , _gc_apis                 :: ~APIsConfig
+                             , _gc_worker               :: ~WorkerSettings
                              }
   deriving (Generic, Show)
 

src/Gargantext/Core/Config/Types.hs

@@ -271,10 +271,10 @@ makeLenses ''APIsConfig
 
 
 data NotificationsConfig =
-  NotificationsConfig { _nc_central_exchange_bind    :: !T.Text
-                      , _nc_central_exchange_connect :: !T.Text
-                      , _nc_dispatcher_bind          :: !T.Text
-                      , _nc_dispatcher_connect       :: !T.Text }
+  NotificationsConfig { _nc_central_exchange_bind    :: ~T.Text
+                      , _nc_central_exchange_connect :: ~T.Text
+                      , _nc_dispatcher_bind          :: ~T.Text
+                      , _nc_dispatcher_connect       :: ~T.Text }
   deriving (Show, Eq)
 instance FromValue NotificationsConfig where
   fromValue = parseTableFromValue $ do

src/Gargantext/Core/Methods/Similarities/Distributional.hs

-{-|
-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

-{-|
-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

-{-|
-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

@@ -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

-{-|
-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

-{-|
-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

-{-|
-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

-{-|
-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

-{-|
-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

-{-|
-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

-{-|
-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

-{-|
-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

@@ -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

-{-|
-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

-{-|
-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

@@ -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

@@ -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

-{-# 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

-{-|
-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

-{-|
-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/Core/Worker.hs

@@ -33,7 +33,7 @@ import Gargantext.Core.Worker.Jobs
 import Gargantext.Core.Worker.Jobs.Types (Job(..))
 import Gargantext.Database.Query.Table.User (getUsersWithEmail)
 import Gargantext.Prelude
-import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(noJobHandle) )
+import Gargantext.Utils.Jobs.Monad ( JobHandle, MonadJobStatus(noJobHandle) )
 
   
 

src/Gargantext/Core/Worker/Env.hs

@@ -22,7 +22,7 @@ import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Pool (Pool)
 import Data.Text qualified as T
 import Database.PostgreSQL.Simple (Connection)
-import Gargantext.API.Admin.EnvTypes (ConcreteJobHandle, Env, GargJob, Mode(Dev), modeToLoggingLevels)
+import Gargantext.API.Admin.EnvTypes (ConcreteJobHandle, GargJob, Mode(Dev), modeToLoggingLevels)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
 import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool )
 import Gargantext.API.Admin.Types (HasSettings(..), Settings(..))
@@ -182,7 +182,8 @@ instance MonadJobStatus WorkerMonad where
   type JobEventType   WorkerMonad = JobLog
 
   -- noJobHandle _         = WorkerNoJobHandle
-  noJobHandle _         = noJobHandle (Proxy :: Proxy (GargM Env IOException))  -- ConcreteNullHandle
+  -- noJobHandle _         = noJobHandle (Proxy :: Proxy (GargM WorkerEnv IOException))  -- ConcreteNullHandle
+  noJobHandle _ = noJobHandle (Proxy :: Proxy WorkerMonad)
   getLatestJobStatus _  = WorkerMonad (pure noJobLog)
   withTracer _ jh n     = n jh
   markStarted _ _       = WorkerMonad $ pure ()

src/Gargantext/Database/Action/Flow/Utils.hs

@@ -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

-{-|
-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

@@ -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

@@ -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

-{-|
-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

-{-# 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

@@ -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/Prelude.hs

@@ -14,7 +14,7 @@ Portability : POSIX
 
 module Gargantext.Database.Prelude where
 
-import Control.Exception (throw)
+import Control.Exception.Safe (throw)
 import Control.Lens (Getter, view)
 import Control.Monad.Random ( MonadRandom )
 import Control.Monad.Trans.Control (MonadBaseControl)

src/Gargantext/Database/Query/Filter.hs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

-{-|
-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

-{-|
-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

-{-|
-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

@@ -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

@@ -9,8 +9,6 @@ Portability : POSIX
 
 -}
 
-{-#  OPTIONS_GHC -fno-warn-orphans  #-}
-
 {-# LANGUAGE Arrows                 #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TemplateHaskell        #-}

src/Gargantext/Database/Schema/ContextNodeNgrams2.hs

@@ -9,8 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 {-# LANGUAGE Arrows                 #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TemplateHaskell        #-}

src/Gargantext/Database/Schema/Node.hs

@@ -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

@@ -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

@@ -9,8 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 {-# LANGUAGE Arrows                 #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE QuasiQuotes            #-}

src/Gargantext/Database/Schema/NodeNgrams.hs

@@ -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/User.hs

@@ -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/Jobs/Map.hs

@@ -25,7 +25,7 @@ module Gargantext.Utils.Jobs.Map (
 import Control.Concurrent
 import Control.Concurrent.Async qualified as Async
 import Control.Concurrent.STM
-import Control.Exception
+import Control.Exception.Safe
 import Control.Monad
 import Data.Map.Strict (Map)
 import Data.Time.Clock