Commit 7da5cfa2 authored by Quentin Lobbé's avatar Quentin Lobbé

Merge branch 'dev' into dev-phylo

parents ce0f0e64 1f9f3f09
......@@ -14,18 +14,21 @@ Import a corpus binary.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Strict #-}
module Main where
import Control.Exception (finally)
import Servant (ServantErr)
import Gargantext.Prelude
import Gargantext.Database.Flow (flowCorpus)
import Gargantext.Database.Flow (FlowCmdM, flowCorpus)
import Gargantext.Text.Parsers (FileFormat(CsvHalFormat))
import Gargantext.Database.Utils (Cmd, connectGargandb, runCmdDevWith)
import Gargantext.Database.Types.Node (NodeId)
import Gargantext.Database.Utils (Cmd, )
import Gargantext.Database.Types.Node (CorpusId)
--import Gargantext.Database.Schema.User (insertUsers, gargantuaUser, simpleUser)
import Gargantext.API.Node () -- instances
import Gargantext.API.Settings (newDevEnvWith, runCmdDev, DevEnv)
import System.Environment (getArgs)
main :: IO ()
......@@ -34,11 +37,16 @@ main = do
{-let createUsers :: Cmd ServantErr Int64
createUsers = insertUsers [gargantuaUser,simpleUser]
_ <- runCmdDevWith iniPath createUsers
-}
let cmd :: Cmd ServantErr NodeId
cmd = flowCorpus CsvHalFormat corpusPath (cs name)
r <- runCmdDevWith iniPath cmd
let cmdCorpus :: forall m. FlowCmdM DevEnv ServantErr m => m CorpusId
cmdCorpus = flowCorpus CsvHalFormat corpusPath (cs name)
-- cmd = {-createUsers >>-} cmdCorpus
env <- newDevEnvWith iniPath
-- Better if we keep only one call to runCmdDev.
_ <- runCmdDev env cmdCorpus
pure ()
......@@ -44,40 +44,37 @@ instance ParseField Mode
instance ParseFields Mode
data MyOptions w = MyOptions { run :: w ::: Mode <?> "Possible modes: Dev | Mock | Prod"
, port :: w ::: Maybe Int <?> "By default: 8008"
, ini :: w ::: Maybe Text <?> "Ini-file path of gargantext.ini"
}
deriving (Generic)
data MyOptions w =
MyOptions { run :: w ::: Mode
<?> "Possible modes: Dev | Mock | Prod"
, port :: w ::: Maybe Int
<?> "By default: 8008"
, ini :: w ::: Maybe Text
<?> "Ini-file path of gargantext.ini"
}
deriving (Generic)
instance ParseRecord (MyOptions Wrapped)
deriving instance Show (MyOptions Unwrapped)
main :: IO ()
main = do
MyOptions myMode myPort myIniFile <- unwrapRecord
"Gargantext: collaborative platform for text-mining"
let myPort' = case myPort of
Just p -> p
Nothing -> 8008
let start = case myMode of
--Nothing -> startGargantext myPort' (unpack myIniFile')
Prod -> startGargantext myPort' (unpack myIniFile')
where
myIniFile' = case myIniFile of
Nothing -> panic "For Prod mode, you need to fill a gargantext.ini file"
Just i -> i
Mock -> startGargantextMock myPort'
_ -> startGargantextMock myPort'
putStrLn $ "Starting Gargantext with mode: " <> show myMode
start
-- main' :: IO ()
--main' = putStrLn $ show $ M.conditional $ M.myMat 10
main = do
MyOptions myMode myPort myIniFile <- unwrapRecord
"Gargantext server"
let myPort' = case myPort of
Just p -> p
Nothing -> 8008
let start = case myMode of
Prod -> startGargantext myPort' (unpack myIniFile')
where
myIniFile' = case myIniFile of
Nothing -> panic "[ERROR] gargantext.ini needed"
Just i -> i
_ -> startGargantextMock myPort'
putStrLn $ "Starting with " <> show myMode <> " mode."
start
......@@ -28,6 +28,7 @@ library:
- Gargantext.API.Auth
- Gargantext.API.Count
- Gargantext.API.FrontEnd
- Gargantext.API.Ngrams
- Gargantext.API.Node
- Gargantext.API.Orchestrator
- Gargantext.API.Search
......@@ -50,6 +51,7 @@ library:
- Gargantext.Text.Examples
- Gargantext.Text.List.CSV
- Gargantext.Text.Metrics
- Gargantext.Text.Metrics.TFICF
- Gargantext.Text.Metrics.CharByChar
- Gargantext.Text.Metrics.Count
- Gargantext.Text.Parsers
......@@ -109,6 +111,7 @@ library:
- ini
- insert-ordered-containers
- jose-jwt
- json-state
# - kmeans-vector
- KMP
- lens
......@@ -159,11 +162,13 @@ library:
- text-metrics
- time
- time-locale-compat
- time-units
- timezone-series
- transformers
- transformers-base
- unordered-containers
- uuid
- validity
- vector
- wai
- wai-cors
......
......@@ -44,6 +44,7 @@ import GHC.Generics (D1, Meta (..), Rep)
import GHC.TypeLits (AppendSymbol, Symbol)
import Control.Lens
import Control.Exception (finally)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (runReaderT)
import Data.Aeson.Encode.Pretty (encodePretty)
......@@ -72,6 +73,7 @@ import Gargantext.Prelude
import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
import Gargantext.API.Ngrams (HasRepoVar(..), HasRepoSaver(..), saveRepo)
import Gargantext.API.Node ( GargServer
, Roots , roots
, NodeAPI , nodeAPI
......@@ -83,6 +85,7 @@ import Gargantext.API.Node ( GargServer
, HyperdataAnnuaire
)
--import Gargantext.Database.Node.Contact (HyperdataContact)
import Gargantext.Database.Utils (HasConnection)
import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
import Gargantext.API.Count ( CountAPI, count, Query)
import Gargantext.API.Search ( SearchAPI, search, SearchQuery)
......@@ -163,9 +166,8 @@ makeMockApp env = do
makeDevApp :: Env -> IO Application
makeDevApp env = do
serverApp <- makeApp env
makeDevMiddleware :: IO Middleware
makeDevMiddleware = do
-- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
--logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
......@@ -192,8 +194,8 @@ makeDevApp env = do
--let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort)
-- $ Warp.defaultSettings
--pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
pure $ logStdoutDev $ corsMiddleware $ serverApp
--pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
pure $ logStdoutDev . corsMiddleware
---------------------------------------------------------------------
-- | API Global
......@@ -276,12 +278,13 @@ type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
---------------------------------------------------------------------
-- | Server declarations
server :: Env -> IO (Server API)
server :: (HasConnection env, HasRepoVar env, HasRepoSaver env)
=> env -> IO (Server API)
server env = do
-- orchestrator <- scrapyOrchestrator env
pure $ swaggerFront
:<|> hoistServer (Proxy :: Proxy GargAPI) (`runReaderT` env) serverGargAPI
:<|> serverIndex
:<|> serverStatic
serverGargAPI :: GargServer GargAPI
serverGargAPI -- orchestrator
......@@ -299,9 +302,12 @@ serverGargAPI -- orchestrator
where
fakeUserId = 1 -- TODO
serverIndex :: Server (Get '[HTML] Html)
serverIndex = $(do (Just s) <- liftIO (fileTypeToFileTree (FileTypeFile "purescript-gargantext/dist/index.html"))
fileTreeToServer s)
serverStatic :: Server (Get '[HTML] Html)
serverStatic = $(do
let path = "purescript-gargantext/dist/index.html"
Just s <- liftIO (fileTypeToFileTree (FileTypeFile path))
fileTreeToServer s
)
---------------------------------------------------------------------
swaggerFront :: Server SwaggerFrontAPI
......@@ -312,11 +318,12 @@ gargMock :: Server GargAPI
gargMock = mock apiGarg Proxy
---------------------------------------------------------------------
makeApp :: Env -> IO Application
makeApp :: (HasConnection env, HasRepoVar env, HasRepoSaver env)
=> env -> IO Application
makeApp = fmap (serve api) . server
appMock :: Application
appMock = serve api (swaggerFront :<|> gargMock :<|> serverIndex)
appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
---------------------------------------------------------------------
api :: Proxy API
......@@ -367,13 +374,19 @@ portRouteInfo port = do
T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
stopGargantext :: HasRepoSaver env => env -> IO ()
stopGargantext env = do
T.putStrLn "----- Stopping gargantext -----"
runReaderT saveRepo env
-- | startGargantext takes as parameters port number and Ini file.
startGargantext :: PortNumber -> FilePath -> IO ()
startGargantext port file = do
env <- newEnv port file
portRouteInfo port
app <- makeDevApp env
run port app
app <- makeApp env
mid <- makeDevMiddleware
run port (mid app) `finally` stopGargantext env
startGargantextMock :: PortNumber -> IO ()
startGargantextMock port = do
......
This diff is collapsed.
......@@ -46,7 +46,7 @@ import Data.Time (UTCTime)
import GHC.Generics (Generic)
import Servant
import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, HasRepoVar, HasRepoSaver)
import Gargantext.Prelude
import Gargantext.Database.Types.Node
import Gargantext.Database.Utils -- (Cmd, CmdM)
......@@ -72,7 +72,10 @@ import Gargantext.Database.Types.Node (CorpusId, ContactId)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
type GargServer api =
forall env m.
(CmdM env ServantErr m, HasRepoVar env, HasRepoSaver env)
=> ServerT api m
-------------------------------------------------------------------
-- TODO-ACCESS: access by admin only.
......@@ -279,7 +282,7 @@ graphAPI nId = do
nodeGraph <- getNode nId HyperdataGraph
let title = "Graph Title"
let title = "Title"
let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph]
[ LegendField 1 "#FFF" "Cluster"
, LegendField 2 "#FFF" "Cluster"
......
......@@ -17,25 +17,31 @@ Portability : POSIX
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.API.Settings
where
import System.Directory
import System.Log.FastLogger
import GHC.Enum
import GHC.Generics (Generic)
import Prelude (Bounded())
import Prelude (Bounded(), fail)
import System.Environment (lookupEnv)
import System.IO (FilePath)
import Database.PostgreSQL.Simple (Connection, connect)
import Network.HTTP.Client (Manager)
import Network.HTTP.Client.TLS (newTlsManager)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Either (either)
import Data.JsonState (mkSaveState)
import Data.Text
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Units
import Data.ByteString.Lazy.Internal
import Servant
......@@ -45,10 +51,14 @@ import Web.HttpApiData (parseUrlPiece)
import qualified Jose.Jwk as Jose
import qualified Jose.Jwa as Jose
import Control.Concurrent
import Control.Exception (finally)
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Lens
import Gargantext.Prelude
import Gargantext.Database.Utils (databaseParameters, HasConnection(..))
import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), initMockRepo, r_version, saveRepo)
import Gargantext.API.Orchestrator.Types
type PortNumber = Int
......@@ -125,12 +135,14 @@ optSetting name d = do
data FireWall = FireWall { unFireWall :: Bool }
data Env = Env
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
, _env_conn :: !Connection
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
, _env_conn :: !Connection
, _env_repo_var :: !(MVar NgramsRepo)
, _env_repo_saver :: !(IO ())
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv
}
deriving (Generic)
......@@ -139,6 +151,12 @@ makeLenses ''Env
instance HasConnection Env where
connection = env_conn
instance HasRepoVar Env where
repoVar = env_repo_var
instance HasRepoSaver Env where
repoSaver = env_repo_saver
data MockEnv = MockEnv
{ _menv_firewall :: !FireWall
}
......@@ -146,22 +164,109 @@ data MockEnv = MockEnv
makeLenses ''MockEnv
repoSnapshot :: FilePath
repoSnapshot = "repo.json"
readRepo :: IO (MVar NgramsRepo)
readRepo = do
-- | Does file exist ? :: Bool
repoFile <- doesFileExist repoSnapshot
-- | Is file not empty ? :: Bool
repoExists <- if repoFile
then (>0) <$> getFileSize repoSnapshot
else pure repoFile
newMVar =<<
if repoExists
then do
e_repo <- eitherDecodeFileStrict repoSnapshot
repo <- either fail pure e_repo
let archive = repoSnapshot <> ".v" <> show (repo ^. r_version)
copyFile repoSnapshot archive
pure repo
else
pure initMockRepo
mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
mkRepoSaver repo_var = do
saveAction <- mkSaveState (10 :: Second) repoSnapshot
pure $ readMVar repo_var >>= saveAction
newEnv :: PortNumber -> FilePath -> IO Env
newEnv port file = do
manager <- newTlsManager
settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
when (port /= settings ^. appPort) $
panic "TODO: conflicting settings of port"
self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
param <- databaseParameters file
conn <- connect param
param <- databaseParameters file
conn <- connect param
repo_var <- readRepo
repo_saver <- mkRepoSaver repo_var
scrapers_env <- newJobEnv defaultSettings manager
logger <- newStderrLoggerSet defaultBufSize
pure $ Env
{ _env_settings = settings
, _env_logger = logger
, _env_conn = conn
, _env_manager = manager
, _env_scrapers = scrapers_env
, _env_self_url = self_url
{ _env_settings = settings
, _env_logger = logger
, _env_conn = conn
, _env_repo_var = repo_var
, _env_repo_saver = repo_saver
, _env_manager = manager
, _env_scrapers = scrapers_env
, _env_self_url = self_url
}
data DevEnv = DevEnv
{ _dev_env_conn :: !Connection
, _dev_env_repo_var :: !(MVar NgramsRepo)
, _dev_env_repo_saver :: !(IO ())
}
makeLenses ''DevEnv
instance HasConnection DevEnv where
connection = dev_env_conn
instance HasRepoVar DevEnv where
repoVar = dev_env_repo_var
instance HasRepoSaver DevEnv where
repoSaver = dev_env_repo_saver
newDevEnvWith :: FilePath -> IO DevEnv
newDevEnvWith file = do
param <- databaseParameters file
conn <- connect param
repo_var <- newMVar initMockRepo
repo_saver <- mkRepoSaver repo_var
pure $ DevEnv
{ _dev_env_conn = conn
, _dev_env_repo_var = repo_var
, _dev_env_repo_saver = repo_saver
}
newDevEnv :: IO DevEnv
newDevEnv = newDevEnvWith "gargantext.ini"
-- Use only for dev
-- In particular this writes the repo file after running
-- the command.
-- This function is constrained to the DevEnv rather than
-- using HasConnection and HasRepoVar.
runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
runCmdDev env f =
(either (fail . show) pure =<< runCmd env f)
`finally`
runReaderT saveRepo env
-- Use only for dev
runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
runCmdDevNoErr = runCmdDev
-- Use only for dev
runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServantErr a -> IO a
runCmdDevServantErr = runCmdDev
......@@ -20,14 +20,15 @@ module Gargantext.Database.Cooc where
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Prelude
import Gargantext.Database.Utils (Cmd, runCmdDevNoErr, runPGSQuery)
import Gargantext.Database.Utils (Cmd, runPGSQuery)
import Gargantext.API.Settings (runCmdDevNoErr, DevEnv)
type CorpusId = Int
type MainListId = Int
type GroupListId = Int
coocTest :: IO [(Int, Int, Int)]
coocTest = runCmdDevNoErr $ dBcooc 421968 446602 446599
coocTest :: DevEnv -> IO [(Int, Int, Int)]
coocTest env = runCmdDevNoErr env $ dBcooc 421968 446602 446599
dBcooc :: CorpusId -> MainListId -> GroupListId -> Cmd err [(Int, Int, Int)]
dBcooc corpus mainList groupList = runPGSQuery [sql|
......
This diff is collapsed.
{-|
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-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Lists where
import Control.Arrow (returnA)
import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Schema.Node -- (HasNodeError, queryNodeTable)
import Gargantext.Database.Schema.User -- (queryUserTable)
import Gargantext.Database.Utils
import Gargantext.Prelude hiding (sum, head)
import Opaleye hiding (FromField)
import Opaleye.Internal.QueryArr (Query)
import Prelude hiding (null, id, map, sum)
-- | To get all lists of a user
-- /!\ lists of different types of corpora (Annuaire or Documents)
listsWith :: HasNodeError err => Username -> Cmd err [Maybe ListId]
listsWith u = runOpaQuery (selectLists u)
where
selectLists u = proc () -> do
(auth_user,nodes) <- listsWithJoin2 -< ()
restrict -< user_username auth_user .== (pgStrictText u)
restrict -< _node_typename nodes .== (toNullable $ pgInt4 $ nodeTypeId NodeList)
returnA -< _node_id nodes
listsWithJoin2 :: Query (UserRead, NodeReadNull)
listsWithJoin2 = leftJoin queryUserTable queryNodeTable cond12
where
cond12 (u,n) = user_id u .== _node_userId n
{-
listsWithJoin3 :: Query (NodeRead, (UserRead, NodeReadNull))
listsWithJoin3 = leftJoin3 queryUserTable queryNodeTable queryNodeTable cond12 cond23
where
cond12 :: (NodeRead
cond12 (u,n) = user_id u .== _node_userId n
cond23 :: (NodeRead, (UserRead, NodeReadNull)) -> Column PGBool
cond23 (n1,(u,n2)) = (toNullable $ _node_id n1) .== _node_parentId n2
--}
......@@ -143,4 +143,3 @@ GROUP BY nu.id,nu.terms
|]
......@@ -25,8 +25,10 @@ Ngrams connection to the Database.
module Gargantext.Database.Schema.Ngrams where
import Data.Aeson (FromJSON, FromJSONKey)
import Control.Lens (makeLenses, view, over)
import Control.Monad (mzero)
import Data.Aeson
import Data.ByteString.Internal (ByteString)
import Data.Map (Map, fromList, lookup, fromListWith)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
......@@ -58,13 +60,11 @@ type NgramsTerms = Text
type NgramsId = Int
type Size = Int
--{-
data NgramsPoly id terms n = NgramsDb { ngrams_id :: id
, ngrams_terms :: terms
, ngrams_n :: n
} deriving (Show)
, ngrams_terms :: terms
, ngrams_n :: n
} deriving (Show)
--}
type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
(Column PGText)
(Column PGInt4)
......@@ -77,7 +77,6 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
(Column (Nullable PGText))
(Column (Nullable PGInt4))
--{-
type NgramsDb = NgramsPoly Int Text Int
$(makeAdaptorAndInstance "pNgramsDb" ''NgramsPoly)
......@@ -85,17 +84,16 @@ $(makeAdaptorAndInstance "pNgramsDb" ''NgramsPoly)
ngramsTable :: Table NgramsWrite NgramsRead
ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id = optional "id"
, ngrams_terms = required "terms"
, ngrams_n = required "n"
}
)
--{-
, ngrams_terms = required "terms"
, ngrams_n = required "n"
}
)
queryNgramsTable :: Query NgramsRead
queryNgramsTable = queryTable ngramsTable
dbGetNgramsDb :: Cmd err [NgramsDb]
dbGetNgramsDb = runOpaQuery queryNgramsTable
--}
-- | Main Ngrams Types
-- | Typed Ngrams
......@@ -104,7 +102,12 @@ dbGetNgramsDb = runOpaQuery queryNgramsTable
-- ngrams in authors field of document has Authors Type
-- ngrams in text (title or abstract) of documents has Terms Type
data NgramsType = Authors | Institutes | Sources | NgramsTerms
deriving (Eq, Show, Ord, Enum, Bounded)
deriving (Eq, Show, Ord, Enum, Bounded, Generic)
instance FromJSON NgramsType
instance FromJSONKey NgramsType
instance ToJSON NgramsType
instance ToJSONKey NgramsType
newtype NgramsTypeId = NgramsTypeId Int
deriving (Eq, Show, Ord, Num)
......
......@@ -155,32 +155,33 @@ instance QueryRunnerColumnDefault PGInt4 NodeId
------------------------------------------------------------------------
$(makeAdaptorAndInstance "pNode" ''NodePoly)
$(makeLensesWith abbreviatedFields ''NodePoly)
$(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
$(makeLensesWith abbreviatedFields ''NodePolySearch)
type NodeWrite = NodePoly (Maybe (Column PGInt4 ))
(Column PGInt4 )
(Column PGInt4 )
(Maybe (Column PGInt4 ))
(Column PGText )
(Maybe (Column PGTimestamptz))
(Column PGJsonb )
type NodeRead = NodePoly (Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGText )
(Column PGTimestamptz )
(Column PGJsonb )
type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGText ))
(Column (Nullable PGTimestamptz ))
(Column (Nullable PGJsonb))
type NodeWrite = NodePoly (Maybe (Column PGInt4) )
(Column PGInt4)
(Column PGInt4)
(Maybe (Column PGInt4) )
(Column PGText)
(Maybe (Column PGTimestamptz))
(Column PGJsonb)
type NodeRead = NodePoly (Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGText )
(Column PGTimestamptz )
(Column PGJsonb )
type NodeReadNull = NodePoly (Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGText))
(Column (Nullable PGTimestamptz))
(Column (Nullable PGJsonb))
nodeTable :: Table NodeWrite NodeRead
nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
......@@ -201,32 +202,38 @@ queryNodeTable = queryTable nodeTable
------------------------------------------------------------------------
-- | Node(Read|Write)Search is slower than Node(Write|Read) use it
-- for full text search only
type NodeSearchWrite = NodePolySearch (Maybe (Column PGInt4 ))
(Column PGInt4 )
(Column PGInt4 )
(Column (Nullable PGInt4 ))
(Column (PGText ))
(Maybe (Column PGTimestamptz))
(Column PGJsonb )
(Maybe (Column PGTSVector))
type NodeSearchRead = NodePolySearch (Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column (Nullable PGInt4 ))
(Column (PGText ))
(Column PGTimestamptz )
(Column PGJsonb)
(Column PGTSVector)
type NodeSearchReadNull = NodePolySearch (Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGText ))
(Column (Nullable PGTimestamptz ))
(Column (Nullable PGJsonb))
(Column (Nullable PGTSVector))
type NodeSearchWrite =
NodePolySearch
(Maybe (Column PGInt4) )
(Column PGInt4 )
(Column PGInt4 )
(Column (Nullable PGInt4) )
(Column PGText )
(Maybe (Column PGTimestamptz))
(Column PGJsonb )
(Maybe (Column PGTSVector) )
type NodeSearchRead =
NodePolySearch
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column (Nullable PGInt4 ))
(Column PGText )
(Column PGTimestamptz )
(Column PGJsonb )
(Column PGTSVector )
type NodeSearchReadNull =
NodePolySearch
(Column (Nullable PGInt4) )
(Column (Nullable PGInt4) )
(Column (Nullable PGInt4) )
(Column (Nullable PGInt4) )
(Column (Nullable PGText) )
(Column (Nullable PGTimestamptz))
(Column (Nullable PGJsonb) )
(Column (Nullable PGTSVector) )
--{-
nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
......@@ -336,7 +343,8 @@ type JSONB = QueryRunnerColumnDefault PGJsonb
getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
getNode nId _ = do
fromMaybe (error $ "Node does node exist: " <> show nId) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
getNodesWithType = runOpaQuery . selectNodesWithType
......@@ -502,13 +510,16 @@ childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a c
type Name = Text
-- | TODO mk all others nodes
mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
mkNodeWithParent NodeUser (Just _) _ _ = nodeError UserNoParent
mkNodeWithParent _ Nothing _ _ = nodeError HasParent
mkNodeWithParent nt pId uId name =
insertNodesWithParentR pId [node nt name hd pId uId]
where
hd = HyperdataUser . Just . pack $ show EN
mkNodeWithParent NodeUser (Just _) _ _ = nodeError UserNoParent
mkNodeWithParent NodeUser Nothing uId name =
insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
where
hd = HyperdataUser . Just . pack $ show EN
mkNodeWithParent _ Nothing _ _ = nodeError HasParent
mkNodeWithParent _ _ _ _ = nodeError NotImplYet
mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
mkRoot uname uId = case uId > 0 of
......
CREATE EXTENSION IF NOT EXISTS plpgsql WITH SCHEMA pg_catalog;
COMMENT ON EXTENSION plpgsql IS 'PL/pgSQL procedural language';
-- needed for rights management
-- CREATE EXTENSION IF NOT EXISTS acl WITH SCHEMA public;
-- CREATE USER WITH ...
-- createdb "gargandb"
......@@ -23,6 +21,7 @@ CREATE TABLE public.auth_user (
ALTER TABLE public.auth_user OWNER TO gargantua;
-- TODO add publication_date
-- TODO typename -> type_id
CREATE TABLE public.nodes (
......@@ -40,7 +39,6 @@ CREATE TABLE public.nodes (
ALTER TABLE public.nodes OWNER TO gargantua;
CREATE TABLE public.ngrams (
id SERIAL,
terms character varying(255),
......@@ -49,7 +47,9 @@ CREATE TABLE public.ngrams (
);
ALTER TABLE public.ngrams OWNER TO gargantua;
-- TODO: delete ID
--------------------------------------------------------------
--------------------------------------------------------------
-- TODO: delete delete this table
CREATE TABLE public.nodes_ngrams (
id SERIAL,
node_id integer NOT NULL,
......@@ -64,13 +64,21 @@ CREATE TABLE public.nodes_ngrams (
-- PRIMARY KEY (node_id,ngrams_id)
);
ALTER TABLE public.nodes_ngrams OWNER TO gargantua;
--------------------------------------------------------------
CREATE TABLE public.nodes_ngrams_repo (
version integer NOT NULL,
patches jsonb DEFAULT '{}'::jsonb NOT NULL,
PRIMARY KEY (version)
);
ALTER TABLE public.nodes_ngrams_repo OWNER TO gargantua;
--------------------------------------------------------------
--
-- Name: nodes_ngrams_ngrams; Type: TABLE; Schema: public; Owner: gargantua
--
-- TODO: delete delete this table
CREATE TABLE public.nodes_ngrams_ngrams (
node_id integer NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
node_id integer NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
ngram1_id integer NOT NULL REFERENCES public.ngrams(id) ON DELETE CASCADE,
ngram2_id integer NOT NULL REFERENCES public.ngrams(id) ON DELETE CASCADE,
weight double precision,
......@@ -79,7 +87,7 @@ CREATE TABLE public.nodes_ngrams_ngrams (
ALTER TABLE public.nodes_ngrams_ngrams OWNER TO gargantua;
---------------------------------------------------------
CREATE TABLE public.nodes_nodes (
node1_id integer NOT NULL,
node2_id integer NOT NULL,
......@@ -89,8 +97,23 @@ CREATE TABLE public.nodes_nodes (
PRIMARY KEY (node1_id, node2_id)
);
ALTER TABLE public.nodes_nodes OWNER TO gargantua;
---------------------------------------------------------
-- If needed for rights management at row level
-- CREATE EXTENSION IF NOT EXISTS acl WITH SCHEMA public;
CREATE TABLE public.rights (
user_id INTEGER NOT NULL REFERENCES public.auth_user(id) ON DELETE CASCADE,
node_id INTEGER NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
rights INTEGER NOT NULL,
PRIMARY KEY (user_id, node_id)
);
ALTER TABLE public.rights OWNER TO gargantua;
CREATE INDEX rights_userId_nodeId ON public.rights USING btree (user_id,node_id);
------------------------------------------------------------
-- INDEXES
CREATE UNIQUE INDEX ON public.auth_user(username);
......
......@@ -28,8 +28,7 @@ import Prelude (Enum, Bounded, minBound, maxBound)
import GHC.Generics (Generic)
import Control.Lens hiding (elements)
import qualified Control.Lens as L
import Control.Lens hiding (elements, (&))
import Control.Applicative ((<*>))
import Control.Monad (mzero)
......@@ -41,7 +40,7 @@ import Data.ByteString.Lazy (ByteString)
import Data.Either
import Data.Eq (Eq)
import Data.Monoid (mempty)
import Data.Text (Text, unpack)
import Data.Text (Text, unpack, pack)
import Data.Time (UTCTime)
import Data.Time.Segment (jour, timesAfter, Granularity(D))
import Data.Swagger
......@@ -61,7 +60,7 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
--import Gargantext.Database.Utils
------------------------------------------------------------------------
newtype NodeId = NodeId Int
deriving (Show, Read, Generic, Num, Eq, Ord, Enum)
deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON)
instance ToField NodeId where
toField (NodeId n) = toField n
......@@ -72,8 +71,6 @@ instance FromField NodeId where
if (n :: Int) > 0 then return $ NodeId n
else mzero
instance ToJSON NodeId
instance FromJSON NodeId
instance ToSchema NodeId
instance FromHttpApiData NodeId where
......@@ -237,11 +234,8 @@ instance ToSchema Event where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
------------------------------------------------------------------------
type Text' = Text
instance Arbitrary Text' where
arbitrary = elements ["ici", "la"]
instance Arbitrary Text where
arbitrary = elements $ map (\c -> pack [c]) ['a'..'z']
data Resource = Resource { resource_path :: Maybe Text
, resource_scraper :: Maybe Text
......@@ -324,6 +318,10 @@ data HyperdataList = HyperdataList { hyperdataList_preferences :: Maybe Text
$(deriveJSON (unPrefix "hyperdataList_") ''HyperdataList)
instance Hyperdata HyperdataList
instance Arbitrary HyperdataList where
arbitrary = elements [HyperdataList (Just "from list A")]
------------------------------------------------------------------------
data HyperdataScore = HyperdataScore { hyperdataScore_preferences :: Maybe Text
} deriving (Show, Generic)
......@@ -500,27 +498,24 @@ docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",
instance ToSchema HyperdataCorpus where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "a corpus"
L.& mapped.schema.example ?~ toJSON hyperdataCorpus
& mapped.schema.description ?~ "a corpus"
& mapped.schema.example ?~ toJSON hyperdataCorpus
instance ToSchema HyperdataAnnuaire where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "an annuaire"
L.& mapped.schema.example ?~ toJSON hyperdataAnnuaire
& mapped.schema.description ?~ "an annuaire"
& mapped.schema.example ?~ toJSON hyperdataAnnuaire
instance ToSchema HyperdataDocument where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "a document"
L.& mapped.schema.example ?~ toJSON hyperdataDocument
& mapped.schema.description ?~ "a document"
& mapped.schema.example ?~ toJSON hyperdataDocument
instance ToSchema HyperdataAny where
declareNamedSchema proxy =
pure $ genericNameSchema defaultSchemaOptions proxy mempty
L.& schema.description ?~ "a node"
L.& schema.example ?~ emptyObject -- TODO
& schema.description ?~ "a node"
& schema.example ?~ emptyObject -- TODO
instance ToSchema hyperdata =>
......
......@@ -37,7 +37,6 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
import Database.PostgreSQL.Simple.Internal (Field)
import Gargantext.Prelude
import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
import Servant (ServantErr)
import System.IO (FilePath)
import Text.Read (read)
import qualified Data.ByteString as DB
......@@ -49,13 +48,19 @@ class HasConnection env where
instance HasConnection Connection where
connection = identity
type CmdM env err m =
type CmdM' env err m =
( MonadReader env m
, HasConnection env
, MonadError err m
, MonadIO m
)
type CmdM env err m =
( CmdM' env err m
, HasConnection env
)
type Cmd' env err a = forall m. CmdM' env err m => m a
type Cmd err a = forall m env. CmdM env err m => m a
-- TODO: ideally there should be very few calls to this functions.
......@@ -64,22 +69,10 @@ mkCmd k = do
conn <- view connection
liftIO $ k conn
runCmd :: Connection -> Cmd err a -> IO (Either err a)
runCmd conn m = runExceptT $ runReaderT m conn
-- Use only for dev
runCmdDevWith :: FilePath -> Cmd ServantErr a -> IO a
runCmdDevWith fp f = do
conn <- connectGargandb fp
either (fail . show) pure =<< runCmd conn f
-- Use only for dev
runCmdDev :: Cmd ServantErr a -> IO a
runCmdDev = runCmdDevWith "gargantext.ini"
-- Use only for dev
runCmdDevNoErr :: Cmd () a -> IO a
runCmdDevNoErr = runCmdDevWith "gargantext.ini"
runCmd :: HasConnection env => env
-> Cmd' env err a
-> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runQuery c q
......
......@@ -43,6 +43,7 @@ import Gargantext.Text.Terms (TermType, extractTerms)
import Gargantext.Viz.Graph (Graph(..), data2graph)
import Gargantext.Viz.Graph.Bridgeness (bridgeness)
import Gargantext.Viz.Graph.Distances.Matrice (measureConditional)
--import Gargantext.Viz.Graph.Distances.Matrice (distributional)
import Gargantext.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map)
{-
____ _ _
......@@ -153,7 +154,7 @@ cooc2graph myCooc = do
-- let distance = fromIndex fi distanceMap
--printDebug "distance" $ M.size distance
partitions <- case M.size distanceMap > 0 of
True -> cLouvain distanceMap
False -> panic "Text.Flow: DistanceMap is empty"
......
......@@ -63,7 +63,7 @@ filterCooc' (FilterConfig _ _ _ _ (DefaultValue dv)) ts m = trace ("coocScored "
where
selection = [(x,y) | x <- ts
, y <- ts
-- , x >= y
, x > y
]
......
......@@ -7,7 +7,7 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Specifications of Phylomemy format.
Specifications of Phylomemy export format.
Phylomemy can be described as a Temporal Graph with different scale of
granularity of group of ngrams (terms and multi-terms).
......@@ -39,9 +39,9 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Prelude
------------------------------------------------------------------------
data PhyloFormat =
PhyloFormat { _phyloFormat_param :: PhyloParam
, _phyloFormat_data :: Phylo
data PhyloExport =
PhyloExport { _phyloExport_param :: PhyloParam
, _phyloExport_data :: Phylo
} deriving (Generic)
-- | .phylo parameters
......@@ -66,7 +66,7 @@ data Software =
-- Ngrams : list of all (possible) terms contained in the phylomemy (with their id)
-- Steps : list of all steps to build the phylomemy
data Phylo =
Phylo { _phylo_puration :: (Start, End)
Phylo { _phylo_duration :: (Start, End)
, _phylo_ngrams :: [Ngram]
, _phylo_periods :: [PhyloPeriod]
}
......@@ -109,27 +109,28 @@ type PhyloLevelId = (PhyloPeriodId, Int)
-- Ngrams: set of terms that build the group
-- Period Parents|Childs: weighted link to Parents|Childs (Temporal Period axis)
-- Level Parents|Childs: weighted link to Parents|Childs (Level Granularity axis)
-- Pointers are directed link from Self to any PhyloGroup (/= Self ?)
data PhyloGroup =
PhyloGroup { _phylo_groupId :: PhyloGroupId
, _phylo_groupLabel :: Maybe Text
, _phylo_groupNgrams :: [NgramsId]
, _phylo_groupPeriodParents :: [Edge]
, _phylo_groupPeriodChilds :: [Edge]
, _phylo_groupPeriodParents :: [Pointer]
, _phylo_groupPeriodChilds :: [Pointer]
, _phylo_groupLevelParents :: [Edge]
, _phylo_groupLevelChilds :: [Edge]
, _phylo_groupLevelParents :: [Pointer]
, _phylo_groupLevelChilds :: [Pointer]
}
deriving (Generic)
type PhyloGroupId = (PhyloLevelId, Int)
type Edge = (PhyloGroupId, Weight)
type Pointer = (PhyloGroupId, Weight)
type Weight = Double
-- | Lenses
makeLenses ''Phylo
makeLenses ''PhyloParam
makeLenses ''PhyloFormat
makeLenses ''PhyloExport
makeLenses ''Software
-- | JSON instances
......@@ -138,9 +139,9 @@ $(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
$(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel )
$(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup )
--
$(deriveJSON (unPrefix "_software_" ) ''Software )
$(deriveJSON (unPrefix "_software_" ) ''Software )
$(deriveJSON (unPrefix "_phyloParam_" ) ''PhyloParam )
$(deriveJSON (unPrefix "_phyloFormat_" ) ''PhyloFormat )
$(deriveJSON (unPrefix "_phyloExport_" ) ''PhyloExport )
-- | TODO XML instances
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy tools
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Phylo Toolbox:
- functions to build a Phylo
- functions to filter the cliques
- functions to manage a Phylo
Group Functions (TODO list)
- cohesion sur un groupe
- distance au dernier branchement
- âge du groupe
Futre Idea: temporal zoom on Phylo
phyloZoomOut :: (PeriodGrain, Phylo) -> [(PeriodGrain, Phylo)]
(from smallest granularity, it increases (zoom out) the periods of the Phylo)
Moral idea: viz from out to in
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.Tools where
import Data.Set (Set)
import Data.Map (Map)
import Data.Map as Map hiding (Map)
import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Example
-- | Some types to help reading
type Clique = Set Ngrams
type Support = Int
type MinSize = Int
-- | Building a phylo
-- (Indicative and schematic function)
buildPhylo :: Support -> MinSize
-> Map Clique Support -> Phylo
buildPhylo s m mcs = level2Phylo
. groups2level
. clusters2group
. map clique2cluster
. filterCliques s m
level2Phylo :: PhyloLevel -> Phylo -> Phylo
level2Phylo = undefined
groups2level :: [PhyloGroup] -> PhyloLevel
groups2level = undefined
clusters2group :: [Cluster Ngrams] -> PhyloGroup
clusters2group = undefined
clique2cluster :: Clique -> Cluster Ngrams
clique2cluster = undefined
-- | Filtering the cliques before bulding the Phylo
-- (Support and MinSize as parameter of the finale function to build a phylo)
-- idea: log of Corpus size (of docs)
filterCliques :: Support -> MinSize
-> Map Clique Support -> [Clique]
filterCliques s ms = maximalCliques
. filterWithSizeSet ms
. Map.keys
. filterWithSupport s
-- | Hapaxify / Threshold
-- hapax s = 1
-- ?
filterWithSupport :: Support -> Map Clique Support -> Map Clique Support
filterWithSupport s = Map.filter (>s)
filterWithSizeSet :: MinSize -> [Clique] -> [Clique]
filterWithSizeSet = undefined
-- | filtre les cliques de ngrams compris dans une clique plus grande
-- /!\ optim inside
maximalCliques :: [Clique] -> [Clique]
maximalCliques = undefined
-- | Phylo management
-- | PhyloLevel Management
viewGroups :: (Start,End) -> PhyloLevel -> Phylo -> [PhyloGroup]
viewGroups = undefined
viewLevels :: (Start,End) -> Phylo -> [PhyloLevel]
viewLevels = undefined
-- | tous les terme des champs, tous les parents et les enfants
setGroup :: PhyloGroup -> PhyloGroup -> PhyloGroup
setGroup = undefined
--removeTerms :: recalculer les cliques pour ces termes
--addTerms
......@@ -12,6 +12,8 @@ packages:
allow-newer: true
extra-deps:
- json-state-0.1.0.1
- time-units-1.0.0
- git: https://github.com/delanoe/data-time-segment.git
commit: 4e3d57d80e9dfe6624c8eeaa8595fc8fe64d8723
- git: https://gitlab.iscpif.fr/gargantext/hlcm.git
......@@ -34,4 +36,4 @@ extra-deps:
- servant-flatten-0.2
- servant-multipart-0.11.2
- stemmer-0.5.2
- validity-0.8.0.0 # patches-{map,class}
- validity-0.9.0.0 # patches-{map,class}
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