Skip to content

haskell-gargantext
haskell-gargantext
Commit 6116a39e authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[DEV] -> [STABLE]

parents aa583794 f182259f
Pipeline #4652 failed with stage
    in 21 seconds
    Expand all Hide whitespace changes
    Inline Side-by-side
    Showing with 3222 additions and 1282 deletions
    bin/gargantext-adaptative-phylo/Main.hs
    View file @ 6116a39e
    ......@@ -26,7 +26,7 @@ import Data.ByteString.Lazy (ByteString)
    import Data.Maybe (isJust, fromJust)
    import Data.List (concat, nub, isSuffixOf, take)
    import Data.String (String)
    import Data.Text (Text, unwords)
    import Data.Text (Text, unwords, unpack)
    import Gargantext.Prelude
    import Gargantext.Database.Types.Node (HyperdataDocument(..))
    ......@@ -36,7 +36,10 @@ import Gargantext.Text.Corpus.Parsers (FileFormat(..),parseFile)
    import Gargantext.Text.List.CSV (csvGraphTermList)
    import Gargantext.Text.Terms.WithList (Patterns, buildPatterns, extractTermsWithList)
    import Gargantext.Viz.AdaptativePhylo
    import Gargantext.Viz.Phylo.PhyloMaker (toPhylo)
    import Gargantext.Viz.Phylo.PhyloMaker (toPhylo)
    import Gargantext.Viz.Phylo.PhyloTools (printIOMsg, printIOComment)
    import Gargantext.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
    -- import Gargantext.Viz.Phylo.SynchronicClustering (synchronicDistance')
    import GHC.IO (FilePath)
    import Prelude (Either(..))
    ......@@ -54,21 +57,6 @@ import qualified Gargantext.Text.Corpus.Parsers.CSV as Csv
    ---------------
    -- | To print an important message as an IO()
    printIOMsg :: String -> IO ()
    printIOMsg msg =
    putStrLn ( "\n"
    <> "------------"
    <> "\n"
    <> "-- | " <> msg <> "\n" )
    -- | To print a comment as an IO()
    printIOComment :: String -> IO ()
    printIOComment cmt =
    putStrLn ( "\n" <> cmt <> "\n" )
    -- | To get all the files in a directory or just a file
    getFilesFromPath :: FilePath -> IO([FilePath])
    getFilesFromPath path = do
    ......@@ -166,6 +154,23 @@ main = do
    printIOComment (show (length corpus) <> " parsed docs from the corpus")
    printIOMsg "Reconstruct the Phylo"
    let phylo = toPhylo corpus mapList config
    printIOMsg "End of reconstruction"
    \ No newline at end of file
    -- | probes
    -- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_synchronic_distance_cumu_jaccard.txt")
    -- $ synchronicDistance' phylo 1
    -- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_inflexion_points.txt")
    -- $ inflexionPoints phylo 1
    printIOMsg "End of reconstruction, start the export"
    let dot = toPhyloExport phylo
    let output = (outputPath config)
    <> (unpack $ phyloName config)
    <> "_V2.dot"
    dotToFile output dot
    \ No newline at end of file
    bin/gargantext-import/Main.hs
    View file @ 6116a39e
    ......@@ -23,14 +23,14 @@ import Data.Either
    import Prelude (read)
    import Control.Exception (finally)
    import Gargantext.Prelude
    import Gargantext.Database.Flow (FlowCmdM, flowCorpusFile)
    import Gargantext.Database.Flow (FlowCmdM, flowCorpusFile, flowAnnuaire)
    import Gargantext.Text.Corpus.Parsers (FileFormat(..))
    import Gargantext.Database.Utils (Cmd, )
    import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument)
    import Gargantext.Database.Schema.User (insertUsersDemo)
    import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Core (Lang(..))
    import Gargantext.API -- (GargError)
    import Gargantext.API.Types (GargError)
    import Gargantext.API.Node () -- instances
    import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
    import System.Environment (getArgs)
    ......@@ -41,9 +41,10 @@ import Control.Monad.IO.Class (liftIO)
    main :: IO ()
    main = do
    [userCreate, user, name, iniPath, limit, corpusPath] <- getArgs
    [fun, user, name, iniPath, limit, corpusPath] <- getArgs
    --{-
    let createUsers :: Cmd GargError Int64
    createUsers = insertUsersDemo
    ......@@ -51,8 +52,16 @@ main = do
    --tt = (Unsupervised EN 6 0 Nothing)
    tt = (Multi EN)
    format = CsvGargV3 -- CsvHalFormat --WOS
    cmd :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
    cmd = flowCorpusFile (cs user) (Left (cs name :: Text)) (read limit :: Int) tt format corpusPath
    corpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
    corpus = flowCorpusFile (cs user) (Left (cs name :: Text)) (read limit :: Int) tt format corpusPath
    corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
    corpusCsvHal = flowCorpusFile (cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHalFormat corpusPath
    annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
    annuaire = flowAnnuaire (cs user) (Left "Annuaire") (Multi EN) corpusPath
    {-
    let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
    debatCorpus = do
    ......@@ -64,13 +73,23 @@ main = do
    flowCorpus (Text.pack user) (Text.pack name) (Multi FR) (map (map toHyperdataDocument) docs)
    --}
    withDevEnv iniPath $ \env -> do
    _ <- if userCreate == "true"
    _ <- if fun == "users"
    then runCmdDev env createUsers
    else pure 0 --(cs "false")
    _ <- runCmdDev env cmd
    _ <- if fun == "corpus"
    then runCmdDev env corpus
    else pure 0 --(cs "false")
    _ <- if fun == "corpusCsvHal"
    then runCmdDev env corpusCsvHal
    else pure 0 --(cs "false")
    _ <- if fun == "annuaire"
    then runCmdDev env annuaire
    else pure 0
    {-
    _ <- if corpusType == "csv"
    then runCmdDev env csvCorpus
    ......
    bin/gargantext-init/Main.hs
    View file @ 6116a39e
    ......@@ -28,7 +28,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
    import Gargantext.Database.Schema.User (insertUsersDemo, UserId)
    import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Core (Lang(..))
    import Gargantext.API -- (GargError)
    import Gargantext.API.Types (GargError)
    import Gargantext.API.Node () -- instances
    import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
    --import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))
    ......@@ -42,7 +42,7 @@ main = do
    let createUsers :: Cmd GargError Int64
    createUsers = insertUsersDemo
    let
    mkRoots :: Cmd GargError (UserId, RootId)
    mkRoots = getOrMkRoot "user1"
    ......
    devops/docker/Dockerfile
    View file @ 6116a39e
    from fpco/stack-build:lts-12.26
    from fpco/stack-build:lts-14.6
    RUN apt-get update && \
    apt-get install -y git libigraph0-dev && \
    ......
    devops/docker/docker-postgres
    View file @ 6116a39e
    ......@@ -4,6 +4,6 @@ docker rm --volumes dbgarg || :
    export PGPASSWORD="$(grep DB_PASS gargantext.ini | \awk '{print $3}')"
    docker run --name dbgarg -e POSTGRES_USER=gargantua -e POSTGRES_DB=gargandbV5 -e POSTGRES_PASSWORD=${PGPASSWORD} -d postgres
    sleep 3
    docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < src/Gargantext/Database/Schema/schema.sql
    docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < devops/postgres/schema.sql
    #docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < gargantext.dump
    #docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres dropdb -h postgres -U gargantua gargandbV5
    devops/postgres/schema.sql
    View file @ 6116a39e
    ......@@ -134,17 +134,20 @@ CREATE INDEX ON public.rights USING btree (user_id,node_id);
    CREATE INDEX ON public.nodes USING gin (hyperdata);
    CREATE INDEX ON public.nodes USING btree (user_id, typename, parent_id);
    CREATE INDEX ON public.nodes USING btree (typename, id);
    CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqId'::text)));
    CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqIdBdd'::text)));
    CREATE UNIQUE INDEX ON public.nodes USING btree (typename, parent_id, ((hyperdata ->> 'uniqId'::text)));
    CREATE UNIQUE INDEX ON public.ngrams (terms); -- TEST GIN
    CREATE INDEX ON public.ngrams USING btree (id, terms);
    CREATE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id, category);
    CREATE UNIQUE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id);
    CREATE UNIQUE INDEX ON public.node_node_ngrams USING btree (node1_id, node2_id, ngrams_id, ngrams_type);
    create INDEX on public.node_node_ngrams USING btree (node1_id, node2_id);
    CREATE INDEX ON public.node_node_ngrams USING btree (node1_id, node2_id);
    CREATE INDEX ON public.node_node_ngrams USING btree (ngrams_id, node2_id);
    -- TRIGGERS
    -- TODO user haskell-postgresql-simple to create this function
    ......@@ -154,10 +157,10 @@ RETURNS trigger AS $$
    begin
    IF new.typename = 4 AND new.hyperdata @> '{"language_iso2":"EN"}' THEN
    new.search := to_tsvector( 'english' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
    ELSIF new.typename = 4 AND new.hyperdata @> '{"language_iso2":"FR"}' THEN
    new.search := to_tsvector( 'french' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
    ELSIF new.typename = 41 THEN
    new.search := to_tsvector( 'french' , (new.hyperdata ->> 'prenom')
    || ' ' || (new.hyperdata ->> 'nom')
    ......@@ -191,6 +194,3 @@ UPDATE nodes SET hyperdata = hyperdata;
    package.yaml
    View file @ 6116a39e
    ......@@ -33,6 +33,7 @@ library:
    # - Gargantext.API.Orchestrator
    - Gargantext.API.Search
    - Gargantext.API.Settings
    - Gargantext.API.Types
    - Gargantext.Core
    - Gargantext.Core.Types
    - Gargantext.Core.Types.Main
    ......@@ -71,6 +72,9 @@ library:
    - Gargantext.Viz.AdaptativePhylo
    - Gargantext.Viz.Phylo.PhyloMaker
    - Gargantext.Viz.Phylo.Tools
    - Gargantext.Viz.Phylo.PhyloTools
    - Gargantext.Viz.Phylo.PhyloExport
    - Gargantext.Viz.Phylo.SynchronicClustering
    - Gargantext.Viz.Phylo.Example
    - Gargantext.Viz.Phylo.LevelMaker
    - Gargantext.Viz.Phylo.View.Export
    ......@@ -82,11 +86,13 @@ library:
    - aeson
    - aeson-lens
    - aeson-pretty
    - argon2
    - async
    - attoparsec
    - auto-update
    - base >=4.7 && <5
    - base16-bytestring
    - base64-bytestring
    - blaze-html
    - blaze-markup
    - blaze-svg
    ......@@ -94,6 +100,7 @@ library:
    - case-insensitive
    - cassava
    #- charsetdetect-ae # detect charset
    - clock
    - clustering-louvain
    - conduit
    - conduit-extra
    ......@@ -109,6 +116,7 @@ library:
    - duckling
    - exceptions
    - filepath
    - formatting
    - fullstop
    - fclabels
    - fgl
    ......@@ -130,7 +138,7 @@ library:
    - hlcm
    - ini
    - insert-ordered-containers
    - jose-jwt
    - jose
    # - kmeans-vector
    - json-stream
    - KMP
    ......@@ -156,10 +164,13 @@ library:
    - profunctors
    - protolude
    - pureMD5
    - random-shuffle
    - MonadRandom
    - SHA
    - simple-reflect
    - cereal # (IGraph)
    - singletons # (IGraph)
    - quickcheck-instances
    - random
    - rake
    - regex-compat
    ......@@ -169,9 +180,11 @@ library:
    - semigroups
    - servant
    - servant-auth
    - servant-auth-server >= 0.4.4.0
    - servant-auth-swagger
    - servant-blaze
    - servant-client
    # - servant-job
    - servant-job
    - servant-mock
    - servant-multipart
    - servant-server
    ......
    src/Gargantext/API.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/API/Auth.hs
    View file @ 6116a39e
    ......@@ -7,7 +7,7 @@ Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    Main authorisation of Gargantext are managed in this module
    Main authorization of Gargantext are managed in this module
    -- 1: Implement the Server / Client JWT authentication
    -> Client towards Python Backend
    ......@@ -16,27 +16,41 @@ Main authorisation of Gargantext are managed in this module
    -- 2: Implement the Auth API backend
    https://github.com/haskell-servant/servant-auth
    TODO-ACCESS Critical
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TemplateHaskell #-}
    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
    import Data.Text (Text, reverse)
    import Data.Text.Lazy (toStrict)
    import Data.Text.Lazy.Encoding (decodeUtf8)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Servant
    import Servant.Auth.Server
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.API.Settings
    import Gargantext.API.Types (HasJoseError(..), joseError, HasServerError, GargServerC)
    --import Gargantext.API.Types (HasJoseError(..), joseError, HasServerError, serverError, GargServerC)
    import Gargantext.Database.Root (getRoot)
    import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId)
    import Gargantext.Database.Utils (Cmd)
    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.Prelude hiding (reverse)
    import Test.QuickCheck (elements, oneof)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    ......@@ -69,20 +83,34 @@ type TreeId = NodeId
    -- | Main functions of authorization
    -- | Main types of authorization
    data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
    deriving (Eq)
    checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
    makeTokenForUser :: (HasSettings env, HasJoseError err)
    => NodeId -> Cmd' env err Token
    makeTokenForUser uid = do
    jwtS <- view $ settings . jwtSettings
    e <- liftIO $ 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)
    => Username -> Password -> Cmd' env err CheckAuth
    checkAuthRequest u p
    | not (u `elem` arbitraryUsername) = pure InvalidUser
    | u /= reverse p = pure InvalidPassword
    | otherwise = do
    muId <- getRoot "user1"
    pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
    auth :: AuthRequest -> Cmd err AuthResponse
    muId <- head <$> getRoot u
    case _node_id <$> muId of
    Nothing -> pure InvalidUser
    Just uid -> do
    token <- makeTokenForUser uid
    pure $ Valid token uid
    auth :: (HasSettings env, HasConnection env, HasJoseError err)
    => AuthRequest -> Cmd' env err AuthResponse
    auth (AuthRequest u p) = do
    checkAuthRequest' <- checkAuthRequest u p
    case checkAuthRequest' of
    ......@@ -90,9 +118,36 @@ auth (AuthRequest u p) = do
    InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
    Valid to trId -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
    newtype AuthenticatedUser = AuthenticatedUser
    { _authUser_id :: NodeId
    } deriving (Generic)
    $(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
    instance ToSchema AuthenticatedUser where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
    instance ToJWT AuthenticatedUser
    instance FromJWT AuthenticatedUser
    --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
    -- TODO-SECURITY why is the CookieSettings necessary?
    type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
    {-
    instance FromBasicAuthData AuthenticatedUser where
    fromBasicAuthData authData authCheckFunction = authCheckFunction authData
    authCheck :: forall env. env
    -> BasicAuthData
    -> IO (AuthResult AuthenticatedUser)
    authCheck _env (BasicAuthData login password) = pure $
    maybe Indefinite Authenticated $ TODO
    -}
    -- | Instances
    $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
    instance ToSchema AuthRequest
    instance ToSchema AuthRequest where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
    instance Arbitrary AuthRequest where
    arbitrary = elements [ AuthRequest u p
    ......@@ -101,23 +156,60 @@ instance Arbitrary AuthRequest where
    ]
    $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
    instance ToSchema AuthResponse
    instance ToSchema AuthResponse where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
    instance Arbitrary AuthResponse where
    arbitrary = oneof [ AuthResponse Nothing . Just <$> arbitrary
    , flip AuthResponse Nothing . Just <$> arbitrary ]
    $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
    instance ToSchema AuthInvalid
    instance ToSchema AuthInvalid where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
    instance Arbitrary AuthInvalid where
    arbitrary = elements [ AuthInvalid m
    | m <- [ "Invalid user", "Invalid password"]
    ]
    $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
    instance ToSchema AuthValid
    instance ToSchema AuthValid where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
    instance Arbitrary AuthValid where
    arbitrary = elements [ AuthValid to tr
    | to <- ["token0", "token1"]
    , tr <- [1..3]
    ]
    data PathId = PathNode NodeId | PathNodeNode ListId DocId
    withAccessM :: (CmdM env err m, HasServerError err)
    => UserId
    -> PathId
    -> m a
    -> m a
    withAccessM uId (PathNode id) m = do
    d <- id `isDescendantOf` NodeId uId
    if d then m else m -- serverError err401
    withAccessM uId (PathNodeNode cId docId) m = do
    _a <- isIn cId docId -- TODO use one query for all ?
    _d <- cId `isDescendantOf` NodeId uId
    if True -- a && d
    then m
    else m
    withAccess :: forall env err m api.
    (GargServerC env err m, HasServer api '[]) =>
    Proxy api -> Proxy m ->
    UserId -> PathId ->
    ServerT api m -> ServerT api m
    withAccess p _ uId id = hoistServer p f
    where
    f :: forall a. m a -> m a
    f = withAccessM uId id
    {- | Collaborative Schema
    User at his root can create Teams Folder
    User can create Team in Teams Folder.
    User can invite User in Team as NodeNode only if Team in his parents.
    All users can access to the Team folder as if they were owner.
    -}
    src/Gargantext/API/Corpus/New.hs
    View file @ 6116a39e
    ......@@ -18,8 +18,8 @@ New corpus means either:
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.API.Corpus.New
    where
    ......@@ -30,12 +30,14 @@ import Data.Aeson.TH (deriveJSON)
    import Data.Swagger
    import Data.Text (Text)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Flow (flowCorpusSearchInDatabase)
    import Gargantext.Database.Types.Node (CorpusId)
    import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Prelude
    import Gargantext.API.Orchestrator.Types
    import Servant
    -- import Servant.Job.Server
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary
    import Gargantext.Core (Lang(..))
    ......@@ -60,9 +62,7 @@ instance Arbitrary Query where
    ]
    instance ToSchema Query where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 6 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
    type Api = Summary "New Corpus endpoint"
    :> ReqBody '[JSON] Query
    ......@@ -70,6 +70,8 @@ type Api = Summary "New Corpus endpoint"
    :<|> Get '[JSON] ApiInfo
    -- | TODO manage several apis
    -- TODO-ACCESS
    -- TODO this is only the POST
    api :: (FlowCmdM env err m) => Query -> m CorpusId
    api (Query q _ as) = do
    cId <- case head as of
    ......@@ -95,4 +97,58 @@ instance ToSchema ApiInfo
    info :: FlowCmdM env err m => UserId -> m ApiInfo
    info _u = pure $ ApiInfo API.externalAPIs
    {-
    -- Proposal to replace the Query type which seems to generically named.
    data ScraperInput = ScraperInput
    { _scin_query :: !Text
    , _scin_corpus_id :: !Int
    , _scin_databases :: [API.ExternalAPIs]
    }
    deriving (Eq, Show, Generic)
    makeLenses ''ScraperInput
    deriveJSON (unPrefix "_scin_") 'ScraperInput
    data ScraperEvent = ScraperEvent
    { _scev_message :: !(Maybe Text)
    , _scev_level :: !(Maybe Text)
    , _scev_date :: !(Maybe Text)
    }
    deriving Generic
    deriveJSON (unPrefix "_scev_") 'ScraperEvent
    data ScraperStatus = ScraperStatus
    { _scst_succeeded :: !(Maybe Int)
    , _scst_failed :: !(Maybe Int)
    , _scst_remaining :: !(Maybe Int)
    , _scst_events :: !(Maybe [ScraperEvent])
    }
    deriving Generic
    deriveJSON (unPrefix "_scst_") 'ScraperStatus
    -}
    type API_v2 =
    Summary "Add to corpus endpoint" :>
    "corpus" :>
    Capture "corpus_id" CorpusId :>
    "add" :>
    "async" :> ScraperAPI2
    -- TODO ScraperInput2 also has a corpus id
    addToCorpusJobFunction :: FlowCmdM env err m => CorpusId -> ScraperInput2 -> (ScraperStatus -> m ()) -> m ScraperStatus
    addToCorpusJobFunction _cid _input logStatus = do
    -- TODO ...
    logStatus ScraperStatus { _scst_succeeded = Just 10
    , _scst_failed = Just 2
    , _scst_remaining = Just 138
    , _scst_events = Just []
    }
    -- TODO ...
    pure ScraperStatus { _scst_succeeded = Just 137
    , _scst_failed = Just 13
    , _scst_remaining = Just 0
    , _scst_events = Just []
    }
    src/Gargantext/API/Count.hs
    View file @ 6116a39e
    ......@@ -41,7 +41,7 @@ import Test.QuickCheck (elements)
    -- import Control.Applicative ((<*>))
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    -----------------------------------------------------------------------
    -- TODO-ACCESS: CanCount
    ......@@ -93,7 +93,9 @@ instance Arbitrary Query where
    , n <- take 10 $ permutations scrapers
    ]
    instance ToSchema Query
    instance ToSchema Query where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
    -----------------------------------------------------------------------
    type Code = Integer
    type Error = Text
    ......@@ -144,7 +146,8 @@ data Count = Count { count_name :: Scraper
    $(deriveJSON (unPrefix "count_") ''Count)
    instance ToSchema Count
    instance ToSchema Count where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "count_")
    --instance Arbitrary Count where
    -- arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
    ......
    src/Gargantext/API/Metrics.hs
    View file @ 6116a39e
    ......@@ -31,7 +31,7 @@ import Data.Time (UTCTime)
    import Data.Text (Text)
    import GHC.Generics (Generic)
    import Gargantext.Core.Types (ListType(..))
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Utils
    import Gargantext.Core.Types (CorpusId, ListId, Limit)
    import Gargantext.Prelude
    ......@@ -50,7 +50,8 @@ data Metrics = Metrics
    { metrics_data :: [Metric]}
    deriving (Generic, Show)
    instance ToSchema Metrics
    instance ToSchema Metrics where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "metrics_")
    instance Arbitrary Metrics
    where
    arbitrary = Metrics <$> arbitrary
    ......@@ -62,7 +63,8 @@ data Metric = Metric
    , m_cat :: !ListType
    } deriving (Generic, Show)
    instance ToSchema Metric
    instance ToSchema Metric where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "m_")
    instance Arbitrary Metric
    where
    arbitrary = Metric <$> arbitrary
    ......@@ -78,7 +80,8 @@ deriveJSON (unPrefix "m_") ''Metric
    data ChartMetrics a = ChartMetrics { chartMetrics_data :: a }
    deriving (Generic, Show)
    instance (ToSchema a) => ToSchema (ChartMetrics a)
    instance (ToSchema a) => ToSchema (ChartMetrics a) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "chartMetrics_")
    instance (Arbitrary a) => Arbitrary (ChartMetrics a)
    where
    arbitrary = ChartMetrics <$> arbitrary
    ......@@ -86,7 +89,8 @@ instance (Arbitrary a) => Arbitrary (ChartMetrics a)
    deriveJSON (unPrefix "chartMetrics_") ''ChartMetrics
    -------------------------------------------------------------
    instance ToSchema Histo
    instance ToSchema Histo where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "histo_")
    instance Arbitrary Histo
    where
    arbitrary = elements [ Histo ["2012"] [1]
    ......@@ -95,11 +99,6 @@ instance Arbitrary Histo
    deriveJSON (unPrefix "histo_") ''Histo
    instance ToSchema MyTree
    instance Arbitrary MyTree
    where
    arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
    -------------------------------------------------------------
    -- | Scatter metrics API
    ......
    src/Gargantext/API/Ngrams.hs
    View file @ 6116a39e
    {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
    {-|
    Module : Gargantext.API.Ngrams
    Description : Server API
    ......@@ -32,6 +33,61 @@ add get
    {-# OPTIONS -fno-warn-orphans #-}
    module Gargantext.API.Ngrams
    ( TableNgramsApi
    , TableNgramsApiGet
    , TableNgramsApiPut
    , TableNgramsApiPost
    , getTableNgrams
    , putListNgrams
    , tableNgramsPost
    , apiNgramsTableCorpus
    , apiNgramsTableDoc
    , NgramsStatePatch
    , NgramsTablePatch
    , NgramsElement
    , mkNgramsElement
    , mergeNgramsElement
    , RootParent(..)
    , MSet
    , mSetFromList
    , mSetToList
    , Repo(..)
    , r_version
    , r_state
    , NgramsRepo
    , NgramsRepoElement(..)
    , saveRepo
    , initRepo
    , RepoEnv(..)
    , renv_var
    , renv_lock
    , TabType(..)
    , ngramsTypeFromTabType
    , HasRepoVar(..)
    , HasRepoSaver(..)
    , HasRepo(..)
    , RepoCmdM
    , QueryParamR
    , TODO(..)
    -- Internals
    , getNgramsTableMap
    , tableNgramsPull
    , tableNgramsPut
    , Versioned(..)
    , currentVersion
    , listNgramsChangedSince
    )
    where
    -- import Debug.Trace (trace)
    ......@@ -56,7 +112,7 @@ import Data.Map.Strict (Map)
    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_, (%%~), (?~))
    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.Error.Class (MonadError)
    import Control.Monad.Reader
    import Control.Monad.State
    ......@@ -68,8 +124,10 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
    import Data.Swagger hiding (version, patch)
    import Data.Text (Text, isInfixOf, count)
    import Data.Validity
    import Formatting (hprint, int, (%))
    import Formatting.Clock (timeSpecs)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    -- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
    import Gargantext.Database.Config (userMaster)
    import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast)
    ......@@ -87,7 +145,9 @@ import Gargantext.Prelude
    -- import Gargantext.Core.Types (ListTypeId, listTypeId)
    import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
    import Servant hiding (Patch)
    import System.Clock (getTime, TimeSpec, Clock(..))
    import System.FileLock (FileLock)
    import System.IO (stderr)
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    ......@@ -208,7 +268,8 @@ mkNgramsElement ngrams list rp children =
    newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
    newNgramsElement mayList ngrams = mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty
    instance ToSchema NgramsElement
    instance ToSchema NgramsElement where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
    instance Arbitrary NgramsElement where
    arbitrary = elements [newNgramsElement Nothing "sport"]
    ......@@ -462,7 +523,8 @@ data NgramsPatch =
    deriveJSON (unPrefix "_") ''NgramsPatch
    makeLenses ''NgramsPatch
    instance ToSchema NgramsPatch
    instance ToSchema NgramsPatch where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
    instance Arbitrary NgramsPatch where
    arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
    ......@@ -597,7 +659,8 @@ data Versioned a = Versioned
    deriving (Generic, Show)
    deriveJSON (unPrefix "_v_") ''Versioned
    makeLenses ''Versioned
    instance ToSchema a => ToSchema (Versioned a)
    instance ToSchema a => ToSchema (Versioned a) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_v_")
    instance Arbitrary a => Arbitrary (Versioned a) where
    arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
    ......@@ -798,12 +861,34 @@ putListNgrams listId ngramsType nes = do
    where
    m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes
    -- TODO-ACCESS check
    tableNgramsPost :: RepoCmdM env err m => TabType -> NodeId -> Maybe ListType -> [NgramsTerm] -> m ()
    tableNgramsPost tabType listId mayList =
    putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
    currentVersion :: RepoCmdM env err m => m Version
    currentVersion = do
    var <- view repoVar
    r <- liftIO $ readMVar var
    pure $ r ^. r_version
    tableNgramsPull :: RepoCmdM env err m
    => ListId -> NgramsType
    -> Version
    -> m (Versioned NgramsTablePatch)
    tableNgramsPull listId ngramsType p_version = do
    var <- view repoVar
    r <- liftIO $ readMVar var
    let
    q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
    q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
    pure (Versioned (r ^. r_version) q_table)
    -- Apply the given patch to the DB and returns the patch to be applied on the
    -- client.
    -- TODO-ACCESS check
    tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
    => TabType -> ListId
    -> Versioned NgramsTablePatch
    ......@@ -811,15 +896,7 @@ tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
    tableNgramsPut tabType listId (Versioned p_version p_table)
    | p_table == mempty = do
    let ngramsType = ngramsTypeFromTabType tabType
    var <- view repoVar
    r <- liftIO $ readMVar var
    let
    q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
    q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
    pure (Versioned (r ^. r_version) q_table)
    tableNgramsPull listId ngramsType p_version
    | otherwise = do
    let ngramsType = ngramsTypeFromTabType tabType
    ......@@ -880,7 +957,8 @@ 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
    getTableNgrams :: forall env err m.
    ......@@ -895,7 +973,8 @@ getTableNgrams :: forall env err m.
    getTableNgrams _nType nId tabType listId limit_ offset
    listType minSize maxSize orderBy searchQuery = do
    _lIds <- selectNodesWithUsername NodeList userMaster
    t0 <- getTime'
    -- lIds <- selectNodesWithUsername NodeList userMaster
    let
    ngramsType = ngramsTypeFromTabType tabType
    offset' = maybe 0 identity offset
    ......@@ -939,15 +1018,20 @@ getTableNgrams _nType nId tabType listId limit_ offset
    setScores False table = pure table
    setScores True table = do
    let ngrams_terms = (table ^.. each . ne_ngrams)
    t1 <- getTime'
    occurrences <- getOccByNgramsOnlyFast nId
    ngramsType
    ngrams_terms
    t2 <- getTime'
    liftIO $ hprint stderr
    ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
    (length ngrams_terms) t1 t2
    {-
    occurrences <- getOccByNgramsOnlySlow nType nId
    (lIds <> [listId])
    ngramsType
    ngrams_terms
    -}
    -}
    let
    setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
    ......@@ -960,11 +1044,24 @@ getTableNgrams _nType nId tabType listId limit_ offset
    let nSco = needsScores orderBy
    tableMap1 <- getNgramsTableMap listId ngramsType
    t1 <- getTime'
    tableMap2 <- tableMap1 & v_data %%~ setScores nSco
    . Map.mapWithKey ngramsElementFromRepo
    tableMap2 & v_data %%~ fmap NgramsTable
    . setScores (not nSco)
    . selectAndPaginate
    t2 <- getTime'
    tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
    . setScores (not nSco)
    . selectAndPaginate
    t3 <- getTime'
    liftIO $ hprint stderr
    ("getTableNgrams total=" % timeSpecs
    % " map1=" % timeSpecs
    % " map2=" % timeSpecs
    % " map3=" % timeSpecs
    % " sql=" % (if nSco then "map2" else "map3")
    % "\n"
    ) t0 t3 t0 t1 t1 t2 t2 t3
    pure tableMap3
    -- APIs
    ......@@ -1081,3 +1178,9 @@ apiNgramsTableDoc dId = getTableNgramsDoc dId
    -- > add new ngrams in database (TODO AD)
    -- > index all the corpus accordingly (TODO AD)
    listNgramsChangedSince :: RepoCmdM env err m => ListId -> NgramsType -> Version -> m (Versioned Bool)
    listNgramsChangedSince listId ngramsType version
    | version < 0 =
    Versioned <$> currentVersion <*> pure True
    | otherwise =
    tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
    src/Gargantext/API/Ngrams/NTree.hs
    View file @ 6116a39e
    ......@@ -23,16 +23,18 @@ import Data.Text (Text)
    import Gargantext.Prelude
    import GHC.Generics (Generic)
    import Data.Aeson.TH (deriveJSON)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Core.Types (ListType(..), NodeId)
    import Gargantext.API.Ngrams
    import Data.Tree
    import Data.Maybe (catMaybes)
    import Data.Map (Map)
    import Data.Set (Set)
    import Data.Swagger
    import qualified Data.Set as Set
    import qualified Data.Map as Map
    import qualified Data.List as List
    import Test.QuickCheck
    type Children = Text
    type Root = Text
    ......@@ -47,12 +49,17 @@ toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs)
    deriveJSON (unPrefix "mt_") ''MyTree
    instance ToSchema MyTree where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
    instance Arbitrary MyTree
    where
    arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
    toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
    toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
    where
    buildNode r = maybe ((r, value r),[]) (\x -> ((r, value r), mSetToList $ _nre_children x)) (Map.lookup r m)
    value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs
    rootsCandidates = catMaybes
    ......@@ -60,7 +67,7 @@ toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
    $ map (\(c,c') -> case _nre_root c' of
    Nothing -> Just c
    _ -> _nre_root c' ) (Map.toList m)
    roots = map fst
    $ filter (\(_,l) -> l == lt)
    $ catMaybes
    ......
    src/Gargantext/API/Ngrams/Tools.hs
    View file @ 6116a39e
    ......@@ -33,6 +33,10 @@ import qualified Data.Set as Set
    type RootTerm = Text
    -- TODO-ACCESS: We want to do the security check before entering here.
    -- Add a static capability parameter would be nice.
    -- Ideally this is the access to `repoVar` which needs to
    -- be properly guarded.
    getListNgrams :: RepoCmdM env err m
    => [ListId] -> NgramsType
    -> m (Map Text NgramsRepoElement)
    ......
    src/Gargantext/API/Node.hs
    View file @ 6116a39e
    ......@@ -7,6 +7,8 @@ Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    -- TODO-SECURITY: Critical
    -- TODO-ACCESS: CanGetNode
    -- TODO-EVENTS: No events as this is a read only query.
    Node API
    ......@@ -36,7 +38,7 @@ Node API
    module Gargantext.API.Node
    where
    import Control.Lens ((.~), (?~))
    import Control.Lens ((.~), (?~), (^.))
    import Control.Monad ((>>), forM)
    import Control.Monad.IO.Class (liftIO)
    import Data.Aeson (FromJSON, ToJSON)
    ......@@ -46,6 +48,7 @@ import Data.Swagger
    import Data.Text (Text())
    import Data.Time (UTCTime)
    import GHC.Generics (Generic)
    import Gargantext.API.Auth (withAccess, PathId(..))
    import Gargantext.API.Metrics
    import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
    import Gargantext.API.Ngrams.NTree (MyTree)
    ......@@ -62,7 +65,7 @@ import Gargantext.Database.Tree (treeDB)
    import Gargantext.Database.Types.Node
    import Gargantext.Database.Utils -- (Cmd, CmdM)
    import Gargantext.Prelude
    import Gargantext.Prelude.Utils (hash)
    import Gargantext.Prelude.Utils (sha)
    import Gargantext.Viz.Chart
    import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
    import Servant
    ......@@ -128,7 +131,7 @@ type NodeAPI a = Get '[JSON] (Node a)
    -- TODO gather it
    :<|> "table" :> TableApi
    :<|> "ngrams" :> TableNgramsApi
    :<|> "pairing" :> PairingApi
    -- :<|> "pairing" :> PairingApi
    :<|> "category" :> CatApi
    :<|> "search" :> SearchDocsAPI
    ......@@ -139,7 +142,7 @@ type NodeAPI a = Get '[JSON] (Node a)
    :<|> "pie" :> PieApi
    :<|> "tree" :> TreeApi
    :<|> "phylo" :> PhyloAPI
    :<|> "upload" :> UploadAPI
    :<|> "add" :> NodeAddAPI
    -- TODO-ACCESS: check userId CanRenameNode nodeId
    -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
    ......@@ -156,11 +159,25 @@ type ChildrenApi a = Summary " Summary children"
    :> QueryParam "offset" Int
    :> QueryParam "limit" Int
    :> Get '[JSON] [Node a]
    ------------------------------------------------------------------------
    type NodeNodeAPI a = Get '[JSON] (Node a)
    nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> CorpusId -> NodeId -> GargServer (NodeNodeAPI a)
    nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
    where
    nodeNodeAPI' :: GargServer (NodeNodeAPI a)
    nodeNodeAPI' = getNode nId p
    ------------------------------------------------------------------------
    -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
    nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
    nodeAPI p uId id
    = getNode id p
    nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
    nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
    where
    nodeAPI' :: GargServer (NodeAPI a)
    nodeAPI' = getNode id p
    :<|> rename id
    :<|> postNode uId id
    :<|> putNode id
    ......@@ -170,32 +187,36 @@ nodeAPI p uId id
    -- TODO gather it
    :<|> tableApi id
    :<|> apiNgramsTableCorpus id
    :<|> getPairing id
    -- :<|> getPairing id
    -- :<|> getTableNgramsDoc id
    :<|> catApi id
    :<|> searchDocs id
    :<|> getScatter id
    :<|> getChart id
    :<|> getPie id
    :<|> getTree id
    :<|> phyloAPI id uId
    :<|> postUpload id
    where
    :<|> nodeAddAPI id
    -- :<|> postUpload id
    deleteNodeApi id' = do
    node <- getNode' id'
    if _node_typename node == nodeTypeId NodeUser
    then panic "not allowed" -- TODO add proper Right Management Type
    else deleteNode id'
    -- Annuaire
    -- :<|> query
    ------------------------------------------------------------------------
    data RenameNode = RenameNode { r_name :: Text }
    deriving (Generic)
    -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON RenameNode
    instance ToJSON RenameNode
    instance ToSchema RenameNode
    ......@@ -206,6 +227,7 @@ data PostNode = PostNode { pn_name :: Text
    , pn_typename :: NodeType}
    deriving (Generic)
    -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON PostNode
    instance ToJSON PostNode
    instance ToSchema PostNode
    ......@@ -222,6 +244,7 @@ data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
    }
    deriving (Generic)
    -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON NodesToCategory
    instance ToJSON NodesToCategory
    instance ToSchema NodesToCategory
    ......@@ -301,8 +324,7 @@ instance HasTreeError ServantErr where
    -}
    type TreeAPI = Get '[JSON] (Tree NodeTree)
    -- TODO-ACCESS: CanTree or CanGetNode
    -- TODO-EVENTS: No events as this is a read only query.
    treeAPI :: NodeId -> GargServer TreeAPI
    treeAPI = treeDB
    ......@@ -312,7 +334,10 @@ rename :: NodeId -> RenameNode -> Cmd err [Int]
    rename nId (RenameNode name') = U.update (U.Rename nId name')
    postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
    postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
    postNode uId pId (PostNode nodeName nt) = do
    nodeUser <- getNode (NodeId uId) HyperdataUser
    let uId' = nodeUser ^. node_userId
    mkNodeWithParent nt (Just pId) uId' nodeName
    putNode :: NodeId -> Cmd err Int
    putNode = undefined -- TODO
    ......@@ -354,6 +379,12 @@ instance (ToParamSchema a, HasSwagger sub) =>
    & in_ .~ ParamFormData
    & paramSchema .~ toParamSchema (Proxy :: Proxy a)
    type NodeAddAPI = "file" :> Summary "Node add API"
    :> UploadAPI
    nodeAddAPI :: NodeId -> GargServer NodeAddAPI
    nodeAddAPI id = postUpload id
    type UploadAPI = Summary "Upload file(s) to a corpus"
    :> MultipartForm Mem (MultipartData Mem)
    :> QueryParam "fileType" FileType
    ......@@ -379,4 +410,4 @@ postUpload _ multipartData (Just fileType) = do
    --pure $ cs content
    -- is <- inputs multipartData
    pure $ map (hash . cs) is
    pure $ map (sha . cs) is
    src/Gargantext/API/Orchestrator._hs → src/Gargantext/API/Orchestrator.hs
    View file @ 6116a39e
    ......@@ -66,10 +66,14 @@ pipeline scrapyurl client_env input log_status = do
    e <- runJobMLog client_env log_status $ callScraper scrapyurl input
    either (panic . cs . show) pure e -- TODO throwError
    -- TODO integrate to ServerT
    -- use:
    -- * serveJobsAPI instead of simpleServeJobsAPI
    -- * JobFunction instead of simpleJobFunction
    scrapyOrchestrator :: Env -> IO (Server (WithCallbacks ScraperAPI))
    scrapyOrchestrator env = do
    apiWithCallbacksServer (Proxy :: Proxy ScraperAPI)
    defaultSettings (extendBaseUrl ("scraper" :: String) $ env ^. env_self_url)
    (env ^. env_manager) (LogEvent logConsole) $
    serveJobsAPI (env ^. env_scrapers) .
    JobFunction . pipeline (URL $ env ^. env_settings . scrapydUrl)
    simpleServeJobsAPI (env ^. env_scrapers) .
    simpleJobFunction . pipeline (URL $ env ^. env_settings . scrapydUrl)
    src/Gargantext/API/Orchestrator/Types._hs → src/Gargantext/API/Orchestrator/Types.hs
    View file @ 6116a39e
    ......@@ -13,15 +13,16 @@ module Gargantext.API.Orchestrator.Types where
    import Gargantext.Prelude
    import Control.Lens hiding (elements)
    import Data.Aeson
    import Data.Proxy
    import Data.Text (Text)
    import Data.Swagger hiding (URL, url, port)
    import GHC.Generics hiding (to)
    import Servant.Job.Async
    import Servant.Job.Client
    import Servant.Job.Types
    import Servant.Job.Utils (jsonOptions)
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary
    import Gargantext.API.Ngrams (TODO(..))
    instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
    arbitrary = panic "TODO"
    ......@@ -29,21 +30,37 @@ instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
    instance Arbitrary a => Arbitrary (JobOutput a) where
    arbitrary = JobOutput <$> arbitrary
    instance ToSchema URL where
    declareNamedSchema = panic "TODO"
    -- | Main Types
    data ExternalAPIs = All
    | PubMed
    | HAL_EN
    | HAL_FR
    | IsTex_EN
    | IsTex_FR
    instance ToSchema AnyOutput where
    declareNamedSchema = panic "TODO"
    | Isidore_EN
    | Isidore_FR
    -- | IsidoreAuth
    deriving (Show, Eq, Enum, Bounded, Generic)
    instance ToSchema AnyInput where
    declareNamedSchema = panic "TODO"
    instance ToSchema AnyEvent where
    declareNamedSchema = panic "TODO"
    -- | Main Instances
    instance FromJSON ExternalAPIs
    instance ToJSON ExternalAPIs
    instance ToSchema a => ToSchema (JobInput a)
    externalAPIs :: [ExternalAPIs]
    externalAPIs = [minBound..maxBound]
    instance ToSchema a => ToSchema (JobOutput a)
    instance Arbitrary ExternalAPIs
    where
    arbitrary = elements externalAPIs
    instance ToSchema ExternalAPIs
    instance ToSchema URL where
    declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
    data ScraperInput = ScraperInput
    { _scin_spider :: !Text
    ......@@ -62,6 +79,19 @@ makeLenses ''ScraperInput
    instance FromJSON ScraperInput where
    parseJSON = genericParseJSON $ jsonOptions "_scin_"
    -- Proposal to replace the Corpus.API.Query type which seems to generically named.
    data ScraperInput2 = ScraperInput2
    { _scin2_query :: !Text
    , _scin2_corpus :: !Int
    , _scin2_databases :: ![ExternalAPIs]
    }
    deriving Generic
    makeLenses ''ScraperInput2
    instance FromJSON ScraperInput2 where
    parseJSON = genericParseJSON $ jsonOptions "_scin2_"
    data ScraperEvent = ScraperEvent
    { _scev_message :: !(Maybe Text)
    , _scev_level :: !(Maybe Text)
    ......@@ -100,14 +130,16 @@ instance FromJSON ScraperStatus where
    instance ToSchema ScraperStatus -- TODO _scst_ prefix
    instance ToSchema ScraperInput -- TODO _scin_ prefix
    instance ToSchema ScraperInput2 -- TODO _scin2_ prefix
    instance ToSchema ScraperEvent -- TODO _scev_ prefix
    instance ToParamSchema Offset where
    toParamSchema = panic "TODO"
    instance ToParamSchema Offset -- where
    -- toParamSchema = panic "TODO"
    instance ToParamSchema Limit where
    toParamSchema = panic "TODO"
    instance ToParamSchema Limit -- where
    -- toParamSchema = panic "TODO"
    type ScrapersEnv = JobEnv ScraperStatus ScraperStatus
    type ScraperAPI = AsyncJobsAPI ScraperStatus ScraperInput ScraperStatus
    type ScraperAPI = AsyncJobsAPI ScraperStatus ScraperInput ScraperStatus
    type ScraperAPI2 = AsyncJobsAPI ScraperStatus ScraperInput2 ScraperStatus
    src/Gargantext/API/Search.hs
    View file @ 6116a39e
    ......@@ -12,6 +12,7 @@ Count API part of Gargantext.
    {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE TemplateHaskell #-}
    ......@@ -35,7 +36,7 @@ import Test.QuickCheck (elements)
    -- import Control.Applicative ((<*>))
    import Gargantext.API.Types (GargServer)
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Types.Node
    import Gargantext.Database.TextSearch
    import Gargantext.Database.Facet
    ......@@ -48,9 +49,7 @@ data SearchQuery = SearchQuery
    $(deriveJSON (unPrefix "sq_") ''SearchQuery)
    instance ToSchema SearchQuery where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 3}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sq_")
    instance Arbitrary SearchQuery where
    arbitrary = elements [SearchQuery ["electrodes"]]
    ......@@ -64,11 +63,10 @@ instance Arbitrary SearchDocResults where
    arbitrary = SearchDocResults <$> arbitrary
    instance ToSchema SearchDocResults where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 4}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sdr_")
    data SearchPairedResults = SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
    data SearchPairedResults =
    SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
    deriving (Generic)
    $(deriveJSON (unPrefix "spr_") ''SearchPairedResults)
    ......@@ -76,9 +74,7 @@ instance Arbitrary SearchPairedResults where
    arbitrary = SearchPairedResults <$> arbitrary
    instance ToSchema SearchPairedResults where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "spr_")
    -----------------------------------------------------------------------
    -- TODO-ACCESS: CanSearch? or is it part of CanGetNode
    ......@@ -92,12 +88,14 @@ type SearchAPI results
    :> Post '[JSON] results
    type SearchDocsAPI = SearchAPI SearchDocResults
    type SearchPairsAPI = SearchAPI SearchPairedResults
    type SearchPairsAPI =
    Summary "" :> "list" :> Capture "list" ListId
    :> SearchAPI SearchPairedResults
    -----------------------------------------------------------------------
    searchPairs :: NodeId -> GargServer SearchPairsAPI
    searchPairs pId (SearchQuery q) o l order =
    SearchPairedResults <$> searchInCorpusWithContacts pId q o l order
    searchPairs pId lId (SearchQuery q) o l order =
    SearchPairedResults <$> searchInCorpusWithContacts pId lId q o l order
    searchDocs :: NodeId -> GargServer SearchDocsAPI
    searchDocs nId (SearchQuery q) o l order =
    ......
    src/Gargantext/API/Settings.hs
    View file @ 6116a39e
    ......@@ -6,6 +6,8 @@ License : AGPL + CECILL v3
    Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    TODO-SECURITY: Critical
    -}
    {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
    ......@@ -14,6 +16,7 @@ Portability : POSIX
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    ......@@ -40,16 +43,16 @@ import Data.Aeson
    import Data.Maybe (fromMaybe)
    import Data.Either (either)
    import Data.Text
    import Data.Text.Encoding (encodeUtf8)
    --import Data.Text.Encoding (encodeUtf8)
    import Data.ByteString (ByteString)
    import qualified Data.ByteString.Lazy as L
    import Servant
    import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey)
    import Servant.Client (BaseUrl, parseBaseUrl)
    --import Servant.Job.Async (newJobEnv, defaultSettings)
    import qualified Servant.Job.Core
    import Servant.Job.Async (newJobEnv, defaultSettings, HasJobEnv(..), Job)
    import Web.HttpApiData (parseUrlPiece)
    import qualified Jose.Jwk as Jose
    import qualified Jose.Jwa as Jose
    import Control.Concurrent
    import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
    ......@@ -60,7 +63,7 @@ import Control.Lens
    import Gargantext.Prelude
    import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
    import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
    --import Gargantext.API.Orchestrator.Types
    import Gargantext.API.Orchestrator.Types
    type PortNumber = Int
    ......@@ -77,7 +80,8 @@ data Settings = Settings
    , _logLevelLimit :: LogLevel -- log level from the monad-logger package
    -- , _dbServer :: Text
    -- ^ this is not used yet
    , _jwtSecret :: Jose.Jwk -- key from the jose-jwt package
    , _jwtSettings :: JWTSettings
    , _cookieSettings :: CookieSettings
    , _sendLoginEmails :: SendEmailType
    , _scrapydUrl :: BaseUrl
    , _fileFolder :: FilePath
    ......@@ -88,30 +92,22 @@ makeLenses ''Settings
    class HasSettings env where
    settings :: Getter env Settings
    parseJwk :: Text -> Jose.Jwk
    parseJwk secretStr = jwk
    where
    secretBs = encodeUtf8 secretStr
    jwk = Jose.SymmetricJwk secretBs
    Nothing
    Nothing
    (Just $ Jose.Signed Jose.HS256)
    devSettings :: Settings
    devSettings = Settings
    devSettings :: FilePath -> IO Settings
    devSettings jwkFile = do
    jwkExists <- doesFileExist jwkFile
    when (not jwkExists) $ writeKey jwkFile
    jwk <- readKey jwkFile
    pure $ Settings
    { _allowedOrigin = "http://localhost:8008"
    , _allowedHost = "localhost:3000"
    , _appPort = 3000
    , _logLevelLimit = LevelDebug
    -- , _dbServer = "localhost"
    -- generate with dd if=/dev/urandom bs=1 count=32 | base64
    -- make sure jwtSecret differs between development and production, because you do not want
    -- your production key inside source control.
    , _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
    , _sendLoginEmails = LogEmailToConsole
    , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
    , _fileFolder = "data"
    , _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune
    , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
    }
    ......@@ -147,7 +143,7 @@ data Env = Env
    , _env_repo :: !RepoEnv
    , _env_manager :: !Manager
    , _env_self_url :: !BaseUrl
    --, _env_scrapers :: !ScrapersEnv
    , _env_scrapers :: !ScrapersEnv
    }
    deriving (Generic)
    ......@@ -168,6 +164,12 @@ instance HasRepo Env where
    instance HasSettings Env where
    settings = env_settings
    instance Servant.Job.Core.HasEnv Env (Job ScraperStatus ScraperStatus) where
    _env = env_scrapers . Servant.Job.Core._env
    instance HasJobEnv Env ScraperStatus ScraperStatus where
    job_env = env_scrapers
    data MockEnv = MockEnv
    { _menv_firewall :: !FireWall
    }
    ......@@ -232,10 +234,13 @@ readRepoEnv = do
    saver <- mkRepoSaver mvar
    pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
    devJwkFile :: FilePath
    devJwkFile = "dev.jwk"
    newEnv :: PortNumber -> FilePath -> IO Env
    newEnv port file = do
    manager <- newTlsManager
    settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
    settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
    when (port /= settings ^. appPort) $
    panic "TODO: conflicting settings of port"
    ......@@ -243,7 +248,7 @@ newEnv port file = do
    param <- databaseParameters file
    conn <- connect param
    repo <- readRepoEnv
    --scrapers_env <- newJobEnv defaultSettings manager
    scrapers_env <- newJobEnv defaultSettings manager
    logger <- newStderrLoggerSet defaultBufSize
    pure $ Env
    ......@@ -252,7 +257,7 @@ newEnv port file = do
    , _env_conn = conn
    , _env_repo = repo
    , _env_manager = manager
    --, _env_scrapers = scrapers_env
    , _env_scrapers = scrapers_env
    , _env_self_url = self_url
    }
    ......@@ -295,10 +300,11 @@ withDevEnv iniPath k = do
    param <- databaseParameters iniPath
    conn <- connect param
    repo <- readRepoEnv
    setts <- devSettings devJwkFile
    pure $ DevEnv
    { _dev_env_conn = conn
    , _dev_env_repo = repo
    , _dev_env_settings = devSettings
    , _dev_env_settings = setts
    }
    -- | Run Cmd Sugar for the Repl (GHCI)
    ......
    src/Gargantext/API/Table.hs
    View file @ 6116a39e
    ......@@ -45,8 +45,8 @@ import Data.Text (Text())
    import GHC.Generics (Generic)
    import Gargantext.API.Ngrams (TabType(..))
    import Gargantext.Core.Types (Offset, Limit)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..))
    import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
    import Gargantext.Database.TextSearch
    import Gargantext.Database.Types.Node
    ......@@ -57,11 +57,11 @@ import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    ------------------------------------------------------------------------
    type TableApi = Summary " Table API"
    :> ReqBody '[JSON] TableQuery
    :> Post '[JSON] [FacetDoc]
    :> Post '[JSON] TableResult
    --{-
    data TableQuery = TableQuery
    { tq_offset :: Int
    , tq_limit :: Int
    ......@@ -70,35 +70,67 @@ data TableQuery = TableQuery
    , tq_query :: Text
    } deriving (Generic)
    data TableResult = TableResult { tr_count :: Int
    , tr_docs :: [FacetDoc]
    } deriving (Generic)
    $(deriveJSON (unPrefix "tr_") ''TableResult)
    instance ToSchema TableResult where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tr_")
    instance Arbitrary TableResult where
    arbitrary = TableResult <$> arbitrary <*> arbitrary
    $(deriveJSON (unPrefix "tq_") ''TableQuery)
    instance ToSchema TableQuery where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 3}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tq_")
    instance Arbitrary TableQuery where
    arbitrary = elements [TableQuery 0 10 DateAsc Docs "electrodes"]
    tableApi :: NodeId -> TableQuery -> Cmd err [FacetDoc]
    tableApi :: NodeId -> TableQuery -> Cmd err TableResult
    tableApi cId (TableQuery o l order ft "") = getTable cId (Just ft) (Just o) (Just l) (Just order)
    tableApi cId (TableQuery o l order ft q) = case ft of
    Docs -> searchInCorpus cId False [q] (Just o) (Just l) (Just order)
    Trash -> searchInCorpus cId True [q] (Just o) (Just l) (Just order)
    Docs -> searchInCorpus' cId False [q] (Just o) (Just l) (Just order)
    Trash -> searchInCorpus' cId True [q] (Just o) (Just l) (Just order)
    x -> panic $ "not implemented in tableApi " <> (cs $ show x)
    searchInCorpus' :: CorpusId
    -> Bool
    -> [Text]
    -> Maybe Offset
    -> Maybe Limit
    -> Maybe OrderBy
    -> Cmd err TableResult
    searchInCorpus' cId t q o l order = do
    docs <- searchInCorpus cId t q o l order
    allDocs <- searchInCorpus cId t q Nothing Nothing Nothing
    pure (TableResult (length allDocs) docs)
    getTable :: NodeId -> Maybe TabType
    -> Maybe Offset -> Maybe Limit
    -> Maybe OrderBy -> Cmd err TableResult
    getTable cId ft o l order = do
    docs <- getTable' cId ft o l order
    allDocs <- getTable' cId ft Nothing Nothing Nothing
    pure (TableResult (length allDocs) docs)
    getTable' :: NodeId -> Maybe TabType
    -> Maybe Offset -> Maybe Limit
    -> Maybe OrderBy -> Cmd err [FacetDoc]
    getTable cId ft o l order =
    getTable' cId ft o l order =
    case ft of
    (Just Docs) -> runViewDocuments cId False o l order
    (Just Trash) -> runViewDocuments cId True o l order
    (Just Docs) -> runViewDocuments cId False o l order
    (Just Trash) -> runViewDocuments cId True o l order
    (Just MoreFav) -> moreLike cId o l order IsFav
    (Just MoreTrash) -> moreLike cId o l order IsTrash
    x -> panic $ "not implemented in getTable: " <> (cs $ show x)
    {-
    getPairing :: ContactId -> Maybe TabType
    -> Maybe Offset -> Maybe Limit
    -> Maybe OrderBy -> Cmd err [FacetDoc]
    ......@@ -108,4 +140,4 @@ getPairing cId ft o l order =
    (Just Trash) -> runViewAuthorsDoc cId True o l order
    _ -> panic $ "not implemented: get Pairing" <> (cs $ show ft)
    -}
    src/Gargantext/API/Types.hs
    View file @ 6116a39e
    ......@@ -10,32 +10,116 @@ Portability : POSIX
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE UndecidableInstances #-}
    module Gargantext.API.Types
    ( module Gargantext.API.Types
    , HasServerError(..)
    , serverError
    )
    where
    import Control.Exception (Exception)
    import Control.Lens (Prism', (#))
    import Control.Lens.TH (makePrisms)
    import Control.Monad.Error.Class (MonadError(throwError))
    import Crypto.JOSE.Error as Jose
    import Data.Aeson.Types
    import Data.Typeable
    import Data.Validity
    import Servant
    import Servant.Job.Core (HasServerError(..), serverError)
    import Servant.Job.Async (HasJobEnv)
    import Gargantext.Prelude
    import Gargantext.API.Settings
    import Gargantext.API.Orchestrator.Types
    import Gargantext.API.Ngrams
    import Gargantext.Database.Tree
    import Gargantext.Core.Types
    import Gargantext.Database.Tree
    import Gargantext.Database.Utils
    import Gargantext.Database.Schema.Node
    class HasJoseError e where
    _JoseError :: Prism' e Jose.Error
    type GargServer api =
    forall env err m.
    joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
    joseError = throwError . (_JoseError #)
    class ThrowAll' e a | a -> e where
    -- | 'throwAll' is a convenience function to throw errors across an entire
    -- sub-API
    --
    --
    -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
    -- > == throwError err400 :<|> throwError err400 :<|> err400
    throwAll' :: e -> a
    instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
    throwAll' e = throwAll' e :<|> throwAll' e
    -- Really this shouldn't be necessary - ((->) a) should be an instance of
    -- MonadError, no?
    instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
    throwAll' e = const $ throwAll' e
    instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
    throwAll' = throwError
    type GargServerC env err m =
    ( CmdM env err m
    , HasNodeError err
    , HasInvalidError err
    , HasTreeError err
    , HasServerError err
    , HasJoseError err
    , ToJSON err -- TODO this is arguable
    , Exception err
    , HasRepo env
    , HasSettings env
    , HasJobEnv env ScraperStatus ScraperStatus
    )
    => ServerT api m
    type GargServerT env err m api = GargServerC env err m => ServerT api m
    type GargServer api =
    forall env err m. GargServerT env err m api
    data GargError
    = GargNodeError NodeError
    | GargTreeError TreeError
    | GargInvalidError Validation
    | GargJoseError Jose.Error
    | GargServerError ServerError
    deriving (Show, Typeable)
    makePrisms ''GargError
    instance ToJSON GargError where
    toJSON _ = String "SomeGargErrorPleaseReport"
    instance Exception GargError
    instance HasNodeError GargError where
    _NodeError = _GargNodeError
    instance HasInvalidError GargError where
    _InvalidError = _GargInvalidError
    instance HasTreeError GargError where
    _TreeError = _GargTreeError
    instance HasServerError GargError where
    _ServerError = _GargServerError
    instance HasJoseError GargError where
    _JoseError = _GargJoseError
    src/Gargantext/API/Utils.hs
    View file @ 6116a39e
    ......@@ -21,22 +21,6 @@ import Gargantext.Prelude
    import Data.Maybe (Maybe, fromMaybe)
    import Prelude (String)
    import qualified Data.Text as T
    import Data.Swagger
    import Data.Text (Text)
    swaggerOptions :: Text -> SchemaOptions
    swaggerOptions pref = defaultSchemaOptions
    { Data.Swagger.fieldLabelModifier = modifier pref
    , Data.Swagger.unwrapUnaryRecords = False
    }
    modifier :: Text -> String -> String
    modifier pref field = T.unpack
    $ T.stripPrefix pref (T.pack field) ?! "Expecting prefix " <> T.unpack pref
    infixr 4 ?|
    ......
    src/Gargantext/Core.hs
    View file @ 6116a39e
    ......@@ -12,8 +12,6 @@ Portability : POSIX
    module Gargantext.Core
    where
    ------------------------------------------------------------------------
    -- | Language of a Text
    -- For simplicity, we suppose text has an homogenous language
    ......
    src/Gargantext/Core/Types/Main.hs
    View file @ 6116a39e
    ......@@ -22,8 +22,7 @@ module Gargantext.Core.Types.Main where
    ------------------------------------------------------------------------
    import Prelude (Enum, Bounded, minBound, maxBound)
    import Data.Aeson (FromJSON, ToJSON, toJSON)
    import Data.Aeson as A
    import Data.Aeson (FromJSON, ToJSON)
    import Data.Aeson.TH (deriveJSON)
    import Data.Map (fromList, lookup)
    import Data.Either (Either(..))
    ......@@ -33,7 +32,7 @@ import Data.Text (Text, unpack)
    import Data.Swagger
    import Gargantext.Database.Types.Node -- (NodeType(..), Node, Hyperdata(..))
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Prelude
    import GHC.Generics (Generic)
    ......@@ -49,36 +48,10 @@ data NodeTree = NodeTree { _nt_name :: Text
    } deriving (Show, Read, Generic)
    $(deriveJSON (unPrefix "_nt_") ''NodeTree)
    instance ToSchema NodeTree where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nt_")
    ------------------------------------------------------------------------
    -- Garg Network is a network of all Garg nodes
    --gargNetwork = undefined
    -- | Garg Node is Database Schema Typed as specification
    -- gargNode gathers all the Nodes of all users on one Node
    gargNode :: [Tree NodeTree]
    gargNode = [userTree]
    -- | User Tree simplified
    userTree :: Tree NodeTree
    userTree = TreeN (NodeTree "user name" NodeUser 1) [annuaireTree, projectTree]
    -- | Project Tree
    projectTree :: Tree NodeTree
    projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2) [corpusTree 10 "A", corpusTree 20 "B"]
    -- | Corpus Tree
    annuaireTree :: Tree NodeTree
    annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41)
    corpusTree :: NodeId -> Text -> Tree NodeTree
    corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1)
    , leafT $ NodeTree "Graph" NodeGraph (nId +2)
    ]
    -- <> [ leafT $ NodeTree "My lists" Lists 5]
    -- <> [ leafT (NodeTree "Metrics A" Metrics 6) ]
    -- <> [ leafT (NodeTree "Class A" Classification 7)]
    )
    --data Classification = Favorites | MyClassifcation
    ......@@ -127,17 +100,14 @@ type IsTrash = Bool
    ------------------------------------------------------------------------
    -- All the Database is structred like a hierarchical Tree
    data Tree a = TreeN a [Tree a]
    data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] }
    deriving (Show, Read, Eq, Generic, Ord)
    instance ToJSON a => ToJSON (Tree a) where
    toJSON (TreeN node nodes) =
    object ["node" A..= toJSON node, "children" A..= toJSON nodes]
    $(deriveJSON (unPrefix "_tn_") ''Tree)
    instance FromJSON a => FromJSON (Tree a)
    instance ToSchema a => ToSchema (Tree a) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_tn_")
    instance ToSchema NodeTree
    instance ToSchema a => ToSchema (Tree a)
    instance Arbitrary (Tree NodeTree) where
    arbitrary = elements [userTree, userTree]
    ......@@ -146,3 +116,33 @@ instance Arbitrary (Tree NodeTree) where
    -- same as Data.Tree
    leafT :: a -> Tree a
    leafT x = TreeN x []
    ------------------------------------------------------------------------
    -- Garg Network is a network of all Garg nodes
    --gargNetwork = undefined
    -- | Garg Node is Database Schema Typed as specification
    -- gargNode gathers all the Nodes of all users on one Node
    gargNode :: [Tree NodeTree]
    gargNode = [userTree]
    -- | User Tree simplified
    userTree :: Tree NodeTree
    userTree = TreeN (NodeTree "user name" NodeUser 1) [annuaireTree, projectTree]
    -- | Project Tree
    projectTree :: Tree NodeTree
    projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2) [corpusTree 10 "A", corpusTree 20 "B"]
    -- | Corpus Tree
    annuaireTree :: Tree NodeTree
    annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41)
    corpusTree :: NodeId -> Text -> Tree NodeTree
    corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1)
    , leafT $ NodeTree "Graph" NodeGraph (nId +2)
    ]
    -- <> [ leafT $ NodeTree "My lists" Lists 5]
    -- <> [ leafT (NodeTree "Metrics A" Metrics 6) ]
    -- <> [ leafT (NodeTree "Class A" Classification 7)]
    )
    src/Gargantext/Core/Types/Phylo.hs
    View file @ 6116a39e
    ......@@ -25,15 +25,18 @@ Phylomemy was first described in Chavalarias, D., Cointet, J.-P., 2013. Phylomem
    module Gargantext.Core.Types.Phylo where
    import Control.Lens (makeLenses)
    import Data.Aeson.TH (deriveJSON)
    import Data.Maybe (Maybe)
    import Data.Swagger
    import Data.Text (Text)
    import Data.Time.Clock.POSIX (POSIXTime)
    import GHC.Generics (Generic)
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    ------------------------------------------------------------------------
    -- | Phylo datatype descriptor of a phylomemy
    ......@@ -94,8 +97,24 @@ type PhyloGroupId = (PhyloLevelId, Int)
    type Edge = (PhyloGroupId, Weight)
    type Weight = Double
    -- | Lenses
    makeLenses ''Phylo
    makeLenses ''PhyloPeriod
    makeLenses ''PhyloLevel
    makeLenses ''PhyloGroup
    -- | JSON instances
    $(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
    $(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod )
    $(deriveJSON (unPrefix "_phylo_Level" ) ''PhyloLevel )
    $(deriveJSON (unPrefix "_phylo_Group" ) ''PhyloGroup )
    -- | ToSchema instances
    instance ToSchema Phylo where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
    instance ToSchema PhyloPeriod where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Period")
    instance ToSchema PhyloLevel where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Level")
    instance ToSchema PhyloGroup where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Group")
    src/Gargantext/Core/Utils/Prefix.hs
    View file @ 6116a39e
    ......@@ -22,6 +22,7 @@ import Data.Aeson.TH (Options, fieldLabelModifier, omitNothingFields)
    import Data.Aeson.Types (Parser)
    import Data.Char (toLower)
    import Data.Monoid ((<>))
    import Data.Swagger.SchemaOptions (SchemaOptions, fromAesonOptions)
    import Text.Read (Read(..),readMaybe)
    ......@@ -32,6 +33,9 @@ unPrefix prefix = defaultOptions
    , omitNothingFields = True
    }
    unPrefixSwagger :: String -> SchemaOptions
    unPrefixSwagger = fromAesonOptions . unPrefix
    -- | Lower case leading character
    unCapitalize :: String -> String
    unCapitalize [] = []
    ......
    src/Gargantext/Database.hs
    View file @ 6116a39e
    ......@@ -17,9 +17,9 @@ Gargantext's database.
    {-# LANGUAGE NoImplicitPrelude #-}
    module Gargantext.Database ( module Gargantext.Database.Utils
    , module Gargantext.Database.Bashql
    -- , module Gargantext.Database.Bashql
    )
    where
    import Gargantext.Database.Utils (connectGargandb)
    import Gargantext.Database.Bashql
    -- import Gargantext.Database.Bashql
    src/Gargantext/Database/Access.hs
    View file @ 6116a39e
    ......@@ -7,6 +7,7 @@ Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    TODO-SECURITY review purpose of this module
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    ......
    src/Gargantext/Database/Bashql.hs
    View file @ 6116a39e
    {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
    {-|
    Module : Gargantext.Database.Bashql
    Description : BASHQL to deal with Gargantext Database.
    ......@@ -55,13 +56,15 @@ AMS, and by SIAM.
    [3] https://github.com/Gabriel439/Haskell-Turtle-Library
    TODO-ACCESS: should the checks be done here or before.
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Bashql ( get
    module Gargantext.Database.Bashql () {-( get
    , ls
    , home
    , post
    ......@@ -71,7 +74,7 @@ module Gargantext.Database.Bashql ( get
    , rename
    , tree
    -- , mkCorpus, mkAnnuaire
    )
    )-}
    where
    import Control.Monad.Reader -- (Reader, ask)
    ......
    src/Gargantext/Database/Config.hs
    View file @ 6116a39e
    ......@@ -43,6 +43,10 @@ nodeTypeId n =
    case n of
    NodeUser -> 1
    NodeFolder -> 2
    NodeFolderPrivate -> 20
    NodeFolderShared -> 21
    NodeTeam -> 210
    NodeFolderPublic -> 22
    NodeCorpusV3 -> 3
    NodeCorpus -> 30
    NodeAnnuaire -> 31
    ......
    src/Gargantext/Database/Facet.hs
    View file @ 6116a39e
    ......@@ -26,10 +26,23 @@ Portability : POSIX
    {-# LANGUAGE TypeFamilies #-}
    ------------------------------------------------------------------------
    module Gargantext.Database.Facet
    ( -- runViewAuthorsDoc
    runViewDocuments
    , filterWith
    , Pair(..)
    , Facet(..)
    , FacetDoc
    , FacetDocRead
    , FacetPaired(..)
    , FacetPairedRead
    , OrderBy(..)
    )
    where
    ------------------------------------------------------------------------
    import Control.Arrow (returnA)
    import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Control.Lens ((^.))
    -- import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Data.Aeson (FromJSON, ToJSON)
    import Data.Aeson.TH (deriveJSON)
    import Data.Either(Either(Left))
    ......@@ -41,14 +54,11 @@ import Data.Time (UTCTime)
    import Data.Time.Segment (jour)
    import GHC.Generics (Generic)
    import Gargantext.Core.Types
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Config (nodeTypeId)
    import Gargantext.Database.Schema.Ngrams
    import Gargantext.Database.Schema.Node
    import Gargantext.Database.Schema.NodeNgram
    import Gargantext.Database.Schema.NodeNode
    import Gargantext.Database.Utils
    import Gargantext.Database.Queries.Join
    import Gargantext.Database.Queries.Filter
    import Opaleye
    import Prelude hiding (null, id, map, sum, not, read)
    ......@@ -70,9 +80,9 @@ type Title = Text
    -- TODO remove Title
    type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Favorite) (Maybe Double)
    type FacetSources = FacetDoc
    type FacetAuthors = FacetDoc
    type FacetTerms = FacetDoc
    -- type FacetSources = FacetDoc
    -- type FacetAuthors = FacetDoc
    -- type FacetTerms = FacetDoc
    data Facet id created title hyperdata favorite ngramCount =
    ......@@ -99,50 +109,50 @@ $(deriveJSON (unPrefix "_p_") ''Pair)
    $(makeAdaptorAndInstance "pPair" ''Pair)
    instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_p_")
    instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
    arbitrary = Pair <$> arbitrary <*> arbitrary
    data FacetPaired id date hyperdata score pairs =
    data FacetPaired id date hyperdata score pair =
    FacetPaired {_fp_id :: id
    ,_fp_date :: date
    ,_fp_hyperdata :: hyperdata
    ,_fp_score :: score
    ,_fp_pairs :: pairs
    ,_fp_pair :: pair
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
    $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
    instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    instance ( ToSchema id
    , ToSchema date
    , ToSchema hyperdata
    , ToSchema score
    , ToSchema pair
    ) => ToSchema (FacetPaired id date hyperdata score pair) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fp_")
    instance ( Arbitrary id
    , Arbitrary date
    , Arbitrary hyperdata
    , Arbitrary score
    , Arbitrary pairs
    ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
    , Arbitrary pair
    ) => Arbitrary (FacetPaired id date hyperdata score pair) where
    arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
    --{-
    type FacetPairedRead = FacetPaired (Column PGInt4 )
    (Column PGTimestamptz)
    (Column PGJsonb )
    (Column PGInt4 )
    (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
    --}
    ( Column (Nullable PGInt4)
    , Column (Nullable PGText)
    )
    -- | JSON instance
    $(deriveJSON (unPrefix "facetDoc_") ''Facet)
    -- | Documentation instance
    instance ToSchema FacetDoc
    instance ToSchema FacetDoc where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
    -- | Mock and Quickcheck instances
    instance Arbitrary FacetDoc where
    ......@@ -158,7 +168,7 @@ instance Arbitrary FacetDoc where
    -- Facets / Views for the Front End
    -- | Database instances
    $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
    $(makeLensesWith abbreviatedFields ''Facet)
    -- $(makeLensesWith abbreviatedFields ''Facet)
    type FacetDocRead = Facet (Column PGInt4 )
    (Column PGTimestamptz)
    ......@@ -196,6 +206,9 @@ instance Arbitrary OrderBy
    arbitrary = elements [minBound..maxBound]
    -- TODO-SECURITY check
    {-
    runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
    runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
    where
    ......@@ -224,18 +237,19 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
    .== nng_node_id nodeNgram
    cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
    cond23 (ngrams, (nodeNgram, _)) = ngrams_id ngrams
    cond23 (ngrams, (nodeNgram, _)) = ngrams^.ngrams_id
    .== nng_ngrams_id nodeNgram
    cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
    cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== nng_ngrams_id nodeNgram2
    cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams^.ngrams_id .== nng_ngrams_id nodeNgram2
    cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
    cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nng_node_id nodeNgram2
    -}
    ------------------------------------------------------------------------
    -- TODO-SECURITY check
    runViewDocuments :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
    runViewDocuments cId t o l order =
    runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
    ......@@ -246,12 +260,12 @@ viewDocuments :: CorpusId -> IsTrash -> NodeTypeId -> Query FacetDocRead
    viewDocuments cId t ntId = proc () -> do
    n <- queryNodeTable -< ()
    nn <- queryNodeNodeTable -< ()
    restrict -< _node_id n .== nn_node2_id nn
    restrict -< nn_node1_id nn .== (pgNodeId cId)
    restrict -< _node_typename n .== (pgInt4 ntId)
    restrict -< if t then nn_category nn .== (pgInt4 0)
    else nn_category nn .>= (pgInt4 1)
    returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (toNullable $ nn_category nn) (toNullable $ nn_score nn)
    restrict -< n^.node_id .== nn^.nn_node2_id
    restrict -< nn^.nn_node1_id .== (pgNodeId cId)
    restrict -< n^.node_typename .== (pgInt4 ntId)
    restrict -< if t then nn^.nn_category .== (pgInt4 0)
    else nn^.nn_category .>= (pgInt4 1)
    returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (toNullable $ nn^.nn_category) (toNullable $ nn^.nn_score)
    ------------------------------------------------------------------------
    ......
    src/Gargantext/Database/Flow.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Database/Flow/Pairing.hs
    View file @ 6116a39e
    ......@@ -16,10 +16,11 @@ Portability : POSIX
    -- {-# LANGUAGE Arrows #-}
    module Gargantext.Database.Flow.Pairing
    (pairing)
    where
    --import Debug.Trace (trace)
    import Control.Lens (_Just,view)
    import Control.Lens (_Just, (^.))
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    -- import Opaleye
    -- import Opaleye.Aggregate
    ......@@ -32,54 +33,59 @@ import Data.Text (Text, toLower)
    import qualified Data.Text as DT
    import Gargantext.Prelude hiding (sum)
    import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
    --import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
    --import Gargantext.Database.Types.Node -- (Hyperdata(..))
    import Gargantext.Database.Node.Contact
    import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
    import Gargantext.Database.Flow.Utils
    import Gargantext.Database.Utils (Cmd, runPGSQuery)
    import Gargantext.Database.Types.Node (AnnuaireId, CorpusId)
    import Gargantext.Database.Node.Children
    import Gargantext.Core.Types (NodeType(..))
    import Gargantext.Database.Types.Node (AnnuaireId, CorpusId, ListId)
    import Gargantext.Database.Node.Children (getAllContacts)
    -- TODO mv this type in Types Main
    type Terms = Text
    -- | TODO : add paring policy as parameter
    pairing :: AnnuaireId -> CorpusId -> Cmd err Int
    pairing aId cId = do
    contacts' <- getContacts aId (Just NodeContact)
    let contactsMap = pairingPolicyToMap toLower $ toMaps extractNgramsT contacts'
    pairing :: AnnuaireId
    -> CorpusId
    -> ListId
    -> Cmd err Int
    pairing aId cId lId = do
    contacts' <- getAllContacts aId
    let contactsMap = pairingPolicyToMap toLower
    $ toMaps extractNgramsT contacts'
    ngramsMap' <- getNgramsTindexed cId Authors
    let ngramsMap = pairingPolicyToMap lastName ngramsMap'
    let indexedNgrams = pairMaps contactsMap ngramsMap
    insertToNodeNgrams indexedNgrams
    -- TODO add List
    insertDocNgrams lId indexedNgrams
    lastName :: Terms -> Terms
    lastName texte = DT.toLower $ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
    lastName texte = DT.toLower
    $ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
    where
    lastName' = lastMay . DT.splitOn " "
    -- TODO: this methods is dangerous (maybe equalities of the result are not taken into account
    -- emergency demo plan...
    -- TODO: this method is dangerous (maybe equalities of the result are not taken into account
    -- emergency demo plan...)
    pairingPolicyToMap :: (Terms -> Terms)
    -> Map (NgramsT Ngrams) a -> Map (NgramsT Ngrams) a
    -> Map (NgramsT Ngrams) a
    -> Map (NgramsT Ngrams) a
    pairingPolicyToMap f = DM.mapKeys (pairingPolicy f)
    pairingPolicy :: (Terms -> Terms) -> NgramsT Ngrams -> NgramsT Ngrams
    pairingPolicy :: (Terms -> Terms)
    -> NgramsT Ngrams
    -> NgramsT Ngrams
    pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
    -- | TODO : use Occurrences in place of Int
    extractNgramsT :: HyperdataContact -> Map (NgramsT Ngrams) Int
    extractNgramsT :: HyperdataContact
    -> Map (NgramsT Ngrams) Int
    extractNgramsT contact = fromList [(NgramsT Authors a' , 1)| a' <- authors ]
    where
    authors = map text2ngrams $ catMaybes [view (hc_who . _Just . cw_lastName) contact]
    --}
    authors = map text2ngrams
    $ catMaybes [ contact^.(hc_who . _Just . cw_lastName) ]
    -- NP: notice how this function is no longer specific to the ContactId type
    pairMaps :: Map (NgramsT Ngrams) a
    -> Map (NgramsT Ngrams) NgramsId
    -> Map NgramsIndexed (Map NgramsType a)
    ......@@ -91,23 +97,27 @@ pairMaps m1 m2 =
    ]
    -----------------------------------------------------------------------
    getNgramsTindexed:: CorpusId -> NgramsType -> Cmd err (Map (NgramsT Ngrams) NgramsId)
    getNgramsTindexed :: CorpusId
    -> NgramsType
    -> Cmd err (Map (NgramsT Ngrams) NgramsId)
    getNgramsTindexed corpusId ngramsType' = fromList
    <$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
    <$> selectNgramsTindexed corpusId ngramsType'
    selectNgramsTindexed :: CorpusId -> NgramsType -> Cmd err [(NgramsId, Terms, Int)]
    selectNgramsTindexed corpusId ngramsType'' = runPGSQuery selectQuery (corpusId, ngramsTypeId ngramsType'')
    where
    selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
    JOIN nodes_ngrams occ ON occ.ngram_id = n.id
    JOIN nodes_nodes nn ON nn.node2_id = occ.node_id
    WHERE nn.node1_id = ?
    AND occ.ngrams_type = ?
    AND occ.node_id = nn.node2_id
    GROUP BY n.id;
    |]
    selectNgramsTindexed :: CorpusId
    -> NgramsType
    -> Cmd err [(NgramsId, Terms, Int)]
    selectNgramsTindexed corpusId' ngramsType'' = runPGSQuery selectQuery (corpusId', ngramsTypeId ngramsType'')
    where
    selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
    JOIN node_node_ngrams occ ON occ.ngrams_id = n.id
    JOIN nodes_nodes nn ON nn.node2_id = occ.node2_id
    WHERE nn.node1_id = ?
    AND occ.ngrams_type = ?
    AND occ.node2_id = nn.node2_id
    GROUP BY n.id;
    |]
    {- | TODO more typed SQL queries
    selectNgramsTindexed :: CorpusId -> NgramsType -> Query NgramsRead
    ......@@ -123,5 +133,3 @@ selectNgramsTindexed corpusId ngramsType = proc () -> do
    result <- aggregate groupBy (ngrams_id ngrams)
    returnA -< result
    --}
    src/Gargantext/Database/Flow/Utils.hs
    View file @ 6116a39e
    ......@@ -22,10 +22,8 @@ import Gargantext.Prelude
    import Gargantext.Database.Schema.Ngrams
    import Gargantext.Database.Types.Node (NodeId, Node, NodePoly(..), Hyperdata)
    import Gargantext.Database.Utils (Cmd)
    import Gargantext.Database.Schema.NodeNgram
    import Gargantext.Database.Schema.NodeNodeNgrams
    import Gargantext.Database.Types.Node
    import Gargantext.Core.Types.Main (ListType(..), listTypeId)
    toMaps :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int) -> [Node a] -> Map (NgramsT Ngrams) (Map NodeId Int)
    toMaps fun ns = mapNodeIdNgrams $ documentIdWithNgrams fun ns'
    ......@@ -39,8 +37,10 @@ mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
    n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
    documentIdWithNgrams :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int)
    -> [DocumentWithId a] -> [DocumentIdWithNgrams a]
    documentIdWithNgrams :: Hyperdata a
    => (a -> Map (NgramsT Ngrams) Int)
    -> [DocumentWithId a]
    -> [DocumentIdWithNgrams a]
    documentIdWithNgrams f = map (\d -> DocumentIdWithNgrams d ((f . documentData) d))
    ......@@ -56,19 +56,12 @@ data DocumentIdWithNgrams a =
    , document_ngrams :: Map (NgramsT Ngrams) Int
    } deriving (Show)
    -- | TODO for now, list Type is CandidateTerm because Graph Terms
    -- have to be detected in next step in the flow
    -- TODO remvoe this
    insertToNodeNgrams :: Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err Int
    insertToNodeNgrams m = insertNodeNgrams [ NodeNgram n (_ngramsId ng) Nothing (ngramsTypeId t) (listTypeId CandidateTerm) (fromIntegral i)
    | (ng, t2n2i) <- DM.toList m
    , (t, n2i) <- DM.toList t2n2i
    , (n, i) <- DM.toList n2i
    ]
    docNgrams2nodeNodeNgrams :: CorpusId -> DocNgrams -> NodeNodeNgrams
    docNgrams2nodeNodeNgrams cId (DocNgrams d n nt w) = NodeNodeNgrams Nothing cId d n nt w
    docNgrams2nodeNodeNgrams :: CorpusId
    -> DocNgrams
    -> NodeNodeNgrams
    docNgrams2nodeNodeNgrams cId (DocNgrams d n nt w) =
    NodeNodeNgrams Nothing cId d n nt w
    data DocNgrams = DocNgrams { dn_doc_id :: DocId
    , dn_ngrams_id :: Int
    ......@@ -76,10 +69,14 @@ data DocNgrams = DocNgrams { dn_doc_id :: DocId
    , dn_weight :: Double
    }
    insertDocNgramsOn :: CorpusId -> [DocNgrams] -> Cmd err Int
    insertDocNgramsOn :: CorpusId
    -> [DocNgrams]
    -> Cmd err Int
    insertDocNgramsOn cId dn = insertNodeNodeNgrams $ (map (docNgrams2nodeNodeNgrams cId) dn)
    insertDocNgrams :: CorpusId -> Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err Int
    insertDocNgrams :: CorpusId
    -> Map NgramsIndexed (Map NgramsType (Map NodeId Int))
    -> Cmd err Int
    insertDocNgrams cId m = insertDocNgramsOn cId [ DocNgrams n (_ngramsId ng) (ngramsTypeId t) (fromIntegral i)
    | (ng, t2n2i) <- DM.toList m
    , (t, n2i) <- DM.toList t2n2i
    ......
    src/Gargantext/Database/Ngrams.hs
    View file @ 6116a39e
    ......@@ -18,6 +18,7 @@ module Gargantext.Database.Ngrams
    where
    import Data.Text (Text)
    import Control.Lens ((^.))
    import Gargantext.Core.Types
    import Gargantext.Database.Utils (runOpaQuery, Cmd)
    import Gargantext.Database.Schema.Ngrams
    ......@@ -34,14 +35,14 @@ selectNgramsByDoc cIds dId nt = runOpaQuery (query cIds dId nt)
    join :: Query (NgramsRead, NodeNodeNgramsReadNull)
    join = leftJoin queryNgramsTable queryNodeNodeNgramsTable on1
    where
    on1 (ng,nnng) = ngrams_id ng .== nnng_ngrams_id nnng
    on1 (ng,nnng) = ng^.ngrams_id .== nnng^.nnng_ngrams_id
    query cIds' dId' nt' = proc () -> do
    (ng,nnng) <- join -< ()
    restrict -< foldl (\b cId -> ((toNullable $ pgNodeId cId) .== nnng_node1_id nnng) .|| b) (pgBool True) cIds'
    restrict -< (toNullable $ pgNodeId dId') .== nnng_node2_id nnng
    restrict -< (toNullable $ pgNgramsType nt') .== nnng_ngramsType nnng
    returnA -< ngrams_terms ng
    restrict -< foldl (\b cId -> ((toNullable $ pgNodeId cId) .== nnng^.nnng_node1_id) .|| b) (pgBool True) cIds'
    restrict -< (toNullable $ pgNodeId dId') .== nnng^.nnng_node2_id
    restrict -< (toNullable $ pgNgramsType nt') .== nnng^.nnng_ngramsType
    returnA -< ng^.ngrams_terms
    postNgrams :: CorpusId -> DocId -> [Text] -> Cmd err Int
    ......
    src/Gargantext/Database/Node/Children.hs
    View file @ 6116a39e
    ......@@ -18,6 +18,7 @@ Portability : POSIX
    module Gargantext.Database.Node.Children where
    import Data.Proxy
    import Opaleye
    import Gargantext.Core.Types
    import Gargantext.Database.Schema.Node
    ......@@ -29,30 +30,45 @@ import Gargantext.Database.Node.Contact (HyperdataContact)
    import Gargantext.Database.Schema.Node (pgNodeId)
    import Control.Arrow (returnA)
    -- | TODO: use getChildren with Proxy ?
    getContacts :: ParentId -> Maybe NodeType -> Cmd err [Node HyperdataContact]
    getContacts pId maybeNodeType = runOpaQuery $ selectChildren pId maybeNodeType
    getAllDocuments :: ParentId -> Cmd err [Node HyperdataDocument]
    getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
    (Just NodeDocument)
    getChildren :: JSONB a => ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
    getAllContacts :: ParentId -> Cmd err [Node HyperdataContact]
    getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
    (Just NodeContact)
    getAllChildren :: JSONB a
    => ParentId
    -> proxy a
    -> Maybe NodeType
    -> Cmd err [Node a]
    getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing
    getChildren :: JSONB a
    => ParentId
    -> proxy a
    -> Maybe NodeType
    -> Maybe Offset
    -> Maybe Limit
    -> Cmd err [Node a]
    getChildren pId _ maybeNodeType maybeOffset maybeLimit = runOpaQuery
    $ limit' maybeLimit $ offset' maybeOffset
    $ orderBy (asc _node_id)
    $ selectChildren pId maybeNodeType
    selectChildren :: ParentId -> Maybe NodeType -> Query NodeRead
    selectChildren :: ParentId
    -> Maybe NodeType
    -> Query NodeRead
    selectChildren parentId maybeNodeType = proc () -> do
    row@(Node nId typeName _ parent_id _ _ _) <- queryNodeTable -< ()
    (NodeNode n1id n2id _ _) <- queryNodeNodeTable -< ()
    let nodeType = maybe 0 nodeTypeId maybeNodeType
    restrict -< typeName .== pgInt4 nodeType
    restrict -< (.||) (parent_id .== (pgNodeId parentId))
    ( (.&&) (n1id .== pgNodeId parentId)
    (n2id .== nId))
    returnA -< row
    src/Gargantext/Database/Node/Contact.hs
    View file @ 6116a39e
    ......@@ -22,12 +22,12 @@ module Gargantext.Database.Node.Contact
    import Control.Lens (makeLenses)
    import Data.Aeson.TH (deriveJSON)
    import Data.Swagger (ToSchema)
    import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
    import Data.Text (Text)
    import Data.Time (UTCTime)
    import Database.PostgreSQL.Simple.FromField (FromField, fromField)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Core.Types (Name)
    import Gargantext.Database.Schema.Node (NodeWrite, node)
    import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..), UserId, AnnuaireId)
    ......@@ -76,15 +76,15 @@ data ContactWho =
    data ContactWhere =
    ContactWhere { _cw_organization :: [Text]
    , _cw_labTeamDepts :: [Text]
    , _cw_role :: Maybe Text
    , _cw_office :: Maybe Text
    , _cw_country :: Maybe Text
    , _cw_city :: Maybe Text
    , _cw_touch :: Maybe ContactTouch
    , _cw_entry :: Maybe UTCTime
    , _cw_exit :: Maybe UTCTime
    } deriving (Eq, Show, Generic)
    ......@@ -105,16 +105,22 @@ nodeContactW maybeName maybeContact aId =
    contact = maybe arbitraryHyperdataContact identity maybeContact
    -- | Main instances of Contact
    instance ToSchema HyperdataContact
    instance ToSchema ContactWho
    instance ToSchema ContactWhere
    instance ToSchema ContactTouch
    -- | ToSchema instances
    instance ToSchema HyperdataContact where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hc_")
    instance ToSchema ContactWho where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cw_")
    instance ToSchema ContactWhere where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cw_")
    instance ToSchema ContactTouch where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ct_")
    instance ToSchema ContactMetaData where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cm_")
    -- | Arbitrary instances
    instance Arbitrary HyperdataContact where
    arbitrary = elements [HyperdataContact Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing]
    -- | Specific Gargantext instance
    instance Hyperdata HyperdataContact
    ......
    src/Gargantext/Database/Node/Document/Insert.hs
    View file @ 6116a39e
    ......@@ -39,7 +39,7 @@ database (in others words parent_id is necessary to preserve privacy for
    instance).
    - Hash policy: this UniqId is a sha256 uniq id which is the result of
    the concatenation of the parameters defined by @hashParameters@.
    the concatenation of the parameters defined by @shaParameters@.
    > -- * Example
    > insertTest :: FromRow r => CorpusId -> [Node HyperdataDocument] -> IO [r]
    ......@@ -79,7 +79,7 @@ import Gargantext.Prelude
    import qualified Data.ByteString.Lazy.Char8 as DC (pack)
    import qualified Data.Digest.Pure.SHA as SHA (sha256, showDigest)
    import qualified Data.Text as DT (pack, unpack, concat, take)
    import Gargantext.Prelude.Utils (hash)
    import Gargantext.Prelude.Utils (sha)
    -- TODO : the import of Document constructor below does not work
    -- import Gargantext.Database.Types.Node (Document)
    --import Gargantext.Database.Types.Node (docExample, hyperdataDocument, HyperdataDocument(..)
    ......@@ -186,7 +186,7 @@ queryInsert = [sql|
    data ReturnId = ReturnId { reInserted :: Bool -- if the document is inserted (True: is new, False: is not new)
    , reId :: NodeId -- always return the id of the document (even new or not new)
    -- this is the uniq id in the database
    , reUniqId :: Text -- Hash Id with concatenation of hash parameters
    , reUniqId :: Text -- Hash Id with concatenation of sha parameters
    } deriving (Show, Generic)
    instance FromRow ReturnId where
    ......@@ -204,14 +204,14 @@ instance AddUniqId HyperdataDocument
    addUniqId = addUniqIdsDoc
    where
    addUniqIdsDoc :: HyperdataDocument -> HyperdataDocument
    addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just hashBdd)
    $ set hyperdataDocument_uniqId (Just hashUni) doc
    addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just shaBdd)
    $ set hyperdataDocument_uniqId (Just shaUni) doc
    where
    hashUni = hash $ DT.concat $ map ($ doc) hashParametersDoc
    hashBdd = hash $ DT.concat $ map ($ doc) ([(\d -> maybeText (_hyperdataDocument_bdd d))] <> hashParametersDoc)
    shaUni = sha $ DT.concat $ map ($ doc) shaParametersDoc
    shaBdd = sha $ DT.concat $ map ($ doc) ([(\d -> maybeText (_hyperdataDocument_bdd d))] <> shaParametersDoc)
    hashParametersDoc :: [(HyperdataDocument -> Text)]
    hashParametersDoc = [ \d -> maybeText (_hyperdataDocument_title d)
    shaParametersDoc :: [(HyperdataDocument -> Text)]
    shaParametersDoc = [ \d -> maybeText (_hyperdataDocument_title d)
    , \d -> maybeText (_hyperdataDocument_abstract d)
    , \d -> maybeText (_hyperdataDocument_source d)
    , \d -> maybeText (_hyperdataDocument_publication_date d)
    ......@@ -226,18 +226,18 @@ instance AddUniqId HyperdataContact
    addUniqId = addUniqIdsContact
    addUniqIdsContact :: HyperdataContact -> HyperdataContact
    addUniqIdsContact hc = set (hc_uniqIdBdd) (Just hashBdd)
    $ set (hc_uniqId ) (Just hashUni) hc
    addUniqIdsContact hc = set (hc_uniqIdBdd) (Just shaBdd)
    $ set (hc_uniqId ) (Just shaUni) hc
    where
    hashUni = uniqId $ DT.concat $ map ($ hc) hashParametersContact
    hashBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybeText (view hc_bdd d)] <> hashParametersContact)
    shaUni = uniqId $ DT.concat $ map ($ hc) shaParametersContact
    shaBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybeText (view hc_bdd d)] <> shaParametersContact)
    uniqId :: Text -> Text
    uniqId = DT.pack . SHA.showDigest . SHA.sha256 . DC.pack . DT.unpack
    -- | TODO add more hashparameters
    hashParametersContact :: [(HyperdataContact -> Text)]
    hashParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName) d
    -- | TODO add more shaparameters
    shaParametersContact :: [(HyperdataContact -> Text)]
    shaParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName) d
    , \d -> maybeText $ view (hc_who . _Just . cw_lastName ) d
    , \d -> maybeText $ view (hc_where . _head . cw_touch . _Just . ct_mail) d
    ]
    ......
    src/Gargantext/Database/Node/Update.hs
    View file @ 6116a39e
    ......@@ -41,6 +41,7 @@ data Update = Rename NodeId Name
    unOnly :: Only a -> a
    unOnly (Only a) = a
    -- TODO-ACCESS
    update :: Update -> Cmd err [Int]
    update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id"
    (DT.take 255 name,nId)
    ......
    src/Gargantext/Database/Node/UpdateOpaleye.hs 0 → 100644
    View file @ 6116a39e
    {-|
    Module : Gargantext.Database.Node.UpdateOpaleye
    Description : Update Node in Database (Postgres)
    Copyright : (c) CNRS, 2017-Present
    License : AGPL + CECILL v3
    Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Node.UpdateOpaleye where
    import Opaleye
    import Data.Aeson (encode, ToJSON)
    import Gargantext.Prelude
    import Gargantext.Database.Schema.Node
    import Gargantext.Database.Types.Node
    import Gargantext.Database.Utils (Cmd, mkCmd)
    updateHyperdata :: ToJSON a => NodeId -> a -> Cmd err Int64
    updateHyperdata i h = mkCmd $ \c -> runUpdate_ c (updateHyperdataQuery i h)
    updateHyperdataQuery :: ToJSON a => NodeId -> a -> Update Int64
    updateHyperdataQuery i h = Update
    { uTable = nodeTable
    , uUpdateWith = updateEasy (\ (Node _ni _nt _nu _np _nn _nd _h)
    -> Node _ni _nt _nu _np _nn _nd h'
    )
    , uWhere = (\row -> _node_id row .== pgNodeId i )
    , uReturning = rCount
    }
    where h' = (pgJSONB $ cs $ encode $ h)
    src/Gargantext/Database/Schema/Ngrams.hs
    View file @ 6116a39e
    ......@@ -51,9 +51,9 @@ type NgramsId = Int
    type NgramsTerms = Text
    type Size = Int
    data NgramsPoly id terms n = NgramsDb { ngrams_id :: id
    , ngrams_terms :: terms
    , ngrams_n :: n
    data NgramsPoly id terms n = NgramsDb { _ngrams_id :: id
    , _ngrams_terms :: terms
    , _ngrams_n :: n
    } deriving (Show)
    type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
    ......@@ -71,12 +71,13 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
    type NgramsDb = NgramsPoly Int Text Int
    $(makeAdaptorAndInstance "pNgramsDb" ''NgramsPoly)
    -- $(makeLensesWith abbreviatedFields ''NgramsPoly)
    makeLenses ''NgramsPoly
    ngramsTable :: Table NgramsWrite NgramsRead
    ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id = optional "id"
    , ngrams_terms = required "terms"
    , ngrams_n = required "n"
    ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { _ngrams_id = optional "id"
    , _ngrams_terms = required "terms"
    , _ngrams_n = required "n"
    }
    )
    ......
    src/Gargantext/Database/Schema/Node.hs
    View file @ 6116a39e
    ......@@ -44,6 +44,7 @@ import Gargantext.Database.Queries.Filter (limit', offset')
    import Gargantext.Database.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
    import Gargantext.Database.Utils
    import Gargantext.Prelude hiding (sum, head)
    import Gargantext.Viz.Graph (HyperdataGraph(..))
    import Opaleye hiding (FromField)
    import Opaleye.Internal.QueryArr (Query)
    ......@@ -218,11 +219,11 @@ nodeTable :: Table NodeWrite NodeRead
    nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
    , _node_typename = required "typename"
    , _node_userId = required "user_id"
    , _node_parentId = optional "parent_id"
    , _node_name = required "name"
    , _node_date = optional "date"
    , _node_hyperdata = required "hyperdata"
    }
    )
    ......@@ -266,21 +267,19 @@ type NodeSearchReadNull =
    (Column (Nullable PGJsonb) )
    (Column (Nullable PGTSVector) )
    --{-
    nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
    nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id = optional "id"
    , _ns_typename = required "typename"
    , _ns_userId = required "user_id"
    , _ns_parentId = required "parent_id"
    , _ns_name = required "name"
    , _ns_date = optional "date"
    , _ns_hyperdata = required "hyperdata"
    , _ns_search = optional "search"
    }
    )
    --}
    queryNodeSearchTable :: Query NodeSearchRead
    queryNodeSearchTable = queryTable nodeTableSearch
    ......@@ -434,7 +433,6 @@ nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Jus
    name = maybe "Annuaire" identity maybeName
    annuaire = maybe defaultAnnuaire identity maybeAnnuaire
    ------------------------------------------------------------------------
    {-
    ......@@ -498,7 +496,7 @@ nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just
    ------------------------------------------------------------------------
    arbitraryGraph :: HyperdataGraph
    arbitraryGraph = HyperdataGraph (Just "Preferences")
    arbitraryGraph = HyperdataGraph Nothing
    nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
    nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
    ......@@ -506,6 +504,12 @@ nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
    name = maybe "Graph" identity maybeName
    graph = maybe arbitraryGraph identity maybeGraph
    mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
    mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
    insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
    insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
    ------------------------------------------------------------------------
    arbitraryPhylo :: HyperdataPhylo
    arbitraryPhylo = HyperdataPhylo Nothing Nothing
    ......@@ -518,10 +522,8 @@ nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
    ------------------------------------------------------------------------
    arbitraryDashboard :: HyperdataDashboard
    arbitraryDashboard = HyperdataDashboard (Just "Preferences")
    ------------------------------------------------------------------------
    node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
    ......@@ -582,6 +584,7 @@ data NewNode = NewNode { _newNodeId :: NodeId
    , _newNodeChildren :: [NodeId] }
    postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
    postNode uid pid (Node' nt txt v []) = do
    pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
    case pids of
    ......@@ -597,6 +600,7 @@ postNode uid pid (Node' NodeAnnuaire txt v ns) = do
    NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
    pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
    pure $ NewNode pid' pids
    postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
    ......@@ -614,7 +618,45 @@ mkNodeWithParent NodeUser Nothing uId name =
    where
    hd = HyperdataUser . Just . pack $ show EN
    mkNodeWithParent _ Nothing _ _ = nodeError HasParent
    mkNodeWithParent _ _ _ _ = nodeError NotImplYet
    ------------------------------------------------------------------------
    mkNodeWithParent NodeFolder (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
    where
    hd = HyperdataFolder . Just . pack $ show EN
    mkNodeWithParent NodeFolderPrivate (Just i) uId _ =
    insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
    where
    hd = HyperdataFolder . Just . pack $ show EN
    mkNodeWithParent NodeFolderShared (Just i) uId _ =
    insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
    where
    hd = HyperdataFolder . Just . pack $ show EN
    mkNodeWithParent NodeFolderPublic (Just i) uId _ =
    insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
    where
    hd = HyperdataFolder . Just . pack $ show EN
    mkNodeWithParent NodeTeam (Just i) uId _ =
    insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
    where
    hd = HyperdataFolder . Just . pack $ show EN
    ------------------------------------------------------------------------
    mkNodeWithParent NodeCorpus (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
    where
    hd = defaultCorpus
    mkNodeWithParent _ _ _ _ = nodeError NotImplYet
    mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
    ......@@ -655,10 +697,6 @@ defaultList cId =
    mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
    mkNode nt p u = insertNodesR [nodeDefault nt p u]
    mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
    mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
    mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
    mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
    where
    ......@@ -669,7 +707,6 @@ mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
    dashboard = maybe arbitraryDashboard identity maybeDashboard
    mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
    mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
    ......@@ -678,8 +715,5 @@ mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
    pgNodeId :: NodeId -> Column PGInt4
    pgNodeId = pgInt4 . id2int
    getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
    getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
    src/Gargantext/Database/Schema/NodeNgram.hs deleted 100644 → 0
    View file @ aa583794
    {-|
    Module : Gargantext.Database.Schema.NodeNgrams
    Description : NodeNgram for Ngram indexation or Lists
    Copyright : (c) CNRS, 2017-Present
    License : AGPL + CECILL v3
    Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    NodeNgram: relation between a Node and a Ngrams
    if Node is a Document then it is indexing
    if Node is a List then it is listing (either Stop, Candidate or Map)
    -}
    {-# OPTIONS_GHC -fno-warn-orphans #-}
    {-# LANGUAGE Arrows #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    -- TODO NodeNgrams
    module Gargantext.Database.Schema.NodeNgram where
    import Data.ByteString (ByteString)
    import Data.Text (Text)
    import Control.Lens.TH (makeLenses)
    import Control.Monad (void)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
    import Gargantext.Core.Types.Main (ListTypeId)
    import Gargantext.Database.Types.Node (NodeId, ListId)
    import Gargantext.Database.Schema.Node (pgNodeId)
    import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId)
    import Gargantext.Prelude
    import Gargantext.Database.Utils (formatPGSQuery)
    import Opaleye
    import qualified Database.PostgreSQL.Simple as DPS
    -- | TODO : remove id
    data NodeNgramPoly node_id ngrams_id parent_id ngrams_type list_type weight
    = NodeNgram { nng_node_id :: node_id
    , nng_ngrams_id :: ngrams_id
    , nng_parent_id :: parent_id
    , nng_ngramsType :: ngrams_type
    , nng_listType :: list_type
    , nng_weight :: weight
    } deriving (Show)
    type NodeNgramWrite =
    NodeNgramPoly
    (Column PGInt4 )
    (Column PGInt4 )
    (Maybe (Column PGInt4))
    (Column PGInt4 )
    (Column PGInt4 )
    (Column PGFloat8)
    type NodeNgramRead =
    NodeNgramPoly
    (Column PGInt4 )
    (Column PGInt4 )
    (Column PGInt4 )
    (Column PGInt4 )
    (Column PGInt4 )
    (Column PGFloat8)
    type NodeNgramReadNull =
    NodeNgramPoly
    (Column (Nullable PGInt4 ))
    (Column (Nullable PGInt4 ))
    (Column (Nullable PGInt4 ))
    (Column (Nullable PGInt4 ))
    (Column (Nullable PGInt4 ))
    (Column (Nullable PGFloat8))
    type NodeNgram =
    NodeNgramPoly NodeId Int (Maybe NgramsParentId) NgramsTypeId Int Double
    newtype NgramsParentId = NgramsParentId Int
    deriving (Show, Eq, Num)
    pgNgramsParentId :: NgramsParentId -> Column PGInt4
    pgNgramsParentId (NgramsParentId n) = pgInt4 n
    $(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
    makeLenses ''NodeNgramPoly
    nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
    nodeNgramTable = Table "nodes_ngrams"
    ( pNodeNgram NodeNgram
    { nng_node_id = required "node_id"
    , nng_ngrams_id = required "ngrams_id"
    , nng_parent_id = optional "parent_id"
    , nng_ngramsType = required "ngrams_type"
    , nng_listType = required "list_type"
    , nng_weight = required "weight"
    }
    )
    queryNodeNgramTable :: Query NodeNgramRead
    queryNodeNgramTable = queryTable nodeNgramTable
    --{-
    insertNodeNgrams :: [NodeNgram] -> Cmd err Int
    insertNodeNgrams = insertNodeNgramW
    . map (\(NodeNgram n g p ngt lt w) ->
    NodeNgram (pgNodeId n)
    (pgInt4 g)
    (pgNgramsParentId <$> p)
    (pgNgramsTypeId ngt)
    (pgInt4 lt)
    (pgDouble w)
    )
    insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
    insertNodeNgramW nns =
    mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
    where
    insertNothing = (Insert { iTable = nodeNgramTable
    , iRows = nns
    , iReturning = rCount
    , iOnConflict = (Just DoNothing)
    })
    --}
    type NgramsText = Text
    updateNodeNgrams' :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ()
    updateNodeNgrams' _ [] = pure ()
    updateNodeNgrams' listId input = void $ execPGSQuery updateQuery (DPS.Only $ Values fields input')
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
    input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
    updateNodeNgrams'_debug :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ByteString
    updateNodeNgrams'_debug listId input = formatPGSQuery updateQuery (DPS.Only $ Values fields input')
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
    input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
    updateQuery :: DPS.Query
    updateQuery = [sql|
    WITH new(node_id,ngrams_type,terms,typeList) as (?)
    INSERT into nodes_ngrams (node_id,ngrams_id,ngrams_type,list_type,weight)
    SELECT node_id,ngrams.id,ngrams_type,typeList,1 FROM new
    JOIN ngrams ON ngrams.terms = new.terms
    ON CONFLICT (node_id, ngrams_id, ngrams_type) DO
    -- DO NOTHING
    UPDATE SET list_type = excluded.list_type
    ;
    |]
    src/Gargantext/Database/Schema/NodeNode.hs
    View file @ 6116a39e
    ......@@ -25,11 +25,11 @@ commentary with @some markup@.
    module Gargantext.Database.Schema.NodeNode where
    import Control.Lens (view)
    import Control.Lens (view, (^.))
    import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
    import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Control.Lens.TH (makeLenses)
    import Data.Maybe (Maybe, catMaybes)
    import Data.Text (Text, splitOn)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    ......@@ -44,10 +44,10 @@ import Control.Arrow (returnA)
    import qualified Opaleye as O
    data NodeNodePoly node1_id node2_id score cat
    = NodeNode { nn_node1_id :: node1_id
    , nn_node2_id :: node2_id
    , nn_score :: score
    , nn_category :: cat
    = NodeNode { _nn_node1_id :: node1_id
    , _nn_node2_id :: node2_id
    , _nn_score :: score
    , _nn_category :: cat
    } deriving (Show)
    type NodeNodeWrite = NodeNodePoly (Column (PGInt4))
    ......@@ -59,7 +59,7 @@ type NodeNodeRead = NodeNodePoly (Column (PGInt4))
    (Column (PGInt4))
    (Column (PGFloat8))
    (Column (PGInt4))
    type NodeNodeReadNull = NodeNodePoly (Column (Nullable PGInt4))
    (Column (Nullable PGInt4))
    (Column (Nullable PGFloat8))
    ......@@ -68,14 +68,14 @@ type NodeNodeReadNull = NodeNodePoly (Column (Nullable PGInt4))
    type NodeNode = NodeNodePoly Int Int (Maybe Double) (Maybe Int)
    $(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
    $(makeLensesWith abbreviatedFields ''NodeNodePoly)
    makeLenses ''NodeNodePoly
    nodeNodeTable :: Table NodeNodeWrite NodeNodeRead
    nodeNodeTable = Table "nodes_nodes" (pNodeNode
    NodeNode { nn_node1_id = required "node1_id"
    , nn_node2_id = required "node2_id"
    , nn_score = optional "score"
    , nn_category = optional "category"
    NodeNode { _nn_node1_id = required "node1_id"
    , _nn_node2_id = required "node2_id"
    , _nn_score = optional "score"
    , _nn_category = optional "category"
    }
    )
    ......@@ -144,9 +144,9 @@ selectDocs cId = runOpaQuery (queryDocs cId)
    queryDocs :: CorpusId -> O.Query (Column PGJsonb)
    queryDocs cId = proc () -> do
    (n, nn) <- joinInCorpus -< ()
    restrict -< ( nn_node1_id nn) .== (toNullable $ pgNodeId cId)
    restrict -< ( nn_category nn) .>= (toNullable $ pgInt4 1)
    restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
    restrict -< nn^.nn_node1_id .== (toNullable $ pgNodeId cId)
    restrict -< nn^.nn_category .>= (toNullable $ pgInt4 1)
    restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
    returnA -< view (node_hyperdata) n
    ......@@ -156,9 +156,9 @@ selectDocNodes cId = runOpaQuery (queryDocNodes cId)
    queryDocNodes :: CorpusId -> O.Query NodeRead
    queryDocNodes cId = proc () -> do
    (n, nn) <- joinInCorpus -< ()
    restrict -< ( nn_node1_id nn) .== (toNullable $ pgNodeId cId)
    restrict -< ( nn_category nn) .>= (toNullable $ pgInt4 1)
    restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
    restrict -< nn^.nn_node1_id .== (toNullable $ pgNodeId cId)
    restrict -< nn^.nn_category .>= (toNullable $ pgInt4 1)
    restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
    returnA -< n
    ......@@ -166,7 +166,7 @@ joinInCorpus :: O.Query (NodeRead, NodeNodeReadNull)
    joinInCorpus = leftJoin queryNodeTable queryNodeNodeTable cond
    where
    cond :: (NodeRead, NodeNodeRead) -> Column PGBool
    cond (n, nn) = nn_node2_id nn .== (view node_id n)
    cond (n, nn) = nn^.nn_node2_id .== (view node_id n)
    ------------------------------------------------------------------------
    ......
    src/Gargantext/Database/Schema/NodeNodeNgrams.hs
    View file @ 6116a39e
    ......@@ -25,7 +25,7 @@ module Gargantext.Database.Schema.NodeNodeNgrams
    import Prelude
    import Data.Maybe (Maybe)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    --import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Control.Lens.TH (makeLenses)
    import Gargantext.Database.Utils (Cmd, mkCmd)
    import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId, NgramsId)
    import Gargantext.Database.Schema.Node (pgNodeId)
    ......@@ -35,12 +35,12 @@ import Opaleye
    data NodeNodeNgramsPoly id' n1 n2 ngrams_id ngt w
    = NodeNodeNgrams { nnng_id :: id'
    , nnng_node1_id :: n1
    , nnng_node2_id :: n2
    , nnng_ngrams_id :: ngrams_id
    , nnng_ngramsType :: ngt
    , nnng_weight :: w
    = NodeNodeNgrams { _nnng_id :: id'
    , _nnng_node1_id :: n1
    , _nnng_node2_id :: n2
    , _nnng_ngrams_id :: ngrams_id
    , _nnng_ngramsType :: ngt
    , _nnng_weight :: w
    } deriving (Show)
    ......@@ -71,19 +71,19 @@ type NodeNodeNgramsReadNull =
    type NodeNodeNgrams =
    NodeNodeNgramsPoly (Maybe Int) CorpusId DocId NgramsId NgramsTypeId Double
    --{-
    $(makeAdaptorAndInstance "pNodeNodeNgrams" ''NodeNodeNgramsPoly)
    -- $(makeLensesWith abbreviatedFields ''NodeNodeNgramsPoly)
    makeLenses ''NodeNodeNgramsPoly
    nodeNodeNgramsTable :: Table NodeNodeNgramsWrite NodeNodeNgramsRead
    nodeNodeNgramsTable = Table "node_node_ngrams"
    ( pNodeNodeNgrams NodeNodeNgrams
    { nnng_id = optional "id"
    , nnng_node1_id = required "node1_id"
    , nnng_node2_id = required "node2_id"
    , nnng_ngrams_id = required "ngrams_id"
    , nnng_ngramsType = required "ngrams_type"
    , nnng_weight = required "weight"
    { _nnng_id = optional "id"
    , _nnng_node1_id = required "node1_id"
    , _nnng_node2_id = required "node2_id"
    , _nnng_ngrams_id = required "ngrams_id"
    , _nnng_ngramsType = required "ngrams_type"
    , _nnng_weight = required "weight"
    }
    )
    ......
    src/Gargantext/Database/TextSearch.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Database/Tree.hs
    View file @ 6116a39e
    ......@@ -16,7 +16,16 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
    module Gargantext.Database.Tree
    ( treeDB
    , TreeError(..)
    , HasTreeError(..)
    , dbTree
    , toNodeTree
    , DbTreeNode
    , isDescendantOf
    , isIn
    ) where
    import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
    import Control.Monad.Error.Class (MonadError(throwError))
    ......@@ -27,7 +36,7 @@ import Database.PostgreSQL.Simple.SqlQQ
    import Gargantext.Prelude
    import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
    import Gargantext.Database.Types.Node (NodeId)
    import Gargantext.Database.Types.Node (NodeId, DocId)
    import Gargantext.Database.Config (fromNodeTypeId)
    import Gargantext.Database.Utils (Cmd, runPGSQuery)
    ------------------------------------------------------------------------
    ......@@ -84,26 +93,53 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
    -- | Main DB Tree function
    -- TODO add typenames as parameters
    dbTree :: RootId -> Cmd err [DbTreeNode]
    dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
    WITH RECURSIVE
    tree (id, typename, parent_id, name) AS
    dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
    <$> runPGSQuery [sql|
    WITH RECURSIVE
    tree (id, typename, parent_id, name) AS
    (
    SELECT p.id, p.typename, p.parent_id, p.name
    FROM nodes AS p
    WHERE p.id = ?
    UNION
    SELECT c.id, c.typename, c.parent_id, c.name
    FROM nodes AS c
    INNER JOIN tree AS s ON c.parent_id = s.id
    -- WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90)
    )
    SELECT * from tree;
    |] (Only rootId)
    isDescendantOf :: NodeId -> RootId -> Cmd err Bool
    isDescendantOf childId rootId = (== [Only True])
    <$> runPGSQuery [sql| WITH RECURSIVE
    tree (id, parent_id) AS
    (
    SELECT p.id, p.typename, p.parent_id, p.name
    FROM nodes AS p
    WHERE p.id = ?
    UNION
    SELECT c.id, c.typename, c.parent_id, c.name
    SELECT c.id, c.parent_id
    FROM nodes AS c
    INNER JOIN tree AS s ON c.parent_id = s.id
    WHERE c.typename IN (2,3,5,30,31,40,7,9,90)
    )
    SELECT * from tree;
    |] (Only rootId)
    WHERE c.id = ?
    UNION
    SELECT p.id, p.parent_id
    FROM nodes AS p
    INNER JOIN tree AS t ON t.parent_id = p.id
    )
    SELECT COUNT(*) = 1 from tree AS t
    WHERE t.id = ?;
    |] (childId, rootId)
    -- TODO should we check the category?
    isIn :: NodeId -> DocId -> Cmd err Bool
    isIn cId docId = ( == [Only True])
    <$> runPGSQuery [sql| SELECT COUNT(*) = 1
    FROM nodes_nodes nn
    WHERE nn.node1_id = ?
    AND nn.node2_id = ?;
    |] (cId, docId)
    src/Gargantext/Database/Types/Node.hs
    View file @ 6116a39e
    ......@@ -41,9 +41,8 @@ import Data.ByteString.Lazy (ByteString)
    import Data.Either
    import Data.Eq (Eq)
    import Data.Monoid (mempty)
    import Data.Text (Text, unpack, pack)
    import Data.Text (Text, unpack)
    import Data.Time (UTCTime)
    import Data.Time.Segment (jour, timesAfter, Granularity(D))
    import Data.Swagger
    import Text.Read (read)
    ......@@ -55,19 +54,21 @@ import Servant
    import Test.QuickCheck.Arbitrary
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Instances.Time ()
    import Test.QuickCheck.Instances.Text ()
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Viz.Phylo (Phylo)
    --import Gargantext.Database.Utils
    ------------------------------------------------------------------------
    newtype NodeId = NodeId Int
    deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON)
    instance ToField NodeId where
    toField (NodeId n) = toField n
    instance FromField NodeId where
    fromField field mdata = do
    n <- fromField field mdata
    ......@@ -77,6 +78,7 @@ instance FromField NodeId where
    instance ToSchema NodeId
    type NodeTypeId = Int
    type NodeName = Text
    type TSVector = Text
    ......@@ -86,13 +88,13 @@ data NodePoly id typename userId
    parentId name date
    hyperdata = Node { _node_id :: id
    , _node_typename :: typename
    , _node_userId :: userId
    , _node_parentId :: parentId
    , _node_name :: name
    , _node_date :: date
    , _node_hyperdata :: hyperdata
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "_node_") ''NodePoly)
    ......@@ -102,7 +104,6 @@ $(makeLenses ''NodePoly)
    type Node json = NodePoly NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
    ------------------------------------------------------------------------
    ......@@ -133,12 +134,6 @@ type MasterUserId = UserId
    id2int :: NodeId -> Int
    id2int (NodeId n) = n
    type UTCTime' = UTCTime
    instance Arbitrary UTCTime' where
    arbitrary = elements $ timesAfter 100 D (jour 2000 01 01)
    ------------------------------------------------------------------------
    data Status = Status { status_failed :: !Int
    , status_succeeded :: !Int
    ......@@ -273,18 +268,16 @@ instance Arbitrary Event where
    arbitrary = Event <$> arbitrary <*> arbitrary <*> arbitrary
    instance ToSchema Event where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "event_")
    ------------------------------------------------------------------------
    instance Arbitrary Text where
    arbitrary = elements $ map (\c -> pack [c]) ['a'..'z']
    data Resource = Resource { resource_path :: !(Maybe Text)
    , resource_scraper :: !(Maybe Text)
    , resource_query :: !(Maybe Text)
    , resource_events :: !([Event])
    , resource_status :: !Status
    , resource_date :: !UTCTime'
    , resource_date :: !UTCTime
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "resource_") ''Resource)
    ......@@ -297,7 +290,7 @@ instance Arbitrary Resource where
    <*> arbitrary
    instance ToSchema Resource where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "resource_")
    ------------------------------------------------------------------------
    data HyperdataUser = HyperdataUser { hyperdataUser_language :: Maybe Text
    ......@@ -408,13 +401,6 @@ $(deriveJSON (unPrefix "hyperdataDashboard_") ''HyperdataDashboard)
    instance Hyperdata HyperdataDashboard
    -- TODO add the Graph Structure here
    data HyperdataGraph = HyperdataGraph { hyperdataGraph_preferences :: !(Maybe Text)
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "hyperdataGraph_") ''HyperdataGraph)
    instance Hyperdata HyperdataGraph
    ------------------------------------------------------------------------
    -- TODO add the Graph Structure here
    ......@@ -444,10 +430,15 @@ $(deriveJSON (unPrefix "hd_") ''HyperData)
    instance Hyperdata HyperData
    ------------------------------------------------------------------------
    -- | Then a Node can be either a Folder or a Corpus or a Document
    data NodeType = NodeUser
    | NodeFolderPrivate
    | NodeFolderShared | NodeTeam
    | NodeFolderPublic
    | NodeFolder
    | NodeCorpus | NodeCorpusV3 | NodeTexts | NodeDocument
    | NodeAnnuaire | NodeContact
    | NodeGraph | NodePhylo
    ......@@ -481,7 +472,7 @@ data NodePolySearch id typename userId
    hyperdata search = NodeSearch { _ns_id :: id
    , _ns_typename :: typename
    , _ns_userId :: userId
    -- , nodeUniqId :: hashId
    -- , nodeUniqId :: shaId
    , _ns_parentId :: parentId
    , _ns_name :: name
    , _ns_date :: date
    ......@@ -534,17 +525,20 @@ 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}"
    instance ToSchema HyperdataCorpus where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "hyperdataCorpus_") proxy
    & mapped.schema.description ?~ "a corpus"
    & mapped.schema.example ?~ toJSON hyperdataCorpus
    instance ToSchema HyperdataAnnuaire where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "hyperdataAnnuaire_") proxy
    & mapped.schema.description ?~ "an annuaire"
    & mapped.schema.example ?~ toJSON hyperdataAnnuaire
    instance ToSchema HyperdataDocument where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "_hyperdataDocument_") proxy
    & mapped.schema.description ?~ "a document"
    & mapped.schema.example ?~ toJSON hyperdataDocument
    ......@@ -560,14 +554,16 @@ instance ToSchema hyperdata =>
    (Maybe UserId)
    ParentId NodeName
    UTCTime hyperdata
    )
    ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
    instance ToSchema hyperdata =>
    ToSchema (NodePoly NodeId NodeTypeId
    UserId
    (Maybe ParentId) NodeName
    UTCTime hyperdata
    )
    ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
    instance ToSchema hyperdata =>
    ......@@ -575,16 +571,19 @@ instance ToSchema hyperdata =>
    (Maybe UserId)
    ParentId NodeName
    UTCTime hyperdata (Maybe TSVector)
    )
    ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ns_")
    instance ToSchema hyperdata =>
    ToSchema (NodePolySearch NodeId NodeTypeId
    UserId
    (Maybe ParentId) NodeName
    UTCTime hyperdata (Maybe TSVector)
    )
    ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ns_")
    instance ToSchema Status
    instance ToSchema Status where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "status_")
    src/Gargantext/Database/Utils.hs
    View file @ 6116a39e
    ......@@ -73,12 +73,13 @@ mkCmd k = do
    conn <- view connection
    liftIO $ k conn
    runCmd :: (HasConnection env) => env
    -> Cmd' env err a
    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 :: Default FromFields fields haskells
    => Select fields -> Cmd err [haskells]
    runOpaQuery q = mkCmd $ \c -> runQuery c q
    formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
    ......
    src/Gargantext/Prelude.hs
    View file @ 6116a39e
    ......@@ -7,8 +7,6 @@ Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    Here is a longer description of this module, containing some
    commentary with @some markup@.
    -}
    {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
    ......@@ -43,7 +41,7 @@ import Protolude ( Bool(True, False), Int, Int64, Double, Integer
    , Fractional, Num, Maybe(Just,Nothing)
    , Enum, Bounded, Float
    , Floating, Char, IO
    , pure, (>>=), (=<<), (<*>), (<$>)
    , pure, (>>=), (=<<), (<*>), (<$>), (>>)
    , putStrLn
    , head, flip
    , Ord, Integral, Foldable, RealFrac, Monad, filter
    ......@@ -87,41 +85,6 @@ printDebug msg x = putStrLn $ msg <> " " <> show x
    -- printDebug _ _ = pure ()
    map2 :: (t -> b) -> [[t]] -> [[b]]
    map2 fun = map (map fun)
    -- Some Statistics sugar functions
    -- Exponential Average
    eavg :: [Double] -> Double
    eavg (x:xs) = a*x + (1-a)*(eavg xs)
    where a = 0.70
    eavg [] = 0
    -- Simple Average
    mean :: Fractional a => [a] -> a
    mean xs = sum xs / fromIntegral (length xs)
    sumMaybe :: Num a => [Maybe a] -> Maybe a
    sumMaybe = fmap sum . M.sequence
    variance :: Floating a => [a] -> a
    variance xs = sum ys / (fromIntegral (length xs) - 1)
    where
    m = mean xs
    ys = map (\x -> (x - m) ** 2) xs
    deviation :: Floating a => [a] -> a
    deviation = sqrt . variance
    movingAverage :: (Eq b, Fractional b) => Int -> [b] -> [b]
    movingAverage steps xs = map mean $ chunkAlong steps 1 xs
    ma :: [Double] -> [Double]
    ma = movingAverage 3
    -- | splitEvery n == chunkAlong n n
    splitEvery :: Int -> [a] -> [[a]]
    splitEvery _ [] = []
    ......@@ -176,7 +139,8 @@ chunkAlongV a b l = only (while dropAlong)
    splitAlong :: [Int] -> [Char] -> [[Char]]
    splitAlong _ [] = [] -- No list? done
    splitAlong [] xs = [xs] -- No place to split at? Return the remainder
    splitAlong (x:xs) ys = take x ys : splitAlong xs (drop x ys) -- take until our split spot, recurse with next split spot and list remainder
    splitAlong (x:xs) ys = take x ys : splitAlong xs (drop x ys)
    -- take until our split spot, recurse with next split spot and list remainder
    takeWhileM :: (Monad m) => (a -> Bool) -> [m a] -> m [a]
    takeWhileM _ [] = return []
    ......@@ -212,14 +176,12 @@ count2map xs = M.map (/ (fromIntegral (length xs))) (count2map' xs)
    count2map' :: (Ord k, Foldable t) => t k -> Map k Double
    count2map' xs = L.foldl' (\x y -> insertWith (+) y 1 x) M.empty xs
    trunc :: (RealFrac a, Integral c, Integral b) => b -> a -> c
    trunc n = truncate . (* 10^n)
    trunc' :: Int -> Double -> Double
    trunc' n x = fromIntegral $ truncate $ (x * 10^n)
    ------------------------------------------------------------------------
    bool2num :: Num a => Bool -> a
    bool2num True = 1
    ......@@ -248,7 +210,7 @@ scaleNormalize xs = map (\x -> (x - v / (m + 1))) xs'
    where
    v = variance xs'
    m = mean xs'
    xs' = map abs xs
    xs' = map abs xs
    normalize :: [Double] -> [Double]
    normalize as = normalizeWith identity as
    ......@@ -269,8 +231,8 @@ zipSnd f xs = zip xs (f xs)
    maximumWith :: (Ord a1, Foldable t) => (a2 -> a1) -> t a2 -> a2
    maximumWith f = L.maximumBy (compare `on` f)
    -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
    -- | To get all combinations of a list with no
    -- repetition and apply a function to the resulting list of pairs
    listToCombi :: forall a b. (a -> b) -> [a] -> [(b,b)]
    listToCombi f l = [ (f x, f y) | (x:rest) <- L.tails l, y <- rest ]
    ......@@ -305,5 +267,33 @@ init' :: Text -> [a] -> [a]
    init' = listSafeN "init" initMay
    ------------------------------------------------------------------------
    --- Some Statistics sugar functions
    -- Exponential Average
    eavg :: [Double] -> Double
    eavg (x:xs) = a*x + (1-a)*(eavg xs)
    where a = 0.70
    eavg [] = 0
    -- Simple Average
    mean :: Fractional a => [a] -> a
    mean xs = sum xs / fromIntegral (length xs)
    sumMaybe :: Num a => [Maybe a] -> Maybe a
    sumMaybe = fmap sum . M.sequence
    variance :: Floating a => [a] -> a
    variance xs = sum ys / (fromIntegral (length xs) - 1)
    where
    m = mean xs
    ys = map (\x -> (x - m) ** 2) xs
    deviation :: Floating a => [a] -> a
    deviation = sqrt . variance
    movingAverage :: (Eq b, Fractional b) => Int -> [b] -> [b]
    movingAverage steps xs = map mean $ chunkAlong steps 1 xs
    ma :: [Double] -> [Double]
    ma = movingAverage 3
    -----------------------------------------------------------------------
    src/Gargantext/Prelude/Utils.hs
    View file @ 6116a39e
    ......@@ -18,28 +18,55 @@ 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)
    import GHC.IO (FilePath)
    import Gargantext.Prelude
    import Gargantext.API.Settings
    import System.Random (newStdGen)
    import qualified System.Random.Shuffle as SRS
    import System.Directory (createDirectoryIfMissing)
    import qualified Data.ByteString.Lazy.Char8 as Char
    import qualified Data.Digest.Pure.SHA as SHA (sha256, showDigest)
    import qualified Data.Text as Text
    import Gargantext.Database.Types.Node (NodeId, NodeType)
    import Data.ByteString (ByteString)
    import Crypto.Argon2 as Crypto
    import Data.Either
    import Data.ByteString.Base64.URL as URL
    shuffle :: MonadRandom m => [a] -> m [a]
    shuffle ns = SRS.shuffleM ns
    type FolderPath = FilePath
    type FileName = FilePath
    hash :: Text -> Text
    hash = Text.pack
    . SHA.showDigest
    . SHA.sha256
    sha :: Text -> Text
    sha = Text.pack
    . SHA.showDigest
    . SHA.sha256
    . Char.pack
    . Text.unpack
    data NodeToHash = NodeToHash { nodeType :: NodeType
    , nodeId :: NodeId
    }
    secret_key :: ByteString
    secret_key = "WRV5ymit8s~ge6%08dLR7Q!gBcpb1MY%7e67db2206"
    type SecretKey = ByteString
    hashNode :: SecretKey -> NodeToHash -> ByteString
    hashNode sk (NodeToHash nt ni) = case hashResult of
    Left e -> panic (cs $ show e)
    Right h -> URL.encode h
    where
    hashResult = Crypto.hash Crypto.defaultHashOptions
    sk
    (cs $ show nt <> show ni)
    toPath :: Int -> Text -> (FolderPath,FileName)
    toPath n x = (Text.unpack $ Text.intercalate "/" [x1,x2], Text.unpack xs)
    ......@@ -58,7 +85,7 @@ writeFile :: (MonadReader env m, MonadIO m, HasSettings env, SaveFile a)
    => a -> m FilePath
    writeFile a = do
    dataPath <- view (settings . fileFolder) <$> ask
    (fp,fn) <- liftIO $ (toPath 3) . hash . Text.pack . show <$> newStdGen
    (fp,fn) <- liftIO $ (toPath 3) . sha . Text.pack . show <$> newStdGen
    let foldPath = dataPath <> "/" <> fp
    filePath = foldPath <> "/" <> fn
    ......
    src/Gargantext/Text/Corpus/API.hs
    View file @ 6116a39e
    ......@@ -15,39 +15,25 @@ Portability : POSIX
    {-# LANGUAGE InstanceSigs #-}
    module Gargantext.Text.Corpus.API
    ( ExternalAPIs(..)
    , Query
    , Limit
    , get
    , externalAPIs
    )
    where
    import GHC.Generics (Generic)
    import Data.Aeson
    import Data.Maybe
    import Gargantext.Prelude
    import Gargantext.Core (Lang(..))
    import Gargantext.API.Orchestrator.Types (ExternalAPIs(..), externalAPIs)
    import Gargantext.Database.Types.Node (HyperdataDocument(..))
    import Test.QuickCheck.Arbitrary
    import Test.QuickCheck (elements)
    import Data.Swagger
    import qualified Gargantext.Text.Corpus.API.Pubmed as PUBMED
    import qualified Gargantext.Text.Corpus.API.Isidore as ISIDORE
    import qualified Gargantext.Text.Corpus.API.Hal as HAL
    import qualified Gargantext.Text.Corpus.API.Istex as ISTEX
    -- | Main Types
    data ExternalAPIs = All
    | PubMed
    | HAL_EN
    | HAL_FR
    | IsTex_EN
    | IsTex_FR
    | Isidore_EN
    | Isidore_FR
    -- | IsidoreAuth
    deriving (Show, Eq, Enum, Bounded, Generic)
    -- | Get External API metadata main function
    get :: ExternalAPIs -> Query -> Maybe Limit -> IO [HyperdataDocument]
    get All _ _ = undefined
    ......@@ -63,20 +49,6 @@ get IsTex_FR q l = ISTEX.get FR q l
    get Isidore_EN q l = ISIDORE.get EN (fromIntegral <$> l) (Just q) Nothing
    get Isidore_FR q l = ISIDORE.get FR (fromIntegral <$> l) (Just q) Nothing
    -- | Main Instances
    instance FromJSON ExternalAPIs
    instance ToJSON ExternalAPIs
    externalAPIs :: [ExternalAPIs]
    externalAPIs = [minBound..maxBound]
    instance Arbitrary ExternalAPIs
    where
    arbitrary = elements externalAPIs
    instance ToSchema ExternalAPIs
    -- | Some Sugar for the documentation
    type Query = PUBMED.Query
    type Limit = PUBMED.Limit
    ......
    src/Gargantext/Text/Examples.hs
    View file @ 6116a39e
    ......@@ -19,7 +19,6 @@ This document defines basic of Text definitions according to Gargantext..
    - What is a sentence ?
    - What is a paragraph ?
    -}
    {-# LANGUAGE BangPatterns #-}
    ......@@ -134,6 +133,7 @@ incExcSpeGen_sorted :: Ord t => Map (t,t) Int -> ([(t,Double)],[(t,Double)])
    incExcSpeGen_sorted m = both ordonne (incExcSpeGen $ cooc2mat ti m)
    where
    (ti,fi) = createIndices m
    ordonne x = sortWith (Down . snd) $ zip (map snd $ M.toList fi) (toList x)
    ordonne x = sortWith (Down . snd)
    $ zip (map snd $ M.toList fi) (toList x)
    src/Gargantext/Text/Terms/Eleve.hs
    View file @ 6116a39e
    ......@@ -367,9 +367,21 @@ split inE t0 ts =
    ------------------------------------------------------------------------
    mainEleve :: Int -> [[Text]] -> [[[Text]]]
    mainEleve n i = mainEleveWith m n i
    mainEleve n x = mainEleve' n x x
    mainEleve' :: Int -> [[Text]] -> [[Text]] -> [[[Text]]]
    mainEleve' n x y = mainEleveWith x' n y
    where
    m = buildTries n (fmap toToken i)
    x' = buildTries n (fmap toToken x)
    -- (fmap toToken i) is computed twice, since mainEleveWith is computing it too
    -- | This function should take the longest possible chain of:
    -- mainEleve'' n x y = maxChainSizeOf [ mainEleve' n x y
    -- , mainEleve' n x x
    -- , mainEleve' n y y
    -- ]
    mainEleve'' :: Int -> [[Text]] -> [[Text]] -> [[[Text]]]
    mainEleve'' = undefined
    mainEleveWith :: Tries Token () -> Int -> [[Text]] -> [[[Text]]]
    mainEleveWith m n i = fmap (split n info_autonomy t) (fmap toToken i)
    ......@@ -386,9 +398,9 @@ type Checks e = [(Text, Int, e, e, e, e, e, e, e, e, e)]
    testEleve :: e ~ Double => Bool -> Int -> [Text] -> Checks e -> IO Bool
    testEleve debug n output checks = do
    let
    res = split n info_autonomy nt <$> inp
    res = split (1 + n) info_autonomy nt <$> input
    when debug $ do
    P.putStrLn $ show input
    P.putStrLn . show $ (printToken <$>) <$> input
    P.putStrLn ""
    printTrie info_entropy nt
    P.putStrLn ""
    ......@@ -400,14 +412,13 @@ testEleve debug n output checks = do
    where
    out = T.words <$> output
    expected = fmap (T.splitOn "-") <$> out
    input = (T.splitOn "-" =<<) <$> out
    inp = toToken <$> input
    input = toToken . (T.splitOn "-" =<<) <$> out
    nt :: Tries Token (I Double)
    nt = normalizeEntropy info_entropy_var set_autonomy
    . evTrie identity set_entropy_var
    . entropyTrie isTerminal
    $ buildTries n inp
    $ buildTries n input
    check f msg ref my =
    if f ref my
    ......@@ -434,7 +445,7 @@ testEleve debug n output checks = do
    check sim "bwd_autonomy" bwd_autonomy (nodeEntropy info_autonomy (_bwd nt'))
    -- | TODO real data is a list of tokenized sentences
    example0, example1, example2, example3, example4, example5, example6 :: [Text]
    example0, example1, example2, example3, example4, example5, example6, example7, example8, example9 :: [Text]
    example0 = ["New-York is New-York and New-York"]
    example1 = ["to-be or not to-be"]
    example2 = ["to-be-or not to-be-or NOT to-be and"]
    ......@@ -447,8 +458,13 @@ example6 = ["le-petit chat"
    ,"le-petit rat"
    ,"le gros rat"
    ]
    example7 = ["a-b d", "a-c e", "a-c", "a-b", "a-b", "a-c", "a-c", "a-b"]
    -- example8 = ["z f", "z", "z", "z"] <> example7
    example8 = ["z", "z", "z", "z"] <> example7 <> example7 <> example7
    example9 = (T.replace "z" "a") <$> example8
    --example8 = ["a-b d", "a-c e", "a f", "a-c g", "a-b h", "a i", "a j", "a-b k", "a-c l", "a-c m", "a n", "a-b o"]
    checks0, checks2 :: Checks Double
    checks0, checks2, checks7, checks8, checks9 :: Checks Double
    checks0 =
    -- [(token, count, entropy, ev, autonomy, fwd_entropy, fwd_ev, fwd_autonomy, bwd_entropy, bwd_ev, bwd_autonomy)]
    ......@@ -487,8 +503,27 @@ checks2 = []
    ]
    -}
    runTestsEleve :: IO ()
    runTestsEleve =
    checks7 =
    [ ("a b", 4, 2, 1.5, 1.0106455960380136, 2, 1, 0.7302967433402215, 2, 2, 1.2909944487358056)
    , ("a c", 4, 2, 1.5, 1.0106455960380136, 2, 1, 0.7302967433402215, 2, 2, 1.2909944487358056)
    , ("a", 8, 2, -0.7139421727208477, 0.9315597394596105, 1, -1.7139421727208477, 0.1695158759052029, 3, 0.2860578272791523, 1.693603603014018)
    ]
    checks8 =
    [ ("a b", 4, 2, 1.5, 1.2384061243840367, 2, 1, 0.9190418024406298, 2, 2, 1.5577704463274435)
    , ("a c", 4, 2, 1.5, 1.2384061243840367, 2, 1, 0.9190418024406298, 2, 2, 1.5577704463274435)
    , ("a", 8, 2, -1.1151193576322829, 0.8012882295122719, 1, -2.115119357632283, 1.1025957503820932e-2, 3, -0.11511935763228287, 1.5915505015207227)
    , ("z", 4, 2, -1.1151193576322829, 0.9576679529201777, 2, -1.1151193576322829, 1.0906240295212841, 2, -1.1151193576322829, 0.8247118763190712)
    ]
    checks9 =
    [ ("a b", 4, 2, 0.8741854163060885, 0.9234576822288185, 2, -0.25162916738782304, 0.2891449181301934, 2, 2, 1.5577704463274435)
    , ("a c", 4, 2, 0.8741854163060885, 0.9234576822288185, 2, -0.25162916738782304, 0.2891449181301934, 2, 2, 1.5577704463274435)
    , ("a", 12, 2.91829583405449, 3.763498724462999e-2, 1.518835832034022, 2.251629167387823, -0.6290316794220367, 1.2162041043595873, 3.5849625007211565, 0.7043016539112967, 1.8214675597084569)
    ]
    runTestsEleve :: Bool -> IO ()
    runTestsEleve doChecks =
    forM_
    [("example0", 3, example0, checks0)
    ,("example0", 2, example0, [])
    ......@@ -498,9 +533,12 @@ runTestsEleve =
    ,("example4", 4, example4, [])
    ,("example5", 5, example5, [])
    ,("example6", 2, example6, [])
    ,("example7", 2, example7, checks7)
    ,("example8", 2, example8, checks8)
    ,("example9", 2, example9, checks9)
    ]
    (\(name, n, ex, checks) -> do
    P.putStrLn $ name <> " " <> show n
    b <- testEleve False n ex checks
    b <- testEleve False n ex (if doChecks then checks else [])
    P.putStrLn $ " splitting: " <> if b then "PASS" else "FAIL"
    )
    src/Gargantext/Viz/AdaptativePhylo.hs
    View file @ 6116a39e
    ......@@ -44,6 +44,8 @@ import GHC.IO (FilePath)
    import Control.DeepSeq (NFData)
    import Control.Lens (makeLenses)
    import qualified Data.Text.Lazy as TextLazy
    ----------------
    -- | Config | --
    ......@@ -65,6 +67,15 @@ data Proximity =
    deriving (Show,Generic,Eq)
    data Synchrony =
    ByProximityThreshold
    { _bpt_threshold :: Double
    , _bpt_sensibility :: Double}
    | ByProximityDistribution
    { _bpd_sensibility :: Double}
    deriving (Show,Generic,Eq)
    data TimeUnit =
    Year
    { _year_period :: Int
    ......@@ -77,7 +88,13 @@ data ContextualUnit =
    Fis
    { _fis_support :: Int
    , _fis_size :: Int }
    deriving (Show,Generic,Eq)
    deriving (Show,Generic,Eq)
    data Quality =
    Quality { _qua_relevance :: Double
    , _qua_minBranch :: Int }
    deriving (Show,Generic,Eq)
    data Config =
    ......@@ -88,9 +105,13 @@ data Config =
    , phyloName :: Text
    , phyloLevel :: Int
    , phyloProximity :: Proximity
    , phyloSynchrony :: Synchrony
    , phyloQuality :: Quality
    , timeUnit :: TimeUnit
    , contextualUnit :: ContextualUnit
    , branchSize :: Int
    , exportLabel :: [PhyloLabel]
    , exportSort :: Sort
    , exportFilter :: [Filter]
    } deriving (Show,Generic,Eq)
    ......@@ -102,10 +123,14 @@ defaultConfig =
    , corpusParser = Csv 1000
    , phyloName = pack "Default Phylo"
    , phyloLevel = 2
    , phyloProximity = WeightedLogJaccard 10 0 0.05
    , phyloProximity = WeightedLogJaccard 10 0 0.1
    , phyloSynchrony = ByProximityDistribution 0
    , phyloQuality = Quality 0.1 1
    , timeUnit = Year 3 1 5
    , contextualUnit = Fis 2 4
    , branchSize = 3
    , contextualUnit = Fis 1 5
    , exportLabel = [BranchLabel MostInclusive 2, GroupLabel MostEmergentInclusive 2]
    , exportSort = ByHierarchy
    , exportFilter = [ByBranchSize 2]
    }
    instance FromJSON Config
    ......@@ -118,6 +143,20 @@ instance FromJSON TimeUnit
    instance ToJSON TimeUnit
    instance FromJSON ContextualUnit
    instance ToJSON ContextualUnit
    instance FromJSON PhyloLabel
    instance ToJSON PhyloLabel
    instance FromJSON Tagger
    instance ToJSON Tagger
    instance FromJSON Sort
    instance ToJSON Sort
    instance FromJSON Order
    instance ToJSON Order
    instance FromJSON Filter
    instance ToJSON Filter
    instance FromJSON Synchrony
    instance ToJSON Synchrony
    instance FromJSON Quality
    instance ToJSON Quality
    -- | Software parameters
    ......@@ -248,17 +287,18 @@ data PhyloGroup =
    PhyloGroup { _phylo_groupPeriod :: (Date,Date)
    , _phylo_groupLevel :: Level
    , _phylo_groupIndex :: Int
    , _phylo_groupLabel :: Text
    , _phylo_groupSupport :: Support
    , _phylo_groupNgrams :: [Int]
    , _phylo_groupCooc :: !(Cooc)
    , _phylo_groupBranchId :: PhyloBranchId
    , _phylo_groupMeta :: Map Text [Double]
    , _phylo_groupLevelParents :: [Pointer]
    , _phylo_groupLevelChilds :: [Pointer]
    , _phylo_groupPeriodParents :: [Pointer]
    , _phylo_groupPeriodChilds :: [Pointer]
    , _phylo_groupGhostPointers :: [Pointer]
    }
    deriving (Generic, Show, Eq)
    deriving (Generic, Show, Eq, NFData)
    -- | Weight : A generic mesure that can be associated with an Id
    type Weight = Double
    ......@@ -266,8 +306,6 @@ type Weight = Double
    -- | Pointer : A weighted pointer to a given PhyloGroup
    type Pointer = (PhyloGroupId, Weight)
    type Link = ((PhyloGroupId, PhyloGroupId), Weight)
    data Filiation = ToParents | ToChilds deriving (Generic, Show)
    data PointerType = TemporalPointer | LevelPointer deriving (Generic, Show)
    ......@@ -290,13 +328,53 @@ data PhyloFis = PhyloFis
    } deriving (Generic,NFData,Show,Eq)
    ----------------
    -- | Export | --
    ----------------
    type DotId = TextLazy.Text
    data EdgeType = GroupToGroup | BranchToGroup | BranchToBranch | PeriodToPeriod deriving (Show,Generic,Eq)
    data Filter = ByBranchSize { _branch_size :: Double } deriving (Show,Generic,Eq)
    data Order = Asc | Desc deriving (Show,Generic,Eq)
    data Sort = ByBirthDate { _sort_order :: Order } | ByHierarchy deriving (Show,Generic,Eq)
    data Tagger = MostInclusive | MostEmergentInclusive deriving (Show,Generic,Eq)
    data PhyloLabel =
    BranchLabel
    { _branch_labelTagger :: Tagger
    , _branch_labelSize :: Int }
    | GroupLabel
    { _group_labelTagger :: Tagger
    , _group_labelSize :: Int }
    deriving (Show,Generic,Eq)
    data PhyloBranch =
    PhyloBranch
    { _branch_id :: PhyloBranchId
    , _branch_label :: Text
    , _branch_meta :: Map Text [Double]
    } deriving (Generic, Show)
    data PhyloExport =
    PhyloExport
    { _export_groups :: [PhyloGroup]
    , _export_branches :: [PhyloBranch]
    } deriving (Generic, Show)
    ----------------
    -- | Lenses | --
    ----------------
    makeLenses ''Config
    makeLenses ''Proximity
    makeLenses ''Quality
    makeLenses ''ContextualUnit
    makeLenses ''PhyloLabel
    makeLenses ''TimeUnit
    makeLenses ''PhyloFoundations
    makeLenses ''PhyloFis
    ......@@ -305,6 +383,8 @@ makeLenses ''PhyloPeriod
    makeLenses ''PhyloLevel
    makeLenses ''PhyloGroup
    makeLenses ''PhyloParam
    makeLenses ''PhyloExport
    makeLenses ''PhyloBranch
    ------------------------
    -- | JSON instances | --
    ......
    src/Gargantext/Viz/Graph.hs
    View file @ 6116a39e
    ......@@ -9,6 +9,7 @@ Portability : POSIX
    -}
    {-# OPTIONS_GHC -fno-warn-orphans #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE DeriveGeneric #-}
    ......@@ -24,9 +25,9 @@ import Data.Swagger
    import Data.Text (Text, pack)
    import GHC.Generics (Generic)
    import GHC.IO (FilePath)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Core.Types (ListId)
    import Gargantext.Database.Types.Node (NodeId)
    import Gargantext.Database.Types.Node (NodeId, Hyperdata)
    import Gargantext.Prelude
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    ......@@ -57,9 +58,7 @@ data Node = Node { node_size :: Int
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "node_") ''Node)
    instance ToSchema Node where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
    data Edge = Edge { edge_source :: Text
    ......@@ -71,9 +70,7 @@ data Edge = Edge { edge_source :: Text
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "edge_") ''Edge)
    instance ToSchema Edge where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
    ---------------------------------------------------------------
    data LegendField = LegendField { _lf_id :: Int
    ......@@ -83,9 +80,7 @@ data LegendField = LegendField { _lf_id :: Int
    $(deriveJSON (unPrefix "_lf_") ''LegendField)
    instance ToSchema LegendField where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
    makeLenses ''LegendField
    --
    ......@@ -93,13 +88,12 @@ data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the grap
    , _gm_corpusId :: [NodeId] -- we can map with different corpus
    , _gm_legend :: [LegendField] -- legend of the Graph
    , _gm_listId :: ListId
    , _gm_version :: Int
    }
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
    instance ToSchema GraphMetadata where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
    makeLenses ''GraphMetadata
    ......@@ -112,10 +106,7 @@ $(deriveJSON (unPrefix "_graph_") ''Graph)
    makeLenses ''Graph
    instance ToSchema Graph where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 7 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
    -- | Intances for the mack
    instance Arbitrary Graph where
    ......@@ -154,6 +145,15 @@ data GraphV3 = GraphV3 { go_links :: [EdgeV3]
    $(deriveJSON (unPrefix "go_") ''GraphV3)
    -----------------------------------------------------------
    data HyperdataGraph = HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "") ''HyperdataGraph)
    instance Hyperdata HyperdataGraph
    makeLenses ''HyperdataGraph
    -----------------------------------------------------------
    graphV3ToGraph :: GraphV3 -> Graph
    ......
    src/Gargantext/Viz/Graph/API.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Graph/FGL.hs
    View file @ 6116a39e
    ......@@ -45,6 +45,24 @@ edges = FGL.edges
    nodes :: Graph gr => gr a b -> [Node]
    nodes = FGL.nodes
    ------------------------------------------------------------------------
    -- | Graph Tools
    filterNeighbors :: Graph_Undirected -> Node -> [Node]
    filterNeighbors g n = List.nub $ neighbors g n
    -- Q: why not D.G.I.deg ? (Int as result)
    degree :: Graph_Undirected -> Node -> Double
    degree g n = fromIntegral $ List.length (filterNeighbors g n)
    vcount :: Graph_Undirected -> Double
    vcount = fromIntegral . List.length . List.nub . nodes
    -- | TODO tests, optim and use IGraph library, fix IO ?
    ecount :: Graph_Undirected -> Double
    ecount = fromIntegral . List.length . List.nub . edges
    ------------------------------------------------------------------
    -- | Main sugared functions
    ......
    src/Gargantext/Viz/Graph/IGraph.hs
    View file @ 6116a39e
    ......@@ -19,6 +19,7 @@ import Data.Serialize (Serialize)
    import Data.Singletons (SingI)
    import Gargantext.Prelude
    import IGraph hiding (mkGraph, neighbors, edges, nodes, Node, Graph)
    import IGraph.Algorithms.Clique as IAC
    import qualified IGraph as IG
    import qualified Data.List as List
    ......@@ -46,10 +47,17 @@ edges = IG.edges
    nodes :: IG.Graph d v e -> [Node]
    nodes = IG.nodes
    ------------------------------------------------------------------
    -- | Tools
    maximalCliques :: IG.Graph d v e -> [[Int]]
    maximalCliques g = IAC.maximalCliques g (min',max')
    where
    min' = 0
    max' = 0
    ------------------------------------------------------------------
    -- | Main sugared functions
    mkGraphUfromEdges :: [(Int, Int)] -> Graph_Undirected
    mkGraphUfromEdges es = mkGraph (List.replicate n ()) $ zip es $ repeat ()
    where
    ......
    src/Gargantext/Viz/Graph/MaxClique.hs 0 → 100644
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Graph/Proxemy.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Graph/Tools.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo/API.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo/Example.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo/PhyloExample.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo/PhyloExport.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo/PhyloMaker.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo/PhyloTools.hs
    View file @ 6116a39e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo/Tools.hs
    View file @ 6116a39e
    This diff is collapsed.
    stack.yaml
    View file @ 6116a39e
    This diff is collapsed.
    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