Skip to content

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

Merge branch 'dev' into dev-doc-table-optimization

parents cc87388f d9f67d62
Pipeline #916 canceled with stage
    Hide whitespace changes
    Inline Side-by-side
    Showing with 238 additions and 52 deletions
    bin/gargantext-import/Main.hs
    View file @ e982e379
    ...@@ -27,7 +27,7 @@ import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpusFile, flowAnnuaire, ...@@ -27,7 +27,7 @@ import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpusFile, flowAnnuaire,
    import Gargantext.Database.Query.Table.User (insertUsersDemo) import Gargantext.Database.Query.Table.User (insertUsersDemo)
    import Gargantext.Database.Admin.Types.Hyperdata (toHyperdataDocument) import Gargantext.Database.Admin.Types.Hyperdata (toHyperdataDocument)
    import Gargantext.Database.Admin.Types.Node (CorpusId) import Gargantext.Database.Admin.Types.Node (CorpusId)
    import Gargantext.Database.Prelude (Cmd, ) import Gargantext.Database.Prelude (Cmd)
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Text.Corpus.Parsers (FileFormat(..)) import Gargantext.Text.Corpus.Parsers (FileFormat(..))
    import Prelude (read) import Prelude (read)
    ......
    gargantext.ini_toModify
    View file @ e982e379
    ...@@ -2,7 +2,10 @@ ...@@ -2,7 +2,10 @@
    MASTER_USER = gargantua MASTER_USER = gargantua
    # SECURITY WARNING: keep the secret key used in production secret! # SECURITY WARNING: keep the secret key used in production secret!
    SECRET_KEY = PASSWORD_TO_CHANGE SECRET_KEY = PASSWORD_TO_CHANGE
    FRAME_WRITE_URL = URL_TO_CHANGE
    FRAME_CALC_URL = URL_TO_CHANGE
    [database] [database]
    # PostgreSQL access # PostgreSQL access
    ......
    package.yaml
    View file @ e982e379
    name: gargantext name: gargantext
    version: '0.0.1.6.3' version: '0.0.1.6.4'
    synopsis: Search, map, share synopsis: Search, map, share
    description: Please see README.md description: Please see README.md
    category: Data category: Data
    ......
    src/Gargantext/API/Admin/Auth.hs
    View file @ e982e379
    ...@@ -41,7 +41,7 @@ import Gargantext.Database.Query.Tree (isDescendantOf, isIn) ...@@ -41,7 +41,7 @@ import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
    import Gargantext.Database.Query.Tree.Root (getRoot) import Gargantext.Database.Query.Tree.Root (getRoot)
    import Gargantext.Database.Schema.Node (NodePoly(_node_id)) import Gargantext.Database.Schema.Node (NodePoly(_node_id))
    import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId, ListId, DocId) import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId, ListId, DocId)
    import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool) import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
    import Gargantext.Prelude hiding (reverse) import Gargantext.Prelude hiding (reverse)
    import Gargantext.Database.Query.Table.User import Gargantext.Database.Query.Table.User
    import Servant import Servant
    ...@@ -90,7 +90,7 @@ makeTokenForUser uid = do ...@@ -90,7 +90,7 @@ makeTokenForUser uid = do
    either joseError (pure . toStrict . decodeUtf8) e either joseError (pure . toStrict . decodeUtf8) e
    -- TODO not sure about the encoding... -- TODO not sure about the encoding...
    checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err) checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env)
    => Username => Username
    -> GargPassword -> GargPassword
    -> Cmd' env err CheckAuth -> Cmd' env err CheckAuth
    ...@@ -109,7 +109,7 @@ checkAuthRequest u (GargPassword p) = do ...@@ -109,7 +109,7 @@ checkAuthRequest u (GargPassword p) = do
    token <- makeTokenForUser uid token <- makeTokenForUser uid
    pure $ Valid token uid pure $ Valid token uid
    auth :: (HasSettings env, HasConnectionPool env, HasJoseError err) auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env)
    => AuthRequest -> Cmd' env err AuthResponse => AuthRequest -> Cmd' env err AuthResponse
    auth (AuthRequest u p) = do auth (AuthRequest u p) = do
    checkAuthRequest' <- checkAuthRequest u p checkAuthRequest' <- checkAuthRequest u p
    ......
    src/Gargantext/API/Admin/Settings.hs
    View file @ e982e379
    ...@@ -35,8 +35,9 @@ import GHC.Enum ...@@ -35,8 +35,9 @@ import GHC.Enum
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
    import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock) import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
    import Gargantext.Database.Prelude (databaseParameters, HasConnectionPool(..), Cmd', runCmd) import Gargantext.Database.Prelude (databaseParameters, HasConnectionPool(..), Cmd', runCmd, HasConfig(..))
    import Gargantext.Prelude import Gargantext.Prelude
    import Network.HTTP.Client (Manager) import Network.HTTP.Client (Manager)
    import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.TLS (newTlsManager)
    import Prelude (Bounded(), fail) import Prelude (Bounded(), fail)
    ...@@ -53,7 +54,7 @@ import System.Log.FastLogger ...@@ -53,7 +54,7 @@ import System.Log.FastLogger
    import Web.HttpApiData (parseUrlPiece) import Web.HttpApiData (parseUrlPiece)
    import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
    import qualified Servant.Job.Core import qualified Servant.Job.Core
    import Gargantext.Config (GargConfig(), readConfig, defaultConfig)
    type PortNumber = Int type PortNumber = Int
    ...@@ -75,6 +76,7 @@ data Settings = Settings ...@@ -75,6 +76,7 @@ data Settings = Settings
    , _sendLoginEmails :: SendEmailType , _sendLoginEmails :: SendEmailType
    , _scrapydUrl :: BaseUrl , _scrapydUrl :: BaseUrl
    , _fileFolder :: FilePath , _fileFolder :: FilePath
    , _config :: GargConfig
    } }
    makeLenses ''Settings makeLenses ''Settings
    ...@@ -86,7 +88,7 @@ devSettings :: FilePath -> IO Settings ...@@ -86,7 +88,7 @@ devSettings :: FilePath -> IO Settings
    devSettings jwkFile = do devSettings jwkFile = do
    jwkExists <- doesFileExist jwkFile jwkExists <- doesFileExist jwkFile
    when (not jwkExists) $ writeKey jwkFile when (not jwkExists) $ writeKey jwkFile
    jwk <- readKey jwkFile jwk <- readKey jwkFile
    pure $ Settings pure $ Settings
    { _allowedOrigin = "http://localhost:8008" { _allowedOrigin = "http://localhost:8008"
    , _allowedHost = "localhost:3000" , _allowedHost = "localhost:3000"
    ...@@ -98,6 +100,7 @@ devSettings jwkFile = do ...@@ -98,6 +100,7 @@ devSettings jwkFile = do
    , _fileFolder = "data" , _fileFolder = "data"
    , _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune , _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
    , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
    , _config = defaultConfig
    } }
    where where
    xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True } xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
    ...@@ -136,11 +139,15 @@ data Env = Env ...@@ -136,11 +139,15 @@ data Env = Env
    , _env_manager :: !Manager , _env_manager :: !Manager
    , _env_self_url :: !BaseUrl , _env_self_url :: !BaseUrl
    , _env_scrapers :: !ScrapersEnv , _env_scrapers :: !ScrapersEnv
    , _env_gargConfig :: !GargConfig
    } }
    deriving (Generic) deriving (Generic)
    makeLenses ''Env makeLenses ''Env
    instance HasConfig Env where
    hasConfig = env_gargConfig
    instance HasConnectionPool Env where instance HasConnectionPool Env where
    connPool = env_pool connPool = env_pool
    ...@@ -191,7 +198,7 @@ mkRepoSaver :: MVar NgramsRepo -> IO (IO ()) ...@@ -191,7 +198,7 @@ mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
    mkRepoSaver repo_var = mkDebounce settings mkRepoSaver repo_var = mkDebounce settings
    where where
    settings = defaultDebounceSettings settings = defaultDebounceSettings
    { debounceFreq = 1000000 -- 1 second { debounceFreq = let n = 6 :: Int in 10^n -- 1 second
    , debounceAction = withMVar repo_var repoSaverAction , debounceAction = withMVar repo_var repoSaverAction
    -- Here this not only `readMVar` but `takeMVar`. -- Here this not only `readMVar` but `takeMVar`.
    -- Namely while repoSaverAction is saving no other change -- Namely while repoSaverAction is saving no other change
    ...@@ -238,17 +245,18 @@ devJwkFile = "dev.jwk" ...@@ -238,17 +245,18 @@ devJwkFile = "dev.jwk"
    newEnv :: PortNumber -> FilePath -> IO Env newEnv :: PortNumber -> FilePath -> IO Env
    newEnv port file = do newEnv port file = do
    manager <- newTlsManager manager <- newTlsManager
    settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file' settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
    when (port /= settings ^. appPort) $ when (port /= settings ^. appPort) $
    panic "TODO: conflicting settings of port" panic "TODO: conflicting settings of port"
    self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
    param <- databaseParameters file param <- databaseParameters file
    pool <- newPool param pool <- newPool param
    repo <- readRepoEnv repo <- readRepoEnv
    scrapers_env <- newJobEnv defaultSettings manager scrapers_env <- newJobEnv defaultSettings manager
    logger <- newStderrLoggerSet defaultBufSize logger <- newStderrLoggerSet defaultBufSize
    config <- readConfig file
    pure $ Env pure $ Env
    { _env_settings = settings { _env_settings = settings
    ...@@ -258,19 +266,24 @@ newEnv port file = do ...@@ -258,19 +266,24 @@ newEnv port file = do
    , _env_manager = manager , _env_manager = manager
    , _env_scrapers = scrapers_env , _env_scrapers = scrapers_env
    , _env_self_url = self_url , _env_self_url = self_url
    , _env_gargConfig = config
    } }
    newPool :: ConnectInfo -> IO (Pool Connection) newPool :: ConnectInfo -> IO (Pool Connection)
    newPool param = createPool (connect param) close 1 (60*60) 8 newPool param = createPool (connect param) close 1 (60*60) 8
    data DevEnv = DevEnv data DevEnv = DevEnv
    { _dev_env_pool :: !(Pool Connection) { _dev_env_pool :: !(Pool Connection)
    , _dev_env_repo :: !RepoEnv , _dev_env_repo :: !RepoEnv
    , _dev_env_settings :: !Settings , _dev_env_settings :: !Settings
    , _dev_env_config :: !GargConfig
    } }
    makeLenses ''DevEnv makeLenses ''DevEnv
    instance HasConfig DevEnv where
    hasConfig = dev_env_config
    instance HasConnectionPool DevEnv where instance HasConnectionPool DevEnv where
    connPool = dev_env_pool connPool = dev_env_pool
    ...@@ -303,10 +316,12 @@ withDevEnv iniPath k = do ...@@ -303,10 +316,12 @@ withDevEnv iniPath k = do
    pool <- newPool param pool <- newPool param
    repo <- readRepoEnv repo <- readRepoEnv
    setts <- devSettings devJwkFile setts <- devSettings devJwkFile
    config <- readConfig iniPath
    pure $ DevEnv pure $ DevEnv
    { _dev_env_pool = pool { _dev_env_pool = pool
    , _dev_env_repo = repo , _dev_env_repo = repo
    , _dev_env_settings = setts , _dev_env_settings = setts
    , _dev_env_config = config
    } }
    -- | Run Cmd Sugar for the Repl (GHCI) -- | Run Cmd Sugar for the Repl (GHCI)
    ......
    src/Gargantext/API/Ngrams.hs
    View file @ e982e379
    ...@@ -123,7 +123,7 @@ import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngrams, ng ...@@ -123,7 +123,7 @@ import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngrams, ng
    import Gargantext.Database.Admin.Config (userMaster) import Gargantext.Database.Admin.Config (userMaster)
    import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
    import Gargantext.Database.Admin.Types.Node (NodeType(..)) import Gargantext.Database.Admin.Types.Node (NodeType(..))
    import Gargantext.Database.Prelude (fromField', HasConnectionPool) import Gargantext.Database.Prelude (fromField', HasConnectionPool, HasConfig)
    import Gargantext.Prelude import Gargantext.Prelude
    import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error) import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
    import Servant hiding (Patch) import Servant hiding (Patch)
    ...@@ -1030,7 +1030,7 @@ getTime' = liftBase $ getTime ProcessCPUTime ...@@ -1030,7 +1030,7 @@ getTime' = liftBase $ getTime ProcessCPUTime
    getTableNgrams :: forall env err m. getTableNgrams :: forall env err m.
    (RepoCmdM env err m, HasNodeError err, HasConnectionPool env) (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
    => NodeType -> NodeId -> TabType => NodeType -> NodeId -> TabType
    -> ListId -> Limit -> Maybe Offset -> ListId -> Limit -> Maybe Offset
    -> Maybe ListType -> Maybe ListType
    ...@@ -1132,7 +1132,7 @@ getTableNgrams _nType nId tabType listId limit_ offset ...@@ -1132,7 +1132,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
    pure tableMap3 pure tableMap3
    scoresRecomputeTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnectionPool env) => NodeId -> TabType -> ListId -> m Int scoresRecomputeTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env) => NodeId -> TabType -> ListId -> m Int
    scoresRecomputeTableNgrams nId tabType listId = do scoresRecomputeTableNgrams nId tabType listId = do
    tableMap <- getNgramsTableMap listId ngramsType tableMap <- getNgramsTableMap listId ngramsType
    _ <- tableMap & v_data %%~ setScores _ <- tableMap & v_data %%~ setScores
    ...@@ -1221,7 +1221,7 @@ type TableNgramsApi = TableNgramsApiGet ...@@ -1221,7 +1221,7 @@ type TableNgramsApi = TableNgramsApiGet
    :<|> TableNgramsApiPost :<|> TableNgramsApiPost
    :<|> RecomputeScoresNgramsApiGet :<|> RecomputeScoresNgramsApiGet
    getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env) getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
    => NodeId -> TabType => NodeId -> TabType
    -> ListId -> Limit -> Maybe Offset -> ListId -> Limit -> Maybe Offset
    -> Maybe ListType -> Maybe ListType
    ...@@ -1235,7 +1235,7 @@ getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize o ...@@ -1235,7 +1235,7 @@ getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize o
    searchQuery = maybe (const True) isInfixOf mt searchQuery = maybe (const True) isInfixOf mt
    -- | Text search is deactivated for now for ngrams by doc only -- | Text search is deactivated for now for ngrams by doc only
    getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env) getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
    => DocId -> TabType => DocId -> TabType
    -> ListId -> Limit -> Maybe Offset -> ListId -> Limit -> Maybe Offset
    -> Maybe ListType -> Maybe ListType
    ...@@ -1256,6 +1256,7 @@ apiNgramsTableCorpus :: ( RepoCmdM env err m ...@@ -1256,6 +1256,7 @@ apiNgramsTableCorpus :: ( RepoCmdM env err m
    , HasNodeError err , HasNodeError err
    , HasInvalidError err , HasInvalidError err
    , HasConnectionPool env , HasConnectionPool env
    , HasConfig env
    ) )
    => NodeId -> ServerT TableNgramsApi m => NodeId -> ServerT TableNgramsApi m
    apiNgramsTableCorpus cId = getTableNgramsCorpus cId apiNgramsTableCorpus cId = getTableNgramsCorpus cId
    ...@@ -1267,6 +1268,7 @@ apiNgramsTableDoc :: ( RepoCmdM env err m ...@@ -1267,6 +1268,7 @@ apiNgramsTableDoc :: ( RepoCmdM env err m
    , HasNodeError err , HasNodeError err
    , HasInvalidError err , HasInvalidError err
    , HasConnectionPool env , HasConnectionPool env
    , HasConfig env
    ) )
    => DocId -> ServerT TableNgramsApi m => DocId -> ServerT TableNgramsApi m
    apiNgramsTableDoc dId = getTableNgramsDoc dId apiNgramsTableDoc dId = getTableNgramsDoc dId
    ......
    src/Gargantext/API/Node.hs
    View file @ e982e379
    ...@@ -35,39 +35,37 @@ import Data.Maybe ...@@ -35,39 +35,37 @@ import Data.Maybe
    import Data.Swagger import Data.Swagger
    import Data.Text (Text()) import Data.Text (Text())
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Servant
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    import Gargantext.API.Admin.Auth (withAccess, PathId(..)) import Gargantext.API.Admin.Auth (withAccess, PathId(..))
    import Gargantext.API.Prelude
    import Gargantext.API.Metrics import Gargantext.API.Metrics
    import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus) import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus)
    import Gargantext.API.Node.New import Gargantext.API.Node.New
    import qualified Gargantext.API.Node.Share as Share import Gargantext.API.Prelude
    import qualified Gargantext.API.Node.Update as Update
    import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs) import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
    import Gargantext.API.Table import Gargantext.API.Table
    import Gargantext.Core.Types (NodeTableResult) import Gargantext.Core.Types (NodeTableResult)
    import Gargantext.Core.Types.Individu (User(..))
    import Gargantext.Core.Types.Main (Tree, NodeTree) import Gargantext.Core.Types.Main (Tree, NodeTree)
    import Gargantext.Database.Action.Flow.Pairing (pairing) import Gargantext.Database.Action.Flow.Pairing (pairing)
    import Gargantext.Database.Admin.Types.Node
    import Gargantext.Database.Prelude -- (Cmd, CmdM)
    import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..)) import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
    import Gargantext.Core.Types.Individu (User(..))
    import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node
    import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
    import Gargantext.Database.Query.Table.Node.Children (getChildren) import Gargantext.Database.Query.Table.Node.Children (getChildren)
    import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
    import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
    import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
    import Gargantext.Database.Query.Table.Node.User import Gargantext.Database.Query.Table.Node.User
    import Gargantext.Database.Query.Tree (tree, TreeMode(..))
    import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
    import Gargantext.Database.Admin.Types.Node
    import Gargantext.Database.Prelude -- (Cmd, CmdM)
    import Gargantext.Database.Query.Table.NodeNode import Gargantext.Database.Query.Table.NodeNode
    import Gargantext.Database.Query.Tree (tree, TreeMode(..))
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI) import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
    import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..)) import Servant
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    import qualified Gargantext.API.Node.Share as Share
    import qualified Gargantext.API.Node.Update as Update
    import qualified Gargantext.Database.Action.Delete as Action (deleteNode) import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
    import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
    {- {-
    import qualified Gargantext.Text.List.Learn as Learn import qualified Gargantext.Text.List.Learn as Learn
    ...@@ -313,5 +311,5 @@ moveNode :: User ...@@ -313,5 +311,5 @@ moveNode :: User
    -> ParentId -> ParentId
    -> Cmd err [Int] -> Cmd err [Int]
    moveNode _u n p = update (Move n p) moveNode _u n p = update (Move n p)
    -------------------------------------------------------------
    ------------------------------------------------------------- -------------------------------------------------------------
    src/Gargantext/API/Node/Get.hs 0 → 100644
    View file @ e982e379
    {-|
    Module : Gargantext.API.Node.Get
    Description :
    Copyright : (c) CNRS, 2017-Present
    License : AGPL + CECILL v3
    Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    Polymorphic Get Node API
    -}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeOperators #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-}
    module Gargantext.API.Node.Get
    where
    -- import Gargantext.API.Admin.Settings (HasSettings)
    -- import Servant.Job.Async (JobFunction(..), serveJobsAPI)
    -- import Test.QuickCheck (elements)
    -- import Gargantext.Database.Action.Flow.Types (FlowCmdM)
    import Data.Aeson
    import Data.Swagger
    import GHC.Generics (Generic)
    import Gargantext.API.Prelude
    import Gargantext.Database.Admin.Types.Node
    import Gargantext.Database.Query.Table.Node (JSONB{-, getNodeWith-})
    import Gargantext.Prelude
    import Servant
    import Test.QuickCheck.Arbitrary
    ------------------------------------------------------------------------
    type API a = Summary "Polymorphic Get Node Endpoint"
    :> ReqBody '[JSON] GetNodeParams
    :> Get '[JSON] (Node a)
    ------------------------------------------------------------------------
    data GetNodeParams = GetNodeParams { node_id :: NodeId
    , nodetype :: NodeType
    }
    deriving (Generic)
    ----------------------------------------------------------------------
    api :: forall proxy a.
    ( JSONB a
    , FromJSON a
    , ToJSON a
    ) => proxy a -> UserId -> NodeId -> GargServer (API a)
    api _p _uId _nId (GetNodeParams _nId' _nt) = undefined
    ------------------------------------------------------------------------
    instance FromJSON GetNodeParams where
    parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
    instance ToJSON GetNodeParams where
    toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
    instance ToSchema GetNodeParams
    instance Arbitrary GetNodeParams where
    arbitrary = GetNodeParams <$> arbitrary <*> arbitrary
    ------------------------------------------------------------------------
    src/Gargantext/API/Prelude.hs
    View file @ e982e379
    ...@@ -83,6 +83,7 @@ type GargServerC env err m = ...@@ -83,6 +83,7 @@ type GargServerC env err m =
    , HasRepo env , HasRepo env
    , HasSettings env , HasSettings env
    , HasJobEnv env JobLog JobLog , HasJobEnv env JobLog JobLog
    , HasConfig env
    ) )
    type GargServerT env err m api = GargServerC env err m => ServerT api m type GargServerT env err m api = GargServerC env err m => ServerT api m
    ...@@ -96,9 +97,10 @@ type GargServerM env err = ReaderT env (ExceptT err IO) ...@@ -96,9 +97,10 @@ type GargServerM env err = ReaderT env (ExceptT err IO)
    type EnvC env = type EnvC env =
    ( HasConnectionPool env ( HasConnectionPool env
    , HasRepo env , HasRepo env
    , HasSettings env , HasSettings env
    , HasJobEnv env JobLog JobLog , HasJobEnv env JobLog JobLog
    , HasConfig env
    ) )
    ------------------------------------------------------------------- -------------------------------------------------------------------
    ......
    src/Gargantext/Config.hs 0 → 100644
    View file @ e982e379
    {-|
    Module : Gargantext.Config
    Description : Textmining Collaborative Platform
    Copyright : (c) CNRS, 2017-Present
    License : AGPL + CECILL v3
    Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    -}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.Config where
    import System.IO (FilePath)
    import Data.Ini (readIniFile, lookupValue)
    import Data.Either.Extra (Either(Left, Right))
    import Gargantext.Prelude
    import Data.Text (Text, pack)
    import GHC.Generics (Generic)
    import Control.Lens (makeLenses)
    data GargConfig = GargConfig { _gc_masteruser :: Text
    , _gc_secretkey :: Text
    , _gc_frame_write_url :: Text
    , _gc_frame_calc_url :: Text
    }
    deriving (Generic)
    makeLenses ''GargConfig
    readConfig :: FilePath -> IO GargConfig
    readConfig fp = do
    ini <- readIniFile fp
    let ini'' = case ini of
    Left e -> panic (pack $ "No ini file error" <> show e)
    Right ini' -> ini'
    let val x = case (lookupValue (pack "gargantext") (pack x) ini'') of
    Left _ -> panic (pack $ "no" <> x)
    Right p' -> p'
    pure $ GargConfig (val "MASTER_USER")
    (val "SECRET_KEY")
    (val "FRAME_WRITE_URL")
    (val "FRAME_CALC_URL")
    defaultConfig :: GargConfig
    defaultConfig = GargConfig "gargantua" "secret" "https://frame_write.url" "https://frame_calc.url"
    src/Gargantext/Database/Action/Node.hs
    View file @ e982e379
    ...@@ -20,19 +20,22 @@ Portability : POSIX ...@@ -20,19 +20,22 @@ Portability : POSIX
    module Gargantext.Database.Action.Node module Gargantext.Database.Action.Node
    where where
    import Protolude
    import Gargantext.Core.Types (Name) import Gargantext.Core.Types (Name)
    import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
    import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
    import Gargantext.Database.Prelude (Cmd)
    import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node
    import Gargantext.Database.Query.Table.Node.User
    import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
    import Gargantext.Database.Prelude (Cmd) import Gargantext.Database.Query.Table.Node.User
    import Gargantext.Prelude
    import Gargantext.Prelude.Utils (sha)
    import Gargantext.Database.Prelude
    import Control.Lens (view)
    import Gargantext.Config (GargConfig(..))
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- | TODO mk all others nodes -- | TODO mk all others nodes
    mkNodeWithParent :: HasNodeError err mkNodeWithParent :: (HasNodeError err)
    => NodeType => NodeType
    -> Maybe ParentId -> Maybe ParentId
    -> UserId -> UserId
    ...@@ -91,5 +94,22 @@ mkNodeWithParent NodeGraph (Just i) uId _name = ...@@ -91,5 +94,22 @@ mkNodeWithParent NodeGraph (Just i) uId _name =
    where where
    hd = arbitraryGraph hd = arbitraryGraph
    mkNodeWithParent NodeFrameWrite (Just i) uId name = do
    config <- view hasConfig
    let
    u = _gc_frame_write_url config
    s = _gc_secretkey config
    hd = HyperdataFrame u (sha $ s <> (cs $ show i))
    insertNodesWithParentR (Just i) [node NodeFrameWrite name hd Nothing uId]
    mkNodeWithParent NodeFrameCalc (Just i) uId name = do
    config <- view hasConfig
    let
    u = _gc_frame_calc_url config
    s = _gc_secretkey config
    hd = HyperdataFrame u (sha $ s <> (cs $ show i))
    insertNodesWithParentR (Just i) [node NodeFrameCalc name hd Nothing uId]
    mkNodeWithParent _ _ _ _ = nodeError NotImplYet mkNodeWithParent _ _ _ _ = nodeError NotImplYet
    src/Gargantext/Database/Admin/Config.hs
    View file @ e982e379
    ...@@ -66,6 +66,9 @@ nodeTypeId n = ...@@ -66,6 +66,9 @@ nodeTypeId n =
    NodeDashboard -> 71 NodeDashboard -> 71
    NodeNoteBook -> 88 NodeNoteBook -> 88
    NodeFrameWrite -> 991
    NodeFrameCalc -> 992
    -- Cooccurrences -> 9 -- Cooccurrences -> 9
    -- --
    -- Specclusion -> 11 -- Specclusion -> 11
    ......
    src/Gargantext/Database/Admin/Types/Hyperdata.hs
    View file @ e982e379
    ...@@ -195,6 +195,16 @@ $(makeLenses ''HyperdataCorpus) ...@@ -195,6 +195,16 @@ $(makeLenses ''HyperdataCorpus)
    instance Hyperdata HyperdataCorpus instance Hyperdata HyperdataCorpus
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    data HyperdataFrame =
    HyperdataFrame { base :: !Text
    , frame_id :: !Text
    }
    deriving (Generic)
    $(deriveJSON (unPrefix "") ''HyperdataFrame)
    $(makeLenses ''HyperdataFrame)
    instance Hyperdata HyperdataFrame
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    docExample :: ByteString docExample :: ByteString
    docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",\"publication_minute\":0,\"publication_month\":7,\"language_iso3\":\"eng\",\"publication_second\":0,\"authors\":\"Nils Hovdenak, Kjell Haram\",\"publication_year\":2012,\"publication_date\":\"2012-07-06 00:00:00+00:00\",\"language_name\":\"English\",\"realdate_full_\":\"2012 01 12\",\"source\":\"European journal of obstetrics, gynecology, and reproductive biology\",\"abstract\":\"The literature was searched for publications on minerals and vitamins during pregnancy and the possible influence of supplements on pregnancy outcome.\",\"title\":\"Influence of mineral and vitamin supplements on pregnancy outcome.\",\"publication_hour\":0}" docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",\"publication_minute\":0,\"publication_month\":7,\"language_iso3\":\"eng\",\"publication_second\":0,\"authors\":\"Nils Hovdenak, Kjell Haram\",\"publication_year\":2012,\"publication_date\":\"2012-07-06 00:00:00+00:00\",\"language_name\":\"English\",\"realdate_full_\":\"2012 01 12\",\"source\":\"European journal of obstetrics, gynecology, and reproductive biology\",\"abstract\":\"The literature was searched for publications on minerals and vitamins during pregnancy and the possible influence of supplements on pregnancy outcome.\",\"title\":\"Influence of mineral and vitamin supplements on pregnancy outcome.\",\"publication_hour\":0}"
    ......
    src/Gargantext/Database/Admin/Types/Node.hs
    View file @ e982e379
    ...@@ -250,8 +250,6 @@ data NodeType = NodeUser ...@@ -250,8 +250,6 @@ data NodeType = NodeUser
    | NodeDashboard | NodeChart | NodeNoteBook | NodeDashboard | NodeChart | NodeNoteBook
    | NodeList | NodeListModel | NodeList | NodeListModel
    | NodeListCooc | NodeListCooc
    deriving (Show, Read, Eq, Generic, Bounded, Enum)
    {- {-
    -- | Metrics -- | Metrics
    ...@@ -259,6 +257,12 @@ data NodeType = NodeUser ...@@ -259,6 +257,12 @@ data NodeType = NodeUser
    -- | Classification -- | Classification
    -} -}
    -- Optional Nodes
    | NodeFrameWrite | NodeFrameCalc
    deriving (Show, Read, Eq, Generic, Bounded, Enum)
    allNodeTypes :: [NodeType] allNodeTypes :: [NodeType]
    allNodeTypes = [minBound ..] allNodeTypes = [minBound ..]
    ...@@ -272,6 +276,8 @@ instance FromHttpApiData NodeType ...@@ -272,6 +276,8 @@ instance FromHttpApiData NodeType
    instance ToParamSchema NodeType instance ToParamSchema NodeType
    instance ToSchema NodeType instance ToSchema NodeType
    instance Arbitrary NodeType where
    arbitrary = elements allNodeTypes
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- Instances -- Instances
    ......
    src/Gargantext/Database/Prelude.hs
    View file @ e982e379
    ...@@ -13,7 +13,6 @@ Portability : POSIX ...@@ -13,7 +13,6 @@ Portability : POSIX
    module Gargantext.Database.Prelude where module Gargantext.Database.Prelude where
    import Control.Exception import Control.Exception
    import Control.Lens (Getter, view) import Control.Lens (Getter, view)
    import Control.Monad.Error.Class -- (MonadError(..), Error) import Control.Monad.Error.Class -- (MonadError(..), Error)
    ...@@ -35,6 +34,7 @@ import Database.PostgreSQL.Simple (Connection, connect) ...@@ -35,6 +34,7 @@ import Database.PostgreSQL.Simple (Connection, connect)
    import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError) import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
    import Database.PostgreSQL.Simple.Internal (Field) import Database.PostgreSQL.Simple.Internal (Field)
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Config (GargConfig())
    import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery) import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
    import Opaleye.Aggregate (countRows) import Opaleye.Aggregate (countRows)
    import System.IO (FilePath) import System.IO (FilePath)
    ...@@ -52,6 +52,13 @@ class HasConnectionPool env where ...@@ -52,6 +52,13 @@ class HasConnectionPool env where
    instance HasConnectionPool (Pool Connection) where instance HasConnectionPool (Pool Connection) where
    connPool = identity connPool = identity
    class HasConfig env where
    hasConfig :: Getter env GargConfig
    instance HasConfig GargConfig where
    hasConfig = identity
    -------------------------------------------------------
    type CmdM' env err m = type CmdM' env err m =
    ( MonadReader env m ( MonadReader env m
    , MonadError err m , MonadError err m
    ...@@ -61,6 +68,7 @@ type CmdM' env err m = ...@@ -61,6 +68,7 @@ type CmdM' env err m =
    type CmdM env err m = type CmdM env err m =
    ( CmdM' env err m ( CmdM' env err m
    , HasConnectionPool env , HasConnectionPool env
    , HasConfig env
    ) )
    type Cmd' env err a = forall m. CmdM' env err m => m a type Cmd' env err a = forall m. CmdM' env err m => m a
    ...@@ -99,7 +107,7 @@ runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b] ...@@ -99,7 +107,7 @@ runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
    runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
    runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m, runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
    PGS.FromRow r, PGS.ToRow q, HasConnectionPool env) PGS.FromRow r, PGS.ToRow q, HasConnectionPool env, HasConfig env)
    => PGS.Query -> q -> m [r] => PGS.Query -> q -> m [r]
    runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn) runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
    where where
    ......
    src/Gargantext/Database/Query/Table/Node.hs
    View file @ e982e379
    ...@@ -167,6 +167,8 @@ nodeContactW maybeName maybeContact aId = ...@@ -167,6 +167,8 @@ nodeContactW maybeName maybeContact aId =
    defaultFolder :: HyperdataCorpus defaultFolder :: HyperdataCorpus
    defaultFolder = defaultCorpus defaultFolder = defaultCorpus
    nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
    nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid) nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
    where where
    ......
    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