Skip to content

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

Merge branch 'dev' into dev-graph-explorer-gexf

parents d424a377 5b70b168
Hide whitespace changes
Inline Side-by-side
Showing with 488 additions and 273 deletions
bin/gargantext-import/Main.hs
View file @ 5ac27a46
......@@ -37,7 +37,6 @@ import System.Environment (getArgs)
--import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Monad.IO.Class (liftIO)
main :: IO ()
main = do
......
bin/gargantext-server/Main.hs
View file @ 5ac27a46
......@@ -22,9 +22,11 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
module Main where
import Options.Generic
import Data.Version (showVersion)
import Data.Text (unpack)
import qualified Paths_gargantext as PG -- cabal magic build module
import Options.Generic
import System.Exit (exitSuccess)
import Gargantext.Prelude
import Gargantext.API (startGargantext) -- , startGargantextMock)
......@@ -51,6 +53,8 @@ data MyOptions w =
<?> "By default: 8008"
, ini :: w ::: Maybe Text
<?> "Ini-file path of gargantext.ini"
, version :: w ::: Bool
<?> "Show version number and exit"
}
deriving (Generic)
......@@ -60,9 +64,15 @@ deriving instance Show (MyOptions Unwrapped)
main :: IO ()
main = do
MyOptions myMode myPort myIniFile <- unwrapRecord
MyOptions myMode myPort myIniFile myVersion <- unwrapRecord
"Gargantext server"
if myVersion then do
putStrLn $ "Version: " <> showVersion PG.version
System.Exit.exitSuccess
else
return ()
let myPort' = case myPort of
Just p -> p
Nothing -> 8008
......
build-shell.nix
View file @ 5ac27a46
{ghc}:
with (import ./pinned.nix {});
haskell.lib.buildStackProject {
inherit ghc;
name = "gargantext";
buildInputs = [
docker-compose
blas
{ ghc
, pkgs ? import ./pinned.nix {}
}:
let
buildInputs = with pkgs; [
bzip2
#gfortran
gfortran.cc.lib
glibc
gmp
gsl
igraph
liblapack
lzma
pcre
postgresql
#stack
xz
zlib
blas
gfortran7
gfortran7.cc.lib
];
libraryPaths = pkgs.lib.makeLibraryPath buildInputs;
in
pkgs.haskell.lib.buildStackProject rec {
inherit ghc;
inherit buildInputs;
name = "gargantext";
shellHook = ''
export LD_LIBRARY_PATH="${libraryPaths}"
export LIBRARY_PATH="${libraryPaths}"
'';
}
devops/debian/install
View file @ 5ac27a46
......@@ -26,7 +26,7 @@ tmux
# Open Stack only: attach volumes
# attach the volume created (OS interface or API)
sudo fdisk -l
sudo fisk /dev/vdb (n,p,t,83,w)
sudo fdisk /dev/vdb (n,p,t,83,w)
sudo mkfs.ext4 /dev/vdb1
sudo blkid
......
devops/docker/docker-compose.yaml
View file @ 5ac27a46
......@@ -3,6 +3,7 @@ version: '3'
services:
postgres:
image: 'postgres:latest'
network_mode: host
ports:
- 5432:5432
environment:
......
package.yaml
View file @ 5ac27a46
......@@ -10,6 +10,8 @@ copyright:
license: BSD3
homepage: https://gargantext.org
ghc-options: -Wall
extra-libraries:
- gfortran
dependencies:
- extra
- text
......@@ -82,13 +84,18 @@ library:
- Gargantext.Viz.Phylo.View.Export
- Gargantext.Viz.Phylo.View.ViewMaker
dependencies:
- array
- HSvm
- KMP
- MonadRandom
- QuickCheck
- SHA
- Unique
- accelerate
- aeson
- aeson-lens
- aeson-pretty
- argon2
- array
- async
- attoparsec
- auto-update
......@@ -101,53 +108,51 @@ library:
- bytestring
- case-insensitive
- cassava
#- charsetdetect-ae # detect charset
- cereal # (IGraph)
- clock
- clustering-louvain
- conduit
- conduit-extra
- containers
- contravariant
- crawlerPubMed
- crawlerIsidore
- crawlerHAL
- crawlerISTEX
- crawlerIsidore
- crawlerPubMed
- data-time-segment
- deepseq
- directory
- duckling
- exceptions
- filepath
- formatting
- fullstop
- fast-logger
- fclabels
- fgl
- fast-logger
- filelock
- filepath
- formatting
- full-text-search
- fullstop
- graphviz
- haskell-igraph
- hlcm
- hsparql
- hstatistics
- http-api-data
- http-client
- http-client-tls
- http-conduit
- http-media
- http-api-data
- http-types
- hsparql
- hstatistics
- HSvm
- hxt
- hlcm
- ini
- insert-ordered-containers
- jose
# - kmeans-vector
- json-stream
- KMP
- lens
- located-base
- logging-effect
- matrix
- monad-control
- monad-logger
- mtl
- natural-transformation
......@@ -166,36 +171,35 @@ library:
- profunctors
- protolude
- pureMD5
- random-shuffle
- MonadRandom
- SHA
- simple-reflect
- cereal # (IGraph)
- singletons # (IGraph)
- quickcheck-instances
- random
- rake
- random
- random-shuffle
- rdf4h
- regex-compat
- resource-pool
- resourcet
- rdf4h
- safe
- semigroups
- serialise
- servant
- servant-auth
- servant-auth-server >= 0.4.4.0
- servant-auth-swagger
- servant-blaze
- servant-cassava
- servant-client
- servant-flatten
- servant-job
- servant-mock
- servant-multipart
- servant-server
- servant-static-th
- servant-swagger
- servant-swagger-ui
- servant-static-th
- servant-cassava
- serialise
- servant-xml
- simple-reflect
- singletons # (IGraph)
- split
- stemmer
- string-conversions
......@@ -209,7 +213,6 @@ library:
- transformers
- transformers-base
- unordered-containers
- Unique
- uuid
- validity
- vector
......@@ -220,9 +223,12 @@ library:
- wreq
- xml-conduit
- xml-types
- xmlbf
- yaml
- zip
- zlib
# - kmeans-vector
#- charsetdetect-ae # detect charset
# - utc
# API external connections
......
pinned-19.09.nix 0 → 100644
View file @ 5ac27a46
# this version of nixpkgs contains liblapack at 3.8.0
# this version of nixpkgs contains gsl at 2.5.0
import (
builtins.fetchTarball {
url = "https://github.com/NixOS/nixpkgs/archive/19.09.tar.gz";
sha256 = "0mhqhq21y5vrr1f30qd2bvydv4bbbslvyzclhw0kdxmkgg3z4c92";
}
)
pinned.nix
View file @ 5ac27a46
# this version of nixpkgs contains liblapack at 3.8.0
# this version of nixpkgs contains gsl at 2.5.0
import (
builtins.fetchTarball {
url = "https://github.com/nixos/nixpkgs/archive/ece829033b7b8f4e81261fef5427144df4147bc4.tar.gz";
sha256 = "07n91k3d9i9pym8npsszha9mnvg4d1r0l0ldnhk4g8sx15vv1br5";
url = "https://github.com/NixOS/nixpkgs/archive/18.09.tar.gz";
sha256 = "1ib96has10v5nr6bzf7v8kw7yzww8zanxgw2qi1ll1sbv6kj6zpd";
}
)
shell.nix
View file @ 5ac27a46
{ pkgs ? import ./pinned.nix {} }:
{ pkgs ? import ./pinned-19.09.nix {} }:
pkgs.mkShell {
buildInputs = with pkgs; [
......
src/Gargantext/API.hs
View file @ 5ac27a46
......@@ -51,16 +51,17 @@ import Control.Concurrent (threadDelay)
import Control.Exception (finally)
import Control.Lens
import Control.Monad.Except (withExceptT, ExceptT)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ReaderT, runReaderT)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Swagger
import Data.Text (Text)
import Data.Validity
import Data.Version (showVersion)
import GHC.Generics (D1, Meta (..), Rep)
import GHC.TypeLits (AppendSymbol, Symbol)
import Network.Wai
import Network.Wai.Handler.Warp hiding (defaultSettings)
import qualified Paths_gargantext as PG -- cabal magic build module
import Servant
import Servant.Auth as SA
import Servant.Auth.Server (AuthResult(..))
......@@ -84,7 +85,7 @@ import Gargantext.API.Types
import Gargantext.Database.Node.Contact (HyperdataContact)
import Gargantext.Database.Types.Node
import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
import Gargantext.Database.Utils (HasConnection)
import Gargantext.Database.Utils (HasConnectionPool)
import Gargantext.Prelude
import Gargantext.Viz.Graph.API
import Network.HTTP.Types hiding (Query)
......@@ -197,17 +198,25 @@ type GargAPI = "api" :> Summary "API " :> GargAPIVersion
-- | TODO :<|> Summary "Latest API" :> GargAPI'
type GargAPIVersion = "v1.0" :> Summary "v1.0: " :> GargAPI'
type GargAPIVersion = "v1.0"
:> Summary "Garg API Version "
:> GargAPI'
type GargVersion = "version"
:> Summary "Backend version"
:> Get '[JSON] Text
type GargAPI' =
-- Auth endpoint
"auth" :> Summary "AUTH API"
:> ReqBody '[JSON] AuthRequest
:> Post '[JSON] AuthResponse
-- TODO-ACCESS here we want to request a particular header for
:<|> GargVersion
-- TODO-ACCESS here we want to request a particular header for
-- auth and capabilities.
:<|> GargPrivateAPI
type GargPrivateAPI = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser :> GargPrivateAPI'
type GargAdminAPI
......@@ -225,7 +234,7 @@ waitAPI :: Int -> GargServer WaitAPI
waitAPI n = do
let
m = (10 :: Int) ^ (6 :: Int)
_ <- liftIO $ threadDelay ( m * n)
_ <- liftBase $ threadDelay ( m * n)
pure $ "Waited: " <> (cs $ show n)
----------------------------------------
......@@ -293,7 +302,7 @@ type GargPrivateAPI' =
:<|> New.AddWithForm
:<|> New.AddWithQuery
:<|> Annuaire.AddWithForm
:<|> "annuaire" :> Annuaire.AddWithForm
-- :<|> New.AddWithFile
-- :<|> "scraper" :> WithCallbacks ScraperAPI
-- :<|> "new" :> New.Api
......@@ -324,7 +333,7 @@ type API = SwaggerAPI
type GargServerM env err = ReaderT env (ExceptT err IO)
type EnvC env =
( HasConnection env
( HasConnectionPool env
, HasRepo env
, HasSettings env
, HasJobEnv env ScraperStatus ScraperStatus
......@@ -337,7 +346,11 @@ server :: forall env. EnvC env => env -> IO (Server API)
server env = do
-- orchestrator <- scrapyOrchestrator env
pure $ schemaUiServer swaggerDoc
:<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
:<|> hoistServerWithContext
(Proxy :: Proxy GargAPI)
(Proxy :: Proxy AuthContext)
transform
serverGargAPI
:<|> frontEndServer
where
transform :: forall a. GargServerM env GargError a -> Handler a
......@@ -345,12 +358,18 @@ server env = do
serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
serverGargAPI -- orchestrator
= auth :<|> serverPrivateGargAPI
= auth
:<|> gargVersion
:<|> serverPrivateGargAPI
-- :<|> orchestrator
where
gargVersion :: GargServer GargVersion
gargVersion = pure (cs $ showVersion PG.version)
serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
serverPrivateGargAPI _ = throwAll' (_ServerError # err401)
serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
serverPrivateGargAPI _ = throwAll' (_ServerError # err401)
-- Here throwAll' requires a concrete type for the monad.
-- TODO-SECURITY admin only: withAdmin
......@@ -386,7 +405,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
-- TODO access
-- :<|> addUpload
-- :<|> (\corpus -> addWithQuery corpus :<|> addWithFile corpus)
:<|> addCorpusWithForm
:<|> addCorpusWithForm "user1"
:<|> addCorpusWithQuery
:<|> addAnnuaireWithForm
......@@ -398,35 +417,40 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
{-
addUpload :: GargServer New.Upload
addUpload cId = (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log)))
:<|> (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusWithForm cid i (liftIO . log)))
addUpload cId = (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftBase . log)))
:<|> (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusWithForm cid i (liftBase . log)))
--}
addCorpusWithQuery :: GargServer New.AddWithQuery
addCorpusWithQuery cid =
serveJobsAPI $
JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log))
JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftBase . log))
addWithFile :: GargServer New.AddWithFile
addWithFile cid i f =
serveJobsAPI $
JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftIO . log))
JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftBase . log))
addCorpusWithForm :: GargServer New.AddWithForm
addCorpusWithForm cid =
addCorpusWithForm :: Text -> GargServer New.AddWithForm
addCorpusWithForm username cid =
serveJobsAPI $
JobFunction (\i log -> New.addToCorpusWithForm cid i (liftIO . log))
JobFunction (\i log ->
let
log' x = do
printDebug "addCorpusWithForm" x
liftBase $ log x
in New.addToCorpusWithForm username cid i log')
addAnnuaireWithForm :: GargServer Annuaire.AddWithForm
addAnnuaireWithForm cid =
serveJobsAPI $
JobFunction (\i log -> Annuaire.addToAnnuaireWithForm cid i (liftIO . log))
JobFunction (\i log -> Annuaire.addToAnnuaireWithForm cid i (liftBase . log))
{-
serverStatic :: Server (Get '[HTML] Html)
serverStatic = $(do
let path = "purescript-gargantext/dist/index.html"
Just s <- liftIO (fileTypeToFileTree (FileTypeFile path))
Just s <- liftBase (fileTypeToFileTree (FileTypeFile path))
fileTreeToServer s
)
-}
......
src/Gargantext/API/Annuaire.hs
View file @ 5ac27a46
......@@ -88,7 +88,7 @@ addToAnnuaireWithForm _cid (WithForm ft _d _l) logStatus = do
-- WOS -> Parser.parseFormat Parser.WOS
-- PresseRIS -> Parser.parseFormat Parser.RisPresse
-- docs <- liftIO
-- docs <- liftBase
-- $ splitEvery 500
-- <$> take 1000000
-- <$> parse (cs d)
......
src/Gargantext/API/Auth.hs
View file @ 5ac27a46
......@@ -33,7 +33,6 @@ module Gargantext.API.Auth
where
import Control.Lens (view)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson.TH (deriveJSON)
import Data.List (elem)
import Data.Swagger
......@@ -50,7 +49,7 @@ import Gargantext.API.Types (HasJoseError(..), joseError, HasServerError, GargSe
import Gargantext.Database.Root (getRoot)
import Gargantext.Database.Tree (isDescendantOf, isIn)
import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId(..), UserId, ListId, DocId)
import Gargantext.Database.Utils (Cmd', CmdM, HasConnection)
import Gargantext.Database.Utils (Cmd', CmdM, HasConnectionPool)
import Gargantext.Prelude hiding (reverse)
import Test.QuickCheck (elements, oneof)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......@@ -91,12 +90,12 @@ makeTokenForUser :: (HasSettings env, HasJoseError err)
=> NodeId -> Cmd' env err Token
makeTokenForUser uid = do
jwtS <- view $ settings . jwtSettings
e <- liftIO $ makeJWT (AuthenticatedUser uid) jwtS Nothing
e <- liftBase $ makeJWT (AuthenticatedUser uid) jwtS Nothing
-- TODO-SECURITY here we can implement token expiration ^^.
either joseError (pure . toStrict . decodeUtf8) e
-- TODO not sure about the encoding...
checkAuthRequest :: (HasSettings env, HasConnection env, HasJoseError err)
checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err)
=> Username -> Password -> Cmd' env err CheckAuth
checkAuthRequest u p
| not (u `elem` arbitraryUsername) = pure InvalidUser
......@@ -109,7 +108,7 @@ checkAuthRequest u p
token <- makeTokenForUser uid
pure $ Valid token uid
auth :: (HasSettings env, HasConnection env, HasJoseError err)
auth :: (HasSettings env, HasConnectionPool env, HasJoseError err)
=> AuthRequest -> Cmd' env err AuthResponse
auth (AuthRequest u p) = do
checkAuthRequest' <- checkAuthRequest u p
......
src/Gargantext/API/Corpus/New.hs
View file @ 5ac27a46
......@@ -27,8 +27,6 @@ module Gargantext.API.Corpus.New
--import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat(..))
import Control.Lens hiding (elements)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent
import Data.Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Maybe (fromMaybe)
......@@ -67,7 +65,6 @@ data Query = Query { query_query :: Text
deriveJSON (unPrefix "query_") 'Query
instance Arbitrary Query where
arbitrary = elements [ Query q n fs
| q <- ["a","b"]
......@@ -97,7 +94,7 @@ api _uId (Query q _ as) = do
Nothing -> flowCorpusSearchInDatabase "user1" EN q
Just API.All -> flowCorpusSearchInDatabase "user1" EN q
Just a -> do
docs <- liftIO $ API.get a q (Just 1000)
docs <- liftBase $ API.get a q (Just 1000)
cId' <- flowCorpus "user1" (Left q) (Multi EN) [docs]
pure cId'
......@@ -157,7 +154,6 @@ type Upload = Summary "Corpus Upload endpoint"
:<|> "addWithquery" :> AsyncJobsAPI ScraperStatus WithQuery ScraperStatus
:<|> "addWithfile" :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithForm ScraperStatus
type AddWithQuery = Summary "Add with Query to corpus endpoint"
:> "corpus"
:> Capture "corpus_id" CorpusId
......@@ -205,7 +201,6 @@ addToCorpusJobFunction _cid (WithQuery _q _dbs _l) logStatus = do
, _scst_events = Just []
}
addToCorpusWithFile :: FlowCmdM env err m
=> CorpusId
-> MultipartData Mem
......@@ -218,6 +213,7 @@ addToCorpusWithFile cid input filetype logStatus = do
, _scst_remaining = Just 138
, _scst_events = Just []
}
printDebug "addToCorpusWithFile" cid
_h <- postUpload cid filetype input
pure ScraperStatus { _scst_succeeded = Just 137
......@@ -237,20 +233,19 @@ addToCorpusWithForm' :: FlowCmdM env err m
-> (ScraperStatus -> m ())
-> m ScraperStatus
addToCorpusWithForm' cid (WithForm ft d l) logStatus = do
newStatus <- liftIO newEmptyMVar
newStatus <- liftBase newEmptyMVar
s <- addToCorpusWithForm cid (WithForm ft d l) logStatus
_ <- liftIO $ forkIO $ putMVar newStatus s
s' <- liftIO $ takeMVar newStatus
_ <- liftBase $ forkIO $ putMVar newStatus s
s' <- liftBase $ takeMVar newStatus
pure s'
-}
addToCorpusWithForm :: FlowCmdM env err m
=> CorpusId
=> Text
-> CorpusId
-> WithForm
-> (ScraperStatus -> m ())
-> m ScraperStatus
addToCorpusWithForm cid (WithForm ft d l _n) logStatus = do
printDebug "ft" ft
addToCorpusWithForm username cid (WithForm ft d l _n) logStatus = do
let
parse = case ft of
......@@ -259,29 +254,29 @@ addToCorpusWithForm cid (WithForm ft d l _n) logStatus = do
WOS -> Parser.parseFormat Parser.WOS
PresseRIS -> Parser.parseFormat Parser.RisPresse
newDocs <- liftIO newEmptyMVar
docs <- liftIO
$ splitEvery 500
<$> take 1000000
<$> parse (cs d)
_ <- liftIO $ forkIO $ putMVar newDocs docs
logStatus ScraperStatus { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
docs' <- liftIO $ takeMVar newDocs
newCid <- liftIO newEmptyMVar
cid' <- flowCorpus "user1"
printDebug "Parsing corpus: " cid
-- TODO granularity of the logStatus
docs <- liftBase $ splitEvery 500
<$> take 1000000
<$> parse (cs d)
printDebug "Parsing corpus finished : " cid
printDebug "Starting extraction : " cid
-- TODO granularity of the logStatus
_cid' <- flowCorpus username
(Right [cid])
(Multi $ fromMaybe EN l)
(map (map toHyperdataDocument) docs')
_ <- liftIO $ forkIO $ putMVar newCid cid'
(map (map toHyperdataDocument) docs)
cid'' <- liftIO $ takeMVar newCid
printDebug "cid'" cid''
printDebug "Extraction finished : " cid
pure ScraperStatus { _scst_succeeded = Just 2
, _scst_failed = Just 0
......
src/Gargantext/API/Corpus/New/File.hs
View file @ 5ac27a46
......@@ -27,7 +27,6 @@ module Gargantext.API.Corpus.New.File
import Control.Lens ((.~), (?~))
import Control.Monad (forM)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe
import Data.Aeson
import Data.Monoid (mempty)
......@@ -100,18 +99,18 @@ postUpload :: NodeId
-> Cmd err [Hash]
postUpload _ Nothing _ = panic "fileType is a required parameter"
postUpload _ (Just fileType) multipartData = do
putStrLn $ "File Type: " <> (show fileType)
is <- liftIO $ do
putStrLn ("Inputs:" :: Text)
printDebug "File Type: " fileType
is <- liftBase $ do
printDebug "Inputs:" ()
forM (inputs multipartData) $ \input -> do
putStrLn $ ("iName " :: Text) <> (iName input)
<> ("iValue " :: Text) <> (iValue input)
printDebug "iName " (iName input)
printDebug "iValue " (iValue input)
pure $ iName input
_ <- forM (files multipartData) $ \file -> do
let content = fdPayload file
putStrLn $ ("XXX " :: Text) <> (fdFileName file)
putStrLn $ ("YYY " :: Text) <> cs content
printDebug "XXX " (fdFileName file)
printDebug "YYY " content
--pure $ cs content
-- is <- inputs multipartData
......
src/Gargantext/API/Ngrams.hs
View file @ 5ac27a46
......@@ -119,9 +119,11 @@ import qualified Data.Set as Set
import Control.Category ((>>>))
import Control.Concurrent
import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (.~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left))
......@@ -140,7 +142,7 @@ import Gargantext.Database.Config (userMaster)
import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Database.Types.Node (NodeType(..))
import Gargantext.Database.Utils (fromField', HasConnection)
import Gargantext.Database.Utils (fromField', HasConnectionPool)
import Gargantext.Database.Node.Select
import Gargantext.Database.Ngrams
--import Gargantext.Database.Lists (listsWith)
......@@ -796,14 +798,14 @@ instance HasRepoSaver RepoEnv where
type RepoCmdM env err m =
( MonadReader env m
, MonadError err m
, MonadIO m
, MonadBaseControl IO m
, HasRepo env
)
------------------------------------------------------------------------
saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
=> m ()
saveRepo = liftIO =<< view repoSaver
saveRepo = liftBase =<< view repoSaver
listTypeConflictResolution :: ListType -> ListType -> ListType
listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
......@@ -834,7 +836,7 @@ copyListNgrams :: RepoCmdM env err m
-> m ()
copyListNgrams srcListId dstListId ngramsType = do
var <- view repoVar
liftIO $ modifyMVar_ var $
liftBase $ modifyMVar_ var $
pure . (r_state . at ngramsType %~ (Just . f . something))
saveRepo
where
......@@ -849,7 +851,7 @@ addListNgrams :: RepoCmdM env err m
-> [NgramsElement] -> m ()
addListNgrams listId ngramsType nes = do
var <- view repoVar
liftIO $ modifyMVar_ var $
liftBase $ modifyMVar_ var $
pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
saveRepo
where
......@@ -871,7 +873,7 @@ setListNgrams :: RepoCmdM env err m
-> m ()
setListNgrams listId ngramsType ns = do
var <- view repoVar
liftIO $ modifyMVar_ var $
liftBase $ modifyMVar_ var $
pure . ( r_state
. at ngramsType %~
(Just .
......@@ -899,7 +901,7 @@ putListNgrams' :: RepoCmdM env err m
putListNgrams' listId ngramsType ns = do
-- printDebug "putListNgrams" (length nes)
var <- view repoVar
liftIO $ modifyMVar_ var $
liftBase $ modifyMVar_ var $
pure . ( r_state
. at ngramsType %~
(Just .
......@@ -928,7 +930,7 @@ currentVersion :: RepoCmdM env err m
=> m Version
currentVersion = do
var <- view repoVar
r <- liftIO $ readMVar var
r <- liftBase $ readMVar var
pure $ r ^. r_version
tableNgramsPull :: RepoCmdM env err m
......@@ -937,7 +939,7 @@ tableNgramsPull :: RepoCmdM env err m
-> m (Versioned NgramsTablePatch)
tableNgramsPull listId ngramsType p_version = do
var <- view repoVar
r <- liftIO $ readMVar var
r <- liftBase $ readMVar var
let
q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
......@@ -966,7 +968,7 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
assertValid p_validity
var <- view repoVar
vq' <- liftIO $ modifyMVar var $ \r -> do
vq' <- liftBase $ modifyMVar var $ \r -> do
let
q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
(p', q') = transformWith ngramsStatePatchConflictResolution p q
......@@ -1006,7 +1008,7 @@ getNgramsTableMap :: RepoCmdM env err m
-> m (Versioned NgramsTableMap)
getNgramsTableMap nodeId ngramsType = do
v <- view repoVar
repo <- liftIO $ readMVar v
repo <- liftBase $ readMVar v
pure $ Versioned (repo ^. r_version)
(repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
......@@ -1018,12 +1020,12 @@ type MaxSize = Int
-- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
-- TODO: should take only one ListId
getTime' :: MonadIO m => m TimeSpec
getTime' = liftIO $ getTime ProcessCPUTime
getTime' :: MonadBase IO m => m TimeSpec
getTime' = liftBase $ getTime ProcessCPUTime
getTableNgrams :: forall env err m.
(RepoCmdM env err m, HasNodeError err, HasConnection env)
(RepoCmdM env err m, HasNodeError err, HasConnectionPool env)
=> NodeType -> NodeId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
......@@ -1085,7 +1087,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
ngramsType
ngrams_terms
t2 <- getTime'
liftIO $ hprint stderr
liftBase $ hprint stderr
("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
(length ngrams_terms) t1 t2
{-
......@@ -1114,7 +1116,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
. setScores (not scoresNeeded)
. selectAndPaginate
t3 <- getTime'
liftIO $ hprint stderr
liftBase $ hprint stderr
("getTableNgrams total=" % timeSpecs
% " map1=" % timeSpecs
% " map2=" % timeSpecs
......@@ -1184,7 +1186,7 @@ type TableNgramsApi = TableNgramsApiGet
:<|> TableNgramsApiPut
:<|> TableNgramsApiPost
getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env)
=> NodeId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
......@@ -1198,7 +1200,7 @@ getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize o
searchQuery = maybe (const True) isInfixOf mt
-- | Text search is deactivated for now for ngrams by doc only
getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env)
=> DocId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
......@@ -1218,7 +1220,7 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
apiNgramsTableCorpus :: ( RepoCmdM env err m
, HasNodeError err
, HasInvalidError err
, HasConnection env
, HasConnectionPool env
)
=> NodeId -> ServerT TableNgramsApi m
apiNgramsTableCorpus cId = getTableNgramsCorpus cId
......@@ -1229,7 +1231,7 @@ apiNgramsTableCorpus cId = getTableNgramsCorpus cId
apiNgramsTableDoc :: ( RepoCmdM env err m
, HasNodeError err
, HasInvalidError err
, HasConnection env
, HasConnectionPool env
)
=> DocId -> ServerT TableNgramsApi m
apiNgramsTableDoc dId = getTableNgramsDoc dId
......
src/Gargantext/API/Ngrams/List.hs
View file @ 5ac27a46
......@@ -24,7 +24,6 @@ module Gargantext.API.Ngrams.List
where
import Control.Lens hiding (elements)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import Data.List (zip)
import Data.Map (Map, toList, fromList)
......@@ -50,7 +49,7 @@ import Servant.Job.Utils (jsonOptions)
------------------------------------------------------------------------
type NgramsList = (Map NgramsType (Versioned NgramsTableMap))
------------------------------------------------------------------------
type API = Get '[HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
type API = Get '[JSON, HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
-- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool
:<|> PostAPI
......@@ -111,7 +110,7 @@ type PostAPI = Summary "Update List"
postAsync :: ListId -> GargServer PostAPI
postAsync lId =
serveJobsAPI $
JobFunction (\f log' -> postAsync' lId f (liftIO . log'))
JobFunction (\f log' -> postAsync' lId f (liftBase . log'))
postAsync' :: FlowCmdM env err m
=> ListId
......
src/Gargantext/API/Ngrams/Tools.hs
View file @ 5ac27a46
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
......@@ -36,7 +37,7 @@ type RootTerm = Text
getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo = do
v <- view repoVar
liftIO $ readMVar v
liftBase $ readMVar v
listNgramsFromRepo :: [ListId] -> NgramsType
-> NgramsRepo -> Map Text NgramsRepoElement
......
src/Gargantext/API/Orchestrator/Types.hs
View file @ 5ac27a46
......@@ -85,7 +85,7 @@ data ScraperEvent = ScraperEvent
, _scev_level :: !(Maybe Text)
, _scev_date :: !(Maybe Text)
}
deriving Generic
deriving (Show, Generic)
instance Arbitrary ScraperEvent where
arbitrary = ScraperEvent <$> elements [Nothing, Just "test message"]
......@@ -104,7 +104,7 @@ data ScraperStatus = ScraperStatus
, _scst_remaining :: !(Maybe Int)
, _scst_events :: !(Maybe [ScraperEvent])
}
deriving Generic
deriving (Show, Generic)
instance Arbitrary ScraperStatus where
arbitrary = ScraperStatus
......
src/Gargantext/API/Settings.hs
View file @ 5ac27a46
......@@ -35,13 +35,14 @@ import System.Environment (lookupEnv)
import System.IO (FilePath, hClose)
import System.IO.Temp (withTempFile)
import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
import Network.HTTP.Client (Manager)
import Network.HTTP.Client.TLS (newTlsManager)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Either (either)
import Data.Pool (Pool, createPool)
import Data.Text
--import Data.Text.Encoding (encodeUtf8)
import Data.ByteString (ByteString)
......@@ -61,7 +62,7 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Control.Lens
import Gargantext.Prelude
import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
import Gargantext.Database.Utils (databaseParameters, HasConnectionPool(..), Cmd', runCmd)
import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
import Gargantext.API.Orchestrator.Types
......@@ -141,7 +142,7 @@ data FireWall = FireWall { unFireWall :: Bool }
data Env = Env
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
, _env_conn :: !Connection
, _env_pool :: !(Pool Connection)
, _env_repo :: !RepoEnv
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
......@@ -151,8 +152,8 @@ data Env = Env
makeLenses ''Env
instance HasConnection Env where
connection = env_conn
instance HasConnectionPool Env where
connPool = env_pool
instance HasRepoVar Env where
repoVar = repoEnv . repoVar
......@@ -254,7 +255,7 @@ newEnv port file = do
self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
param <- databaseParameters file
conn <- connect param
pool <- newPool param
repo <- readRepoEnv
scrapers_env <- newJobEnv defaultSettings manager
logger <- newStderrLoggerSet defaultBufSize
......@@ -262,23 +263,26 @@ newEnv port file = do
pure $ Env
{ _env_settings = settings
, _env_logger = logger
, _env_conn = conn
, _env_pool = pool
, _env_repo = repo
, _env_manager = manager
, _env_scrapers = scrapers_env
, _env_self_url = self_url
}
newPool :: ConnectInfo -> IO (Pool Connection)
newPool param = createPool (connect param) close 1 (60*60) 8
data DevEnv = DevEnv
{ _dev_env_conn :: !Connection
{ _dev_env_pool :: !(Pool Connection)
, _dev_env_repo :: !RepoEnv
, _dev_env_settings :: !Settings
}
makeLenses ''DevEnv
instance HasConnection DevEnv where
connection = dev_env_conn
instance HasConnectionPool DevEnv where
connPool = dev_env_pool
instance HasRepoVar DevEnv where
repoVar = repoEnv . repoVar
......@@ -306,11 +310,11 @@ withDevEnv iniPath k = do
where
newDevEnv = do
param <- databaseParameters iniPath
conn <- connect param
pool <- newPool param
repo <- readRepoEnv
setts <- devSettings devJwkFile
pure $ DevEnv
{ _dev_env_conn = conn
{ _dev_env_pool = pool
, _dev_env_repo = repo
, _dev_env_settings = setts
}
......@@ -326,7 +330,7 @@ runCmdReplServantErr = runCmdRepl
-- In particular this writes the repo file after running
-- the command.
-- This function is constrained to the DevEnv rather than
-- using HasConnection and HasRepoVar.
-- using HasConnectionPool and HasRepoVar.
runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
runCmdDev env f =
(either (fail . show) pure =<< runCmd env f)
......
src/Gargantext/Core/Flow/Types.hs
View file @ 5ac27a46
......@@ -10,6 +10,7 @@ Portability : POSIX
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstrainedClassMethods #-}
......
src/Gargantext/Core/Types.hs
View file @ 5ac27a46
......@@ -12,8 +12,8 @@ commentary with @some markup@.
-}
------------------------------------------------------------------------
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
......@@ -139,7 +139,7 @@ class HasInvalidError e where
assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
-- assertValid :: MonadBase IO m => Validation -> m ()
-- assertValid v = when (not $ validationIsValid v) $ fail $ show v
......
src/Gargantext/Database/Flow.hs
View file @ 5ac27a46
......@@ -44,7 +44,6 @@ import Data.Tuple.Extra (first, second)
import Data.Traversable (traverse)
import Debug.Trace (trace)
import Control.Lens ((^.), view, _Just)
import Control.Monad.IO.Class (liftIO)
import Data.List (concat)
import Data.Map (Map, lookup)
import Data.Maybe (Maybe(..), catMaybes)
......@@ -109,7 +108,7 @@ _flowCorpusApi :: ( FlowCmdM env err m)
-> ApiQuery
-> m CorpusId
_flowCorpusApi u n tt l q = do
docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
docs <- liftBase $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
flowCorpus u n tt docs
------------------------------------------------------------------------
......@@ -121,7 +120,7 @@ flowAnnuaire :: FlowCmdM env err m
-> FilePath
-> m AnnuaireId
flowAnnuaire u n l filePath = do
docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
docs <- liftBase $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
-- UNUSED
......@@ -130,7 +129,7 @@ _flowCorpusDebat :: FlowCmdM env err m
-> Limit -> FilePath
-> m CorpusId
_flowCorpusDebat u n l fp = do
docs <- liftIO ( splitEvery 500
docs <- liftBase ( splitEvery 500
<$> take l
<$> readFile' fp
:: IO [[GD.GrandDebatReference ]]
......@@ -143,7 +142,7 @@ flowCorpusFile :: FlowCmdM env err m
-> TermType Lang -> FileFormat -> FilePath
-> m CorpusId
flowCorpusFile u n l la ff fp = do
docs <- liftIO ( splitEvery 500
docs <- liftBase ( splitEvery 500
<$> take l
<$> parseFile ff fp
)
......@@ -439,7 +438,7 @@ instance ExtractNgramsT HyperdataDocument
terms' <- map text2ngrams
<$> map (intercalate " " . _terms_label)
<$> concat
<$> liftIO (extractTerms lang' $ hasText doc)
<$> liftBase (extractTerms lang' $ hasText doc)
pure $ Map.fromList $ [(source, Map.singleton Sources 1)]
<> [(i', Map.singleton Institutes 1) | i' <- institutes ]
......
src/Gargantext/Database/Flow/Annuaire.hs
View file @ 5ac27a46
......@@ -29,7 +29,7 @@ import Gargantext.Database.Flow
flowAnnuaire :: FlowCmdM env ServantErr m => FilePath -> m ()
flowAnnuaire filePath = do
contacts <- liftIO $ deserialiseImtUsersFromFile filePath
contacts <- liftBase $ deserialiseImtUsersFromFile filePath
ps <- flowInsertAnnuaire "Annuaire"
$ map (\h-> ToDbContact h)
$ map addUniqIdsContact contacts
......
src/Gargantext/Database/Flow/Pairing.hs
View file @ 5ac27a46
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......
src/Gargantext/Database/Flow/Utils.hs
View file @ 5ac27a46
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
......
src/Gargantext/Database/Init.hs
View file @ 5ac27a46
......@@ -11,6 +11,7 @@ Ngrams by node enable contextual metrics.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......
src/Gargantext/Database/Metrics/NgramsByNode.hs
View file @ 5ac27a46
......@@ -11,6 +11,7 @@ Ngrams by node enable contextual metrics.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......
src/Gargantext/Database/Node/Document/Add.hs
View file @ 5ac27a46
......@@ -13,6 +13,8 @@ Add Documents/Contact to a Corpus/Annuaire.
------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......
src/Gargantext/Database/Node/Document/Insert.hs
View file @ 5ac27a46
......@@ -49,6 +49,7 @@ the concatenation of the parameters defined by @shaParameters@.
-}
------------------------------------------------------------------------
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......
src/Gargantext/Database/Node/Update.hs
View file @ 5ac27a46
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
......
src/Gargantext/Database/Node/UpdateOpaleye.hs
View file @ 5ac27a46
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
......
src/Gargantext/Database/Schema/Ngrams.hs
View file @ 5ac27a46
......@@ -13,6 +13,7 @@ Ngrams connection to the Database.
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......
src/Gargantext/Database/Schema/NodeNgrams.hs
View file @ 5ac27a46
......@@ -15,6 +15,7 @@ NodeNgrams register Context of Ngrams (named Cgrams then)
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
......
src/Gargantext/Database/Schema/NodeNode.hs
View file @ 5ac27a46
......@@ -14,6 +14,7 @@ commentary with @some markup@.
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
......
src/Gargantext/Database/Schema/NodeNodeNgrams.hs
View file @ 5ac27a46
......@@ -12,6 +12,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......
src/Gargantext/Database/Schema/NodeNodeNgrams2.hs
View file @ 5ac27a46
......@@ -12,6 +12,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......
src/Gargantext/Database/Schema/Node_NodeNgramsNodeNgrams.hs
View file @ 5ac27a46
......@@ -22,6 +22,7 @@ Next Step benchmark:
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......
src/Gargantext/Database/Schema/NodesNgramsRepo.hs
View file @ 5ac27a46
......@@ -13,6 +13,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......
src/Gargantext/Database/Schema/User.hs
View file @ 5ac27a46
......@@ -14,6 +14,7 @@ Functions to deal with users, database side.
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
......
src/Gargantext/Database/TextSearch.hs
View file @ 5ac27a46
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
......
src/Gargantext/Database/Tree.hs
View file @ 5ac27a46
......@@ -12,6 +12,7 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
......
src/Gargantext/Database/Triggers/NodeNodeNgrams.hs
View file @ 5ac27a46
......@@ -11,6 +11,7 @@ Triggers on NodeNodeNgrams table.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......
src/Gargantext/Database/Triggers/Nodes.hs
View file @ 5ac27a46
......@@ -11,6 +11,7 @@ Triggers on Nodes table.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......
src/Gargantext/Database/Triggers/NodesNodes.hs
View file @ 5ac27a46
......@@ -11,6 +11,7 @@ Triggers on NodesNodes table.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......
src/Gargantext/Database/Utils.hs
View file @ 5ac27a46
......@@ -13,6 +13,7 @@ commentary with @some markup@.
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......@@ -22,10 +23,11 @@ module Gargantext.Database.Utils where
import Data.ByteString.Char8 (hPutStrLn)
import System.IO (stderr)
import Control.Exception
import Control.Exception
import Control.Monad.Error.Class -- (MonadError(..), Error)
import Control.Lens (Getter, view)
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Except
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
import Data.Either.Extra (Either(Left, Right))
......@@ -33,10 +35,12 @@ import Data.Ini (readIniFile, lookupValue)
import qualified Data.List as DL
import Data.Maybe (maybe)
import Data.Monoid ((<>))
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default)
import Data.Text (unpack, pack)
import Data.Typeable (Typeable)
import Data.Word (Word16)
--import Database.PostgreSQL.Simple (Connection, Pool, connect, withPoolConnection)
import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field)
......@@ -48,21 +52,21 @@ import Text.Read (read)
import qualified Data.ByteString as DB
import qualified Database.PostgreSQL.Simple as PGS
class HasConnection env where
connection :: Getter env Connection
class HasConnectionPool env where
connPool :: Getter env (Pool Connection)
instance HasConnection Connection where
connection = identity
instance HasConnectionPool (Pool Connection) where
connPool = identity
type CmdM' env err m =
( MonadReader env m
, MonadError err m
, MonadIO m
, MonadBaseControl IO m
)
type CmdM env err m =
( CmdM' env err m
, HasConnection env
, HasConnectionPool env
)
type Cmd' env err a = forall m. CmdM' env err m => m a
......@@ -75,10 +79,10 @@ fromInt64ToInt = fromIntegral
-- TODO: ideally there should be very few calls to this functions.
mkCmd :: (Connection -> IO a) -> Cmd err a
mkCmd k = do
conn <- view connection
liftIO $ k conn
pool <- view connPool
withResource pool (liftBase . k)
runCmd :: (HasConnection env)
runCmd :: (HasConnectionPool env)
=> env -> Cmd' env err a
-> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
......@@ -100,8 +104,8 @@ formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
runPGSQuery :: (MonadError err m, MonadReader env m,
PGS.FromRow r, PGS.ToRow q, MonadIO m, HasConnection env)
runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
PGS.FromRow r, PGS.ToRow q, HasConnectionPool env)
=> PGS.Query -> q -> m [r]
runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
where
......
src/Gargantext/Prelude.hs
View file @ 5ac27a46
......@@ -12,6 +12,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
......@@ -28,13 +29,14 @@ module Gargantext.Prelude
, round
, sortWith
, module Prelude
, MonadBase(..)
)
where
import Control.Monad.Base (MonadBase(..))
import GHC.Exts (sortWith)
import GHC.Err.Located (undefined)
import GHC.Real (round)
import Control.Monad.IO.Class (MonadIO)
import Data.Maybe (isJust, fromJust, maybe)
import Data.Text (Text)
import Protolude ( Bool(True, False), Int, Int64, Double, Integer
......@@ -42,7 +44,6 @@ import Protolude ( Bool(True, False), Int, Int64, Double, Integer
, Enum, Bounded, Float
, Floating, Char, IO
, pure, (>>=), (=<<), (<*>), (<$>), (>>)
, putStrLn
, head, flip
, Ord, Integral, Foldable, RealFrac, Monad, filter
, reverse, map, mapM, zip, drop, take, zipWith
......@@ -63,7 +64,7 @@ import Protolude ( Bool(True, False), Int, Int64, Double, Integer
, panic
)
import Prelude (Enum, Bounded, minBound, maxBound)
import Prelude (Enum, Bounded, minBound, maxBound, putStrLn)
-- TODO import functions optimized in Utils.Count
-- import Protolude hiding (head, last, all, any, sum, product, length)
-- import Gargantext.Utils.Count
......@@ -81,8 +82,8 @@ import Text.Read (Read())
import Data.String.Conversions (cs)
printDebug :: (Show a, MonadIO m) => [Char] -> a -> m ()
printDebug msg x = putStrLn $ msg <> " " <> show x
printDebug :: (Show a, MonadBase IO m) => [Char] -> a -> m ()
printDebug msg x = liftBase . putStrLn $ msg <> " " <> show x
-- printDebug _ _ = pure ()
......@@ -303,6 +304,3 @@ fib :: Int -> Int
fib 0 = 0
fib 1 = 1
fib n = fib (n-1) + fib (n-2)
src/Gargantext/Prelude/Utils.hs
View file @ 5ac27a46
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......@@ -17,7 +18,6 @@ module Gargantext.Prelude.Utils
import Control.Lens (view)
import Control.Monad.Reader (MonadReader)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Random.Class (MonadRandom)
import Data.Text (Text)
import Control.Monad.Reader (ask)
......@@ -84,23 +84,23 @@ class ReadFile a where
readFile' :: FilePath -> IO a
writeFile :: (MonadReader env m, MonadIO m, HasSettings env, SaveFile a)
writeFile :: (MonadReader env m, MonadBase IO m, HasSettings env, SaveFile a)
=> a -> m FilePath
writeFile a = do
dataPath <- view (settings . fileFolder) <$> ask
(fp,fn) <- liftIO $ (toPath 3) . sha . Text.pack . show <$> newStdGen
(fp,fn) <- liftBase $ (toPath 3) . sha . Text.pack . show <$> newStdGen
let foldPath = dataPath <> "/" <> fp
filePath = foldPath <> "/" <> fn
_ <- liftIO $ createDirectoryIfMissing True foldPath
_ <- liftIO $ saveFile' filePath a
_ <- liftBase $ createDirectoryIfMissing True foldPath
_ <- liftBase $ saveFile' filePath a
pure filePath
readFile :: (MonadReader env m, MonadIO m, HasSettings env, ReadFile a)
readFile :: (MonadReader env m, MonadBase IO m, HasSettings env, ReadFile a)
=> FilePath -> m a
readFile fp = do
dataPath <- view (settings . fileFolder) <$> ask
liftIO $ readFile' $ dataPath <> "/" <> fp
liftBase $ readFile' $ dataPath <> "/" <> fp
src/Gargantext/Text/List.hs
View file @ 5ac27a46
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
......
src/Gargantext/Text/List/Learn.hs
View file @ 5ac27a46
......@@ -13,6 +13,7 @@ CSV parser for Gargantext corpus files.
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......@@ -20,7 +21,6 @@ module Gargantext.Text.List.Learn
where
import Control.Monad.Reader (MonadReader)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Gargantext.API.Settings
import Data.Map (Map)
import Data.Maybe (maybe)
......@@ -87,18 +87,18 @@ type Tests = Map ListType [Vec.Vector Double]
type Score = Double
type Param = Double
grid :: (MonadReader env m, MonadIO m, HasSettings env)
grid :: (MonadReader env m, MonadBase IO m, HasSettings env)
=> Param -> Param -> Train -> [Tests] -> m (Maybe Model)
grid _ _ _ [] = panic "Gargantext.Text.List.Learn.grid : empty test data"
grid s e tr te = do
let
grid' :: (MonadReader env m, MonadIO m, HasSettings env)
grid' :: (MonadReader env m, MonadBase IO m, HasSettings env)
=> Double -> Double
-> Train
-> [Tests]
-> m (Score, Model)
grid' x y tr' te' = do
model'' <- liftIO $ trainList x y tr'
model'' <- liftBase $ trainList x y tr'
let
model' = ModelSVM model'' (Just x) (Just y)
......@@ -117,7 +117,7 @@ grid s e tr te = do
$ map (\(k,vs) -> zip (repeat k) vs)
$ Map.toList t
res' <- liftIO $ predictList m toGuess
res' <- liftBase $ predictList m toGuess
pure $ score'' $ score' $ List.zip res res'
score <- mapM (getScore model') te'
......
src/Gargantext/Text/Terms/Multi/PosTagging.hs
View file @ 5ac27a46
......@@ -48,8 +48,6 @@ import Gargantext.Prelude
import Network.HTTP.Simple
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class (MonadIO)
import Data.String.Conversions (ConvertibleStrings)
------------------------------------------------------------------------
......@@ -116,9 +114,10 @@ $(deriveJSON (unPrefix "_") ''PosSentences)
--
corenlp' :: ( MonadThrow m, MonadIO m, FromJSON a
corenlp' :: ( FromJSON a
, ConvertibleStrings p ByteString) =>
Lang -> p -> m (Response a)
Lang -> p -> IO (Response a)
corenlp' lang txt = do
let properties = case lang of
EN -> "{\"annotators\": \"tokenize,ssplit,pos,ner\", \"outputFormat\": \"json\"}"
......
src/Gargantext/Viz/Graph.hs
View file @ 5ac27a46
......@@ -10,6 +10,7 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
......@@ -18,7 +19,6 @@ module Gargantext.Viz.Graph
where
import Control.Lens (makeLenses)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Aeson.TH (deriveJSON)
import Data.ByteString.Lazy as DBL (readFile, writeFile)
import Data.Swagger
......@@ -189,7 +189,7 @@ graphV3ToGraphWithFiles g1 g2 = do
DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
readGraphFromJson fp = do
graph <- liftIO $ DBL.readFile fp
graph <- liftBase $ DBL.readFile fp
pure $ DA.decode graph
src/Gargantext/Viz/Graph/API.hs
View file @ 5ac27a46
......@@ -12,32 +12,37 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} -- allows to write Text literals
{-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.Viz.Graph.API
where
-- import Debug.Trace (trace)
import Control.Concurrent -- (forkIO)
import Control.Lens (set, (^.), _Just, (^?))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import Debug.Trace (trace)
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Swagger
import Data.Text
import GHC.Generics (Generic)
import Servant
import Servant.Job.Async
import Servant.XML
import qualified Xmlbf as Xmlbf
import Gargantext.API.Ngrams (NgramsRepo, r_version)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Orchestrator.Types
import Gargantext.API.Types
import Gargantext.Core.Types.Main
import Gargantext.Database.Config
......@@ -66,11 +71,11 @@ instance Xmlbf.ToXml Graph where
where
params = HashMap.fromList [ ("xmlns", "http://www.gexf.net/1.2draft")
, ("version", "1.2") ]
meta = Xmlbf.element "meta" params $ creator <> description
meta = Xmlbf.element "meta" params $ creator <> desc
where
params = HashMap.fromList [ ("lastmodifieddate", "2020-03-13") ]
creator = Xmlbf.element "creator" HashMap.empty $ Xmlbf.text "Gargantext.org"
description = Xmlbf.element "description" HashMap.empty $ Xmlbf.text "Gargantext gexf file"
desc = Xmlbf.element "description" HashMap.empty $ Xmlbf.text "Gargantext gexf file"
graph :: [G.Node] -> [G.Edge] -> [Xmlbf.Node]
graph gn ge = Xmlbf.element "graph" params $ (nodes gn) <> (edges ge)
where
......@@ -101,14 +106,24 @@ instance Xmlbf.ToXml Graph where
type GraphAPI = Get '[JSON] Graph
:<|> Post '[JSON] [GraphId]
:<|> Put '[JSON] Int
:<|> "gexf" :> Get '[XML] (Headers '[Header "Content-Disposition" Text] Graph)
:<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
:<|> GraphAsyncAPI
:<|> "versions" :> GraphVersionsAPI
data GraphVersions = GraphVersions { gv_graph :: Maybe Int
, gv_repo :: Int } deriving (Show, Generic)
instance ToJSON GraphVersions
instance ToSchema GraphVersions
graphAPI :: UserId -> NodeId -> GargServer GraphAPI
graphAPI u n = getGraph u n
:<|> postGraph n
:<|> putGraph n
:<|> getGraphGexf u n
:<|> graphAsync u n
:<|> graphVersionsAPI u n
------------------------------------------------------------------------
......@@ -119,14 +134,56 @@ graphAPI u n = getGraph u n
-- Each process has to be tailored
getGraph' :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
getGraph' u n = do
newGraph <- liftIO newEmptyMVar
newGraph <- liftBase newEmptyMVar
g <- getGraph u n
_ <- liftIO $ forkIO $ putMVar newGraph g
g' <- liftIO $ takeMVar newGraph
_ <- liftBase $ forkIO $ putMVar newGraph g
g' <- liftBase $ takeMVar newGraph
pure g'
-}
getGraph :: UserId -> NodeId -> GargNoServer Graph
getGraph uId nId = do
nodeGraph <- getNodeWith nId HyperdataGraph
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
-- let listVersion = graph ^? _Just
-- . graph_metadata
-- . _Just
-- . gm_list
-- . lfg_version
repo <- getRepo
-- let v = repo ^. r_version
nodeUser <- getNodeUser (NodeId uId)
let uId' = nodeUser ^. node_userId
let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
identity
$ nodeGraph ^. node_parentId
g <- case graph of
Nothing -> do
graph' <- computeGraph cId NgramsTerms repo
_ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
pure $ trace "Graph empty, computing" $ graph'
Just graph' -> pure $ trace "Graph exists, returning" $ graph'
-- Just graph' -> if listVersion == Just v
-- then pure graph'
-- else do
-- graph'' <- computeGraph cId NgramsTerms repo
-- _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
-- pure graph''
newGraph <- liftBase newEmptyMVar
_ <- liftBase $ forkIO $ putMVar newGraph g
g' <- liftBase $ takeMVar newGraph
pure {- $ trace (show g) $ -} g'
recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
recomputeGraph uId nId = do
nodeGraph <- getNodeWith nId HyperdataGraph
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just
......@@ -145,26 +202,39 @@ getGraph uId nId = do
identity
$ nodeGraph ^. node_parentId
newGraph <- liftIO newEmptyMVar
g <- case graph of
Nothing -> do
graph' <- computeGraph cId NgramsTerms repo
graph' <- computeGraphAsync cId NgramsTerms repo
_ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
pure graph'
pure $ trace "[recomputeGraph] Graph empty, computing" $ graph'
Just graph' -> if listVersion == Just v
then pure graph'
else do
graph'' <- computeGraph cId NgramsTerms repo
graph'' <- computeGraphAsync cId NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
pure graph''
_ <- liftIO $ forkIO $ putMVar newGraph g
g' <- liftIO $ takeMVar newGraph
pure {- $ trace (show g) $ -} g'
pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph''
pure g
computeGraphAsync :: HasNodeError err
=> CorpusId
-> NgramsType
-> NgramsRepo
-> Cmd err Graph
computeGraphAsync cId nt repo = do
g <- liftBase newEmptyMVar
_ <- forkIO <$> putMVar g <$> computeGraph cId nt repo
g' <- liftBase $ takeMVar g
pure g'
-- TODO use Database Monad only here ?
computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
computeGraph :: HasNodeError err
=> CorpusId
-> NgramsType
-> NgramsRepo
-> Cmd err Graph
computeGraph cId nt repo = do
lId <- defaultList cId
......@@ -179,11 +249,11 @@ computeGraph cId nt repo = do
let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
myCooc <- Map.filter (>1)
<$> getCoocByNgrams (Diagonal True)
<$> getCoocByNgrams (Diagonal False)
<$> groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
graph <- liftIO $ cooc2graph 0 myCooc
graph <- liftBase $ cooc2graph 0 myCooc
let graph' = set graph_metadata (Just metadata) graph
pure graph'
......@@ -196,7 +266,69 @@ putGraph :: NodeId -> GargServer (Put '[JSON] Int)
putGraph = undefined
getGraphGexf :: UserId -> NodeId -> GargNoServer (Headers '[Header "Content-Disposition" Text] Graph)
------------------------------------------------------------
getGraphGexf :: UserId -> NodeId -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf uId nId = do
graph <- getGraph uId nId
pure $ addHeader (concat [ "attachment; filename=graph.gexf" ]) graph
------------------------------------------------------------
type GraphAsyncAPI = Summary "Update graph"
:> "async"
:> AsyncJobsAPI ScraperStatus () ScraperStatus
graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
graphAsync u n =
serveJobsAPI $
JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
graphAsync' :: UserId
-> NodeId
-> (ScraperStatus -> GargNoServer ())
-> GargNoServer ScraperStatus
graphAsync' u n logStatus = do
logStatus ScraperStatus { _scst_succeeded = Just 0
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
_g <- trace (show u) $ recomputeGraph u n
pure ScraperStatus { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 0
, _scst_events = Just []
}
------------------------------------------------------------
type GraphVersionsAPI = Summary "Graph versions"
:> Get '[JSON] GraphVersions
:<|> Summary "Recompute graph version"
:> Post '[JSON] Graph
graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
graphVersionsAPI u n =
graphVersions u n
:<|> recomputeVersions u n
graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
graphVersions _uId nId = do
nodeGraph <- getNodeWith nId HyperdataGraph
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just
. graph_metadata
. _Just
. gm_list
. lfg_version
repo <- getRepo
let v = repo ^. r_version
pure $ GraphVersions { gv_graph = listVersion
, gv_repo = v }
recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
recomputeVersions uId nId = recomputeGraph uId nId
src/Gargantext/Viz/Graph/Bridgeness.hs
View file @ 5ac27a46
......@@ -25,7 +25,7 @@ import Data.Map (Map, fromListWith, lookup, fromList, delete, toList, mapKeys, m
import qualified Data.Map as DM
import Data.Maybe (fromJust)
import Data.List (concat, sortOn)
import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
-- TODO mv in Louvain Lib
......
src/Gargantext/Viz/Graph/IGraph.hs
View file @ 5ac27a46
......@@ -8,6 +8,9 @@ Portability : POSIX
Main IGraph funs/types to ease portability with FGL.
Reference:
* Gábor Csárdi, Tamás Nepusz: The igraph software package for complex network research. InterJournal Complex Systems, 1695, 2006.
-}
{-# LANGUAGE NoImplicitPrelude #-}
......
src/Gargantext/Viz/Graph/Tools.hs
View file @ 5ac27a46
......@@ -15,10 +15,8 @@ Portability : POSIX
module Gargantext.Viz.Graph.Tools
where
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
import Debug.Trace (trace)
import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
-- import Data.Graph.Clustering.Louvain (hLouvain, {-iLouvainMap-})
import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
import Data.Map (Map)
import qualified Data.Set as Set
......@@ -57,33 +55,33 @@ cooc2graph :: Threshold
-> (Map (Text, Text) Int)
-> IO Graph
cooc2graph threshold myCooc = do
let (ti, _) = createIndices myCooc
myCooc' = toIndex ti myCooc
matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
distanceMat = measureConditional matCooc
distanceMap = Map.filter (> threshold) $ mat2map distanceMat
let
(ti, _) = createIndices myCooc
myCooc' = toIndex ti myCooc
matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
distanceMat = measureConditional matCooc
distanceMap = Map.filter (> threshold) $ mat2map distanceMat
let nodesApprox :: Int
nodesApprox = n'
where
(as, bs) = List.unzip $ Map.keys distanceMap
n' = Set.size $ Set.fromList $ as <> bs
ClustersParams rivers level = {-trace ("nodesApprox: " <> show nodesApprox) $-} clustersParams nodesApprox
nodesApprox :: Int
nodesApprox = n'
where
(as, bs) = List.unzip $ Map.keys distanceMap
n' = Set.size $ Set.fromList $ as <> bs
ClustersParams rivers level = clustersParams nodesApprox
partitionsV <- liftIO newEmptyMVar
partitions' <- case Map.size distanceMap > 0 of
True -> trace ("level" <> show level) $ cLouvain level distanceMap
False -> panic "Text.Flow: DistanceMap is empty"
_ <- liftIO $ forkIO $ putMVar partitionsV partitions'
partitions <- liftIO $ takeMVar partitionsV
partitions <- if (Map.size distanceMap > 0)
--then iLouvainMap 100 10 distanceMap
-- then hLouvain distanceMap
then cLouvain level distanceMap
else panic "Text.Flow: DistanceMap is empty"
let bridgeness' = {-trace ("rivers: " <> show rivers) $-}
bridgeness rivers partitions distanceMap
let
bridgeness' = bridgeness rivers partitions distanceMap
confluence' = confluence (Map.keys bridgeness') 3 True False
let confluence' = confluence (Map.keys bridgeness') 3 True False
pure $ data2graph (Map.toList ti) myCooc' bridgeness' confluence' partitions
data2graph (Map.toList ti) myCooc' bridgeness' confluence' partitions
data ClustersParams = ClustersParams { bridgness :: Double
......@@ -107,12 +105,13 @@ data2graph :: [(Text, Int)]
-> Map (Int, Int) Double
-> Map (Int, Int) Double
-> [LouvainNode]
-> IO Graph
data2graph labels coocs bridge conf partitions = do
let community_id_by_node_id = Map.fromList [ (n, c) | LouvainNode n c <- partitions ]
-> Graph
data2graph labels coocs bridge conf partitions = Graph nodes edges Nothing
where
nodes <- mapM (setCoord ForceAtlas labels bridge)
community_id_by_node_id = Map.fromList [ (n, c) | LouvainNode n c <- partitions ]
nodes = map (setCoord ForceAtlas labels bridge)
[ (n, Node { node_size = maybe 0 identity (Map.lookup (n,n) coocs)
, node_type = Terms -- or Unknown
, node_id = cs (show n)
......@@ -130,7 +129,7 @@ data2graph labels coocs bridge conf partitions = do
$ Map.toList bridge
]
let edges = [ Edge { edge_source = cs (show s)
edges = [ Edge { edge_source = cs (show s)
, edge_target = cs (show t)
, edge_weight = d
, edge_confluence = maybe 0 identity $ Map.lookup (s,t) conf
......@@ -139,7 +138,6 @@ data2graph labels coocs bridge conf partitions = do
| (i, ((s,t), d)) <- zip ([0..]::[Integer]) (Map.toList bridge), s /= t, d > 0
]
pure $ Graph nodes edges Nothing
------------------------------------------------------------------------
......@@ -153,22 +151,23 @@ setCoord' f (i,n) = n { node_x_coord = x, node_y_coord = y }
-- | ACP
setCoord :: Ord a => Layout -> [(a, Int)] -> Map (Int, Int) Double -> (Int, Node) -> IO Node
setCoord l labels m (n,node) = getCoord l labels m n
>>= \(x,y) -> pure $ node { node_x_coord = x
, node_y_coord = y
}
setCoord :: Ord a => Layout -> [(a, Int)] -> Map (Int, Int) Double -> (Int, Node) -> Node
setCoord l labels m (n,node) = node { node_x_coord = x
, node_y_coord = y
}
where
(x,y) = getCoord l labels m n
getCoord :: Ord a => Layout
-> [(a, Int)] -> Map (Int, Int) Double -> Int -> IO (Double, Double)
getCoord KamadaKawai _ m n = layout m n
-> [(a, Int)] -> Map (Int, Int) Double -> Int -> (Double, Double)
getCoord KamadaKawai _ _m _n = undefined -- layout m n
getCoord ForceAtlas _ _ n = pure (sin d, cos d)
getCoord ForceAtlas _ _ n = (sin d, cos d)
where
d = fromIntegral n
getCoord ACP labels m n = pure $ to2d $ maybe (panic "Graph.Tools no coordinate") identity
getCoord ACP labels m n = to2d $ maybe (panic "Graph.Tools no coordinate") identity
$ Map.lookup n
$ pcaReduceTo (Dimension 2)
$ mapArray labels m
......
src/Gargantext/Viz/Phylo/API.hs
View file @ 5ac27a46
......@@ -42,7 +42,6 @@ import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Web.HttpApiData (parseUrlPiece, readTextData)
import Control.Monad.IO.Class (liftIO)
import Network.HTTP.Media ((//), (/:))
------------------------------------------------------------------------
......@@ -108,7 +107,7 @@ getPhylo phId _lId l msb = do
branc = maybe 2 identity msb
maybePhylo = hyperdataPhylo_data $ _node_hyperdata phNode
p <- liftIO $ viewPhylo2Svg $ viewPhylo level branc $ maybe phyloFromQuery identity maybePhylo
p <- liftBase $ viewPhylo2Svg $ viewPhylo level branc $ maybe phyloFromQuery identity maybePhylo
pure (SVG p)
------------------------------------------------------------------------
type PostPhylo = QueryParam "listId" ListId
......
src/Gargantext/Viz/Phylo/Aggregates.hs
View file @ 5ac27a46
......@@ -27,7 +27,7 @@ import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import Debug.Trace (trace)
import Data.List (partition, concat, nub, elem, sort, (++), null, union)
import Data.Map (Map, fromList, fromListWith, adjust, filterWithKey, elems, keys, unionWith, mapWithKey)
import Data.Set (size)
......
src/Gargantext/Viz/Phylo/Cluster.hs
View file @ 5ac27a46
......@@ -19,6 +19,7 @@ module Gargantext.Viz.Phylo.Cluster
where
import Control.Parallel.Strategies
import Data.Graph.Clustering.Louvain.CplusPlus
import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
import Data.List (null,concat,sort,intersect,(++), elemIndex, groupBy, nub, union, (\\), (!!))
import Data.Map (Map, fromList, mapKeys)
import Data.Tuple (fst)
......
src/Gargantext/Viz/Phylo/Main.hs
View file @ 5ac27a46
......@@ -72,7 +72,7 @@ flowPhylo cId = do
docs = map ( (\(y,t) -> Document y t) . filterTerms patterns) docs'
--liftIO $ flowPhylo' (List.sortOn date docs) termList l m fp
--liftBase $ flowPhylo' (List.sortOn date docs) termList l m fp
pure $ buildPhylo (List.sortOn date docs) termList
......
src/Gargantext/Viz/Phylo/PhyloTools.hs
View file @ 5ac27a46
......@@ -492,4 +492,4 @@ traceTemporalMatching groups =
traceGroupsProxi :: Map (PhyloGroupId,PhyloGroupId) Double -> Map (PhyloGroupId,PhyloGroupId) Double
traceGroupsProxi m =
trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m
\ No newline at end of file
trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m
src/Gargantext/Viz/Phylo/TemporalMatching.hs
View file @ 5ac27a46
......@@ -543,4 +543,4 @@ adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1
(traceTemporalMatching $ getGroupsFromLevel 1 phylo)
--------------------------------------
thr :: Double
thr = toThreshold elevation (phylo ^. phylo_groupsProxi)
\ No newline at end of file
thr = toThreshold elevation (phylo ^. phylo_groupsProxi)
src/Gargantext/Viz/Phylo/View/ViewMaker.hs
View file @ 5ac27a46
......@@ -170,4 +170,4 @@ traceView pv = trace ("------------\n--| View |--\n------------\n\n"
<> show (percentile 75 (VS.fromList lst)) <> " (75%) "
<> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") pv
where
lst = sort $ map (fromIntegral . length . snd) $ getNodesByBranches pv
\ No newline at end of file
lst = sort $ map (fromIntegral . length . snd) $ getNodesByBranches pv
stack.yaml
View file @ 5ac27a46
......@@ -4,6 +4,7 @@ extra-package-dbs: []
packages:
- .
#- 'deps/servant-job'
#- 'deps/clustering-louvain'
docker:
enable: false
......@@ -13,7 +14,6 @@ docker:
nix:
enable: false
#packages: [gmp]
add-gc-roots: true
shell-file: build-shell.nix
......@@ -47,9 +47,9 @@ extra-deps:
#- git: https://github.com/delanoe/servant-job.git
#commit: 7a7b7100e6d132adb4c11b25b2128e6309690ac0
- git: https://github.com/np/servant-job.git
commit: 4016c76398a56e1a352a45b3ee9d698dd0dd2597
commit: 5bf03696edad27285b0588aba92b34b48db16832
- git: https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
commit: e5814cbfa71f43b0a453efb65f476240d7d51a53
commit: 7d74f96dfea8e51fbab1793cc0429b2fe741f73d
- git: https://github.com/np/patches-map
commit: 8c6f38c4844ead53e664cf9c82ba461715dbe445
- git: https://github.com/delanoe/haskell-opaleye.git #- opaleye-0.6.7002.0
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment