Skip to content

haskell-gargantext
haskell-gargantext
Unverified Commit b13b85bf authored by Nicolas Pouillard's avatar Nicolas Pouillard
Browse files
Options

[Database] Refactor functions accessing the database

parent 6fdb2550
Pipeline #68 failed with stage
    Hide whitespace changes
    Inline Side-by-side
    Showing with 556 additions and 559 deletions
    src/Gargantext/API.hs
    View file @ b13b85bf
    ......@@ -24,6 +24,7 @@ Thanks @yannEsposito for this.
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE TemplateHaskell #-}
    ......@@ -37,14 +38,14 @@ module Gargantext.API
    where
    ---------------------------------------------------------------------
    import Database.PostgreSQL.Simple (Connection)
    import System.IO (FilePath)
    import GHC.Generics (D1, Meta (..), Rep)
    import GHC.TypeLits (AppendSymbol, Symbol)
    import Control.Lens
    import Control.Monad.IO.Class (liftIO)
    import Control.Monad.IO.Class (liftIO)
    import Control.Monad.Reader (runReaderT)
    import Data.Aeson.Encode.Pretty (encodePretty)
    import qualified Data.ByteString.Lazy.Char8 as BL8
    import Data.Swagger
    ......@@ -70,8 +71,9 @@ import Text.Blaze.Html (Html)
    import Gargantext.Prelude
    import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
    import Gargantext.API.Auth (AuthRequest, AuthResponse, auth')
    import Gargantext.API.Node ( Roots , roots
    import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
    import Gargantext.API.Node ( GargServer
    , Roots , roots
    , NodeAPI , nodeAPI
    , NodesAPI , nodesAPI
    , GraphAPI , graphAPI
    ......@@ -208,9 +210,6 @@ type GargAPI = "api" :> Summary "API " :> GargAPIVersion
    type GargAPIVersion = "v1.0" :> Summary "v1.0: " :> GargAPI'
    auth :: Connection -> AuthRequest -> Handler AuthResponse
    auth conn ar = liftIO $ auth' conn ar
    type GargAPI' =
    -- Auth endpoint
    "auth" :> Summary "AUTH API"
    ......@@ -277,27 +276,24 @@ type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
    server :: Env -> IO (Server API)
    server env = do
    gargAPI <- serverGargAPI env
    -- orchestrator <- scrapyOrchestrator env
    pure $ swaggerFront
    :<|> gargAPI
    :<|> hoistServer (Proxy :: Proxy GargAPI) (`runReaderT` env) serverGargAPI
    :<|> serverIndex
    serverGargAPI :: Env -> IO (Server GargAPI)
    serverGargAPI env = do
    -- orchestrator <- scrapyOrchestrator env
    pure $ auth conn
    :<|> roots conn
    :<|> nodeAPI conn (Proxy :: Proxy HyperdataAny)
    :<|> nodeAPI conn (Proxy :: Proxy HyperdataCorpus)
    :<|> nodeAPI conn (Proxy :: Proxy HyperdataAnnuaire)
    :<|> nodesAPI conn
    serverGargAPI :: GargServer GargAPI
    serverGargAPI -- orchestrator
    = auth
    :<|> roots
    :<|> nodeAPI (Proxy :: Proxy HyperdataAny)
    :<|> nodeAPI (Proxy :: Proxy HyperdataCorpus)
    :<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire)
    :<|> nodesAPI
    :<|> count -- TODO: undefined
    :<|> search conn
    :<|> graphAPI conn -- TODO: mock
    :<|> treeAPI conn
    :<|> search
    :<|> graphAPI -- TODO: mock
    :<|> treeAPI
    -- :<|> orchestrator
    where
    conn = env ^. env_conn
    serverIndex :: Server (Get '[HTML] Html)
    serverIndex = $(do (Just s) <- liftIO (fileTypeToFileTree (FileTypeFile "purescript-gargantext/dist/index.html"))
    ......
    src/Gargantext/API/Auth.hs
    View file @ b13b85bf
    ......@@ -22,6 +22,7 @@ Main authorisation of Gargantext are managed in this module
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.API.Auth
    ......@@ -31,11 +32,11 @@ import Data.Aeson.TH (deriveJSON)
    import Data.List (elem)
    import Data.Swagger
    import Data.Text (Text, reverse)
    import Database.PostgreSQL.Simple (Connection)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Database.Root (getRoot)
    import Gargantext.Database.Types.Node (NodePoly(_node_id))
    import Gargantext.Database.Utils (Cmd)
    import Gargantext.Prelude hiding (reverse)
    import Test.QuickCheck (elements, oneof)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    ......@@ -81,17 +82,17 @@ arbitraryUsername = ["gargantua", "user1", "user2"]
    arbitraryPassword :: [Password]
    arbitraryPassword = map reverse arbitraryUsername
    checkAuthRequest :: Username -> Password -> Connection -> IO CheckAuth
    checkAuthRequest u p c
    checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
    checkAuthRequest u p
    | not (u `elem` arbitraryUsername) = pure InvalidUser
    | u /= reverse p = pure InvalidPassword
    | otherwise = do
    muId <- getRoot u c
    muId <- getRoot u
    pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
    auth' :: Connection -> AuthRequest -> IO AuthResponse
    auth' c (AuthRequest u p) = do
    checkAuthRequest' <- checkAuthRequest u p c
    auth :: AuthRequest -> Cmd err AuthResponse
    auth (AuthRequest u p) = do
    checkAuthRequest' <- checkAuthRequest u p
    case checkAuthRequest' of
    InvalidUser -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
    InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
    ......
    src/Gargantext/API/Count.hs
    View file @ b13b85bf
    ......@@ -146,5 +146,5 @@ instance ToSchema Count
    -- arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
    -----------------------------------------------------------------------
    count :: Query -> Handler Counts
    count :: Monad m => Query -> m Counts
    count _ = undefined
    src/Gargantext/API/Ngrams.hs
    View file @ b13b85bf
    ......@@ -28,6 +28,7 @@ add get
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE RankNTypes #-}
    {-# OPTIONS -fno-warn-orphans #-}
    module Gargantext.API.Ngrams
    ......@@ -35,6 +36,7 @@ module Gargantext.API.Ngrams
    import Prelude (round)
    -- import Gargantext.Database.Schema.User (UserId)
    import Data.Functor (($>))
    import Data.Patch.Class (Replace, replace)
    --import qualified Data.Map.Strict.Patch as PM
    import Data.Monoid
    ......@@ -42,24 +44,26 @@ import Data.Monoid
    import Data.Set (Set)
    import qualified Data.Set as Set
    --import Data.Maybe (catMaybes)
    --import qualified Data.Map.Strict as DM
    -- import qualified Data.Map.Strict as DM
    import Data.Map.Strict (Map)
    --import qualified Data.Set as Set
    import Control.Lens ((.~))
    import Control.Monad.IO.Class (MonadIO, liftIO)
    import Control.Lens (Prism', prism', (.~), (#))
    import Control.Monad (guard)
    import Control.Monad.Error.Class (MonadError, throwError)
    import Data.Aeson
    import Data.Aeson.TH (deriveJSON)
    import Data.Either(Either(Left))
    import Data.Map (lookup)
    import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
    import Data.Swagger
    import Data.Swagger hiding (version)
    import Data.Text (Text)
    import Database.PostgreSQL.Simple (Connection)
    import GHC.Generics (Generic)
    --import Gargantext.Core.Types.Main (Tree(..))
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Database.Types.Node (NodeType(..))
    import Gargantext.Database.Schema.Node (defaultList)
    import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
    import qualified Gargantext.Database.Schema.Ngrams as Ngrams
    import Gargantext.Database.Utils (Cmd)
    import Gargantext.Prelude
    import Gargantext.Core.Types (ListType(..), ListId, CorpusId, Limit, Offset)
    import Prelude (Enum, Bounded, minBound, maxBound)
    ......@@ -184,27 +188,18 @@ instance ToSchema NgramsPatch
    instance Arbitrary NgramsPatch where
    arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
    data NgramsIdPatch =
    NgramsIdPatch { _nip_ngrams :: NgramsTerm
    , _nip_ngramsPatch :: NgramsPatch
    }
    deriving (Ord, Eq, Show, Generic)
    $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
    instance ToSchema NgramsIdPatch
    instance Arbitrary NgramsIdPatch where
    arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
    --
    -- TODO:
    -- * This should be a Map NgramsId NgramsPatch
    -- * Patchs -> Patches
    newtype NgramsIdPatchs =
    NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
    newtype NgramsTablePatch =
    NgramsTablePatch { _nip_ngramsIdPatchs :: Map NgramsTerm NgramsPatch }
    deriving (Ord, Eq, Show, Generic, Arbitrary)
    $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
    instance ToSchema NgramsIdPatchs
    $(deriveJSON (unPrefix "_nip_") ''NgramsTablePatch)
    instance ToSchema NgramsTablePatch
    -- TODO: replace by mempty once we have the Monoid instance
    emptyNgramsTablePatch :: NgramsTablePatch
    emptyNgramsTablePatch = NgramsTablePatch mempty
    ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    ......@@ -246,22 +241,34 @@ type TableNgramsApiGet = Summary " Table Ngrams API Get"
    type TableNgramsApi = Summary " Table Ngrams API Change"
    :> QueryParam "list" ListId
    :> ReqBody '[JSON] NgramsIdPatchsFeed -- Versioned ...
    :> Put '[JSON] NgramsIdPatchsBack -- Versioned ...
    :> ReqBody '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
    :> Put '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
    type NgramsIdPatchsFeed = NgramsIdPatchs
    type NgramsIdPatchsBack = NgramsIdPatchs
    data NgramError = UnsupportedVersion
    deriving (Show)
    class HasNgramError e where
    _NgramError :: Prism' e NgramError
    instance HasNgramError ServantErr where
    _NgramError = prism' make match
    where
    err = err500 { errBody = "NgramError: Unsupported version" }
    make UnsupportedVersion = err
    match e = guard (e == err) $> UnsupportedVersion
    ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
    ngramError nne = throwError $ _NgramError # nne
    {-
    toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
    toLists :: ListId -> NgramsTablePatch -> [(ListId, NgramsId, ListTypeId)]
    -- toLists = undefined
    toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
    toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
    toList = undefined
    toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
    toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsTablePatch -> [NodeNgramsNgrams]
    toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
    toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
    ......@@ -271,26 +278,37 @@ toGroup lId addOrRem (NgramsIdPatch ngId patch) =
    -}
    tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
    tableNgramsPatch = undefined
    -- Apply the given patch to the DB and returns the patch to be applied on the
    -- cilent.
    -- TODO:
    -- In this perliminary version the OT aspect is missing, therefore the version
    -- number is always 1 and the returned patch is always empty.
    tableNgramsPatch :: (HasNgramError err, HasNodeError err)
    => CorpusId -> Maybe ListId
    -- -> Versioned NgramsTablePatch
    -- -> Cmd err (Versioned NgramsTablePatch)
    -> any
    -> Cmd err any
    tableNgramsPatch _ _ _ = undefined
    {-
    tableNgramsPatch conn corpusId maybeList patchs = do
    listId <- case maybeList of
    Nothing -> defaultList conn corpusId
    Just listId' -> pure listId'
    _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
    _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
    _ <- updateNodeNgrams conn (toLists listId patchs)
    pure (NgramsIdPatchs [])
    tableNgramsPatch corpusId maybeList (Versioned version _patch) = do
    when (version /= 1) $ ngramError UnsupportedVersion
    _listId <- maybe (defaultList corpusId) pure maybeList
    {-
    _ <- ngramsGroup' Add $ toGroups listId _np_add_children patch
    _ <- ngramsGroup' Del $ toGroups listId _np_rem_children patch
    _ <- updateNodeNgrams (toLists listId patch)
    -}
    pure $ Versioned 1 emptyNgramsTablePatch
    -}
    -- | TODO Errors management
    -- TODO: polymorphic for Annuaire or Corpus or ...
    getTableNgrams :: MonadIO m
    => Connection -> CorpusId -> Maybe TabType
    getTableNgrams :: HasNodeError err
    => CorpusId -> Maybe TabType
    -> Maybe ListId -> Maybe Limit -> Maybe Offset
    -> m NgramsTable
    getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
    -> Cmd err NgramsTable
    getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
    let lieu = "Garg.API.Ngrams: " :: Text
    let ngramsType = case maybeTabType of
    Nothing -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
    ......@@ -301,9 +319,7 @@ getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
    Terms -> Ngrams.NgramsTerms
    _ -> panic $ lieu <> "No Ngrams for this tab"
    listId <- case maybeListId of
    Nothing -> defaultList c cId
    Just lId -> pure lId
    listId <- maybe (defaultList cId) pure maybeListId
    let
    defaultLimit = 10 -- TODO
    ......@@ -311,7 +327,7 @@ getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
    offset_ = maybe 0 identity moffset
    (ngramsTableDatas, mapToParent, mapToChildren) <-
    Ngrams.getNgramsTableDb c NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
    Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
    -- printDebug "ngramsTableDatas" ngramsTableDatas
    ......
    src/Gargantext/API/Node.hs
    View file @ b13b85bf
    ......@@ -17,6 +17,7 @@ Node API
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeOperators #-}
    ......@@ -34,28 +35,27 @@ module Gargantext.API.Node
    -------------------------------------------------------------------
    import Control.Lens (prism', set)
    import Control.Monad.IO.Class (liftIO)
    import Control.Monad ((>>))
    import Control.Monad ((>>), guard)
    --import System.IO (putStrLn, readFile)
    import Data.Aeson (FromJSON, ToJSON)
    import Data.Functor (($>))
    --import Data.Text (Text(), pack)
    import Data.Text (Text())
    import Data.Swagger
    import Data.Time (UTCTime)
    import Database.PostgreSQL.Simple (Connection)
    import GHC.Generics (Generic)
    import Servant
    import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, NgramsIdPatchsFeed, NgramsIdPatchsBack)
    import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
    import Gargantext.Prelude
    import Gargantext.Database.Types.Node
    import Gargantext.Database.Utils (runCmd)
    import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB)
    import Gargantext.Database.Utils (Cmd, CmdM)
    import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB, NodeError(..), HasNodeError(..))
    import Gargantext.Database.Node.Children (getChildren)
    import qualified Gargantext.Database.Node.Update as U (update, Update(..))
    import Gargantext.Database.Facet (FacetDoc , runViewDocuments', OrderBy(..),FacetChart,runViewAuthorsDoc)
    import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
    import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
    import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
    import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
    ......@@ -64,12 +64,14 @@ import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
    import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
    -- import Gargantext.Core (Lang(..))
    import Gargantext.Core.Types (Offset, Limit)
    import Gargantext.Core.Types.Main (Tree, NodeTree, ListId, CorpusId, ContactId)
    import Gargantext.Core.Types.Main (Tree, NodeTree, CorpusId, ContactId)
    -- import Gargantext.Text.Terms (TermType(..))
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
    -------------------------------------------------------------------
    -- | TODO : access by admin only
    type NodesAPI = Delete '[JSON] Int
    ......@@ -77,8 +79,8 @@ type NodesAPI = Delete '[JSON] Int
    -- | Delete Nodes
    -- Be careful: really delete nodes
    -- Access by admin only
    nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
    nodesAPI conn ids = deleteNodes' conn ids
    nodesAPI :: [NodeId] -> GargServer NodesAPI
    nodesAPI ids = deleteNodes ids
    ------------------------------------------------------------------------
    -- | TODO: access by admin only
    ......@@ -89,11 +91,11 @@ type Roots = Get '[JSON] [NodeAny]
    :<|> Delete '[JSON] Int -- TODO
    -- | TODO: access by admin only
    roots :: Connection -> Server Roots
    roots conn = liftIO (putStrLn ( "/user" :: Text) >> getNodesWithParentId 0 Nothing conn)
    :<|> pure (panic "not implemented yet") -- TODO
    :<|> pure (panic "not implemented yet") -- TODO
    :<|> pure (panic "not implemented yet") -- TODO
    roots :: GargServer Roots
    roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
    :<|> pure (panic "not implemented yet") -- TODO
    :<|> pure (panic "not implemented yet") -- TODO
    :<|> pure (panic "not implemented yet") -- TODO
    -------------------------------------------------------------------
    -- | Node API Types management
    ......@@ -136,29 +138,27 @@ type ChildrenApi a = Summary " Summary children"
    :> Get '[JSON] [Node a]
    ------------------------------------------------------------------------
    -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
    nodeAPI :: JSONB a => Connection -> proxy a -> NodeId -> Server (NodeAPI a)
    nodeAPI conn p id
    = liftIO (getNode conn id p)
    :<|> rename conn id
    :<|> postNode conn id
    :<|> putNode conn id
    :<|> deleteNode' conn id
    :<|> getChildren' conn id p
    -- TODO gather it
    :<|> getTable conn id
    :<|> tableNgramsPatch' conn id
    :<|> getTableNgrams conn id
    :<|> getPairing conn id
    :<|> getChart conn id
    :<|> favApi conn id
    :<|> delDocs conn id
    :<|> searchIn conn id
    -- Annuaire
    -- :<|> upload
    -- :<|> query
    nodeAPI :: JSONB a => proxy a -> NodeId -> GargServer (NodeAPI a)
    nodeAPI p id = getNode id p
    :<|> rename id
    :<|> postNode id
    :<|> putNode id
    :<|> deleteNode id
    :<|> getChildren id p
    -- TODO gather it
    :<|> getTable id
    :<|> tableNgramsPatch id
    :<|> getTableNgrams id
    :<|> getPairing id
    :<|> getChart id
    :<|> favApi id
    :<|> delDocs id
    :<|> searchIn id
    -- Annuaire
    -- :<|> upload
    -- :<|> query
    ------------------------------------------------------------------------
    data RenameNode = RenameNode { r_name :: Text }
    deriving (Generic)
    ......@@ -191,9 +191,8 @@ instance FromJSON Documents
    instance ToJSON Documents
    instance ToSchema Documents
    delDocs :: Connection -> CorpusId -> Documents -> Handler [Int]
    delDocs c cId ds = liftIO $ nodesToTrash c
    $ map (\n -> (cId, n, True)) $ documents ds
    delDocs :: CorpusId -> Documents -> Cmd err [Int]
    delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
    ------------------------------------------------------------------------
    type FavApi = Summary " Favorites label"
    ......@@ -210,17 +209,14 @@ instance FromJSON Favorites
    instance ToJSON Favorites
    instance ToSchema Favorites
    putFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
    putFav c cId fs = liftIO $ nodesToFavorite c
    $ map (\n -> (cId, n, True)) $ favorites fs
    putFav :: CorpusId -> Favorites -> Cmd err [Int]
    putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
    delFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
    delFav c cId fs = liftIO $ nodesToFavorite c
    $ map (\n -> (cId, n, False)) $ favorites fs
    delFav :: CorpusId -> Favorites -> Cmd err [Int]
    delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
    favApi :: Connection -> CorpusId -> (Favorites -> Handler [Int])
    :<|> (Favorites -> Handler [Int])
    favApi c cId = putFav c cId :<|> delFav c cId
    favApi :: CorpusId -> GargServer FavApi
    favApi cId = putFav cId :<|> delFav cId
    ------------------------------------------------------------------------
    type TableApi = Summary " Table API"
    ......@@ -254,13 +250,10 @@ type ChartApi = Summary " Chart API"
    ------------------------------------------------------------------------
    type GraphAPI = Get '[JSON] Graph
    graphAPI :: Connection -> NodeId -> Server GraphAPI
    graphAPI c nId = liftIO $ graphAPI' c nId
    graphAPI :: NodeId -> GargServer GraphAPI
    graphAPI nId = do
    graphAPI' :: Connection -> NodeId -> IO Graph
    graphAPI' c nId = do
    nodeGraph <- getNode c nId HyperdataGraph
    nodeGraph <- getNode nId HyperdataGraph
    let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
    [ LegendField 1 "#FFFFFF" "Label 1"
    ......@@ -276,64 +269,58 @@ graphAPI' c nId = do
    -- liftIO $ liftIO $ pure $ maybe t identity maybeGraph
    -- TODO what do we get about the node? to replace contextText
    instance HasNodeError ServantErr where
    _NodeError = prism' make match
    where
    err = err404 { errBody = "NodeError: No list found" }
    make NoListFound = err
    match e = guard (e == err) $> NoListFound
    -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
    instance HasTreeError ServantErr where
    _TreeError = prism' mk (const Nothing) -- Note a prism
    _TreeError = prism' mk (const $ panic "HasTreeError ServantErr: not a prism")
    where
    mk NoRoot = err404 { errBody = "Root node not found" }
    mk EmptyRoot = err500 { errBody = "Root node should not be empty" }
    mk TooManyRoots = err500 { errBody = "Too many root nodes" }
    type TreeAPI = Get '[JSON] (Tree NodeTree)
    treeAPI :: Connection -> NodeId -> Server TreeAPI
    treeAPI :: NodeId -> GargServer TreeAPI
    treeAPI = treeDB
    ------------------------------------------------------------------------
    -- | Check if the name is less than 255 char
    rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
    rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
    rename :: NodeId -> RenameNode -> Cmd err [Int]
    rename nId (RenameNode name) = U.update (U.Rename nId name)
    getTable :: Connection -> NodeId -> Maybe TabType
    getTable :: NodeId -> Maybe TabType
    -> Maybe Offset -> Maybe Limit
    -> Maybe OrderBy -> Handler [FacetDoc]
    getTable c cId ft o l order = liftIO $ case ft of
    (Just Docs) -> runViewDocuments' c cId False o l order
    (Just Trash) -> runViewDocuments' c cId True o l order
    -> Maybe OrderBy -> Cmd err [FacetDoc]
    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
    _ -> panic "not implemented"
    getPairing :: Connection -> ContactId -> Maybe TabType
    getPairing :: ContactId -> Maybe TabType
    -> Maybe Offset -> Maybe Limit
    -> Maybe OrderBy -> Handler [FacetDoc]
    getPairing c cId ft o l order = liftIO $ case ft of
    (Just Docs) -> runViewAuthorsDoc c cId False o l order
    (Just Trash) -> runViewAuthorsDoc c cId True o l order
    -> Maybe OrderBy -> Cmd err [FacetDoc]
    getPairing cId ft o l order = case ft of
    (Just Docs) -> runViewAuthorsDoc cId False o l order
    (Just Trash) -> runViewAuthorsDoc cId True o l order
    _ -> panic "not implemented"
    getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
    -> Handler [FacetChart]
    getChart _ _ _ _ = undefined -- TODO
    getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
    -> Cmd err [FacetChart]
    getChart _ _ _ = undefined -- TODO
    postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
    postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
    postNode :: NodeId -> PostNode -> Cmd err [Int]
    postNode pId (PostNode name nt) = mk nt (Just pId) name
    putNode :: Connection -> NodeId -> Handler Int
    putNode :: NodeId -> Cmd err Int
    putNode = undefined -- TODO
    deleteNodes' :: Connection -> [NodeId] -> Handler Int
    deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
    deleteNode' :: Connection -> NodeId -> Handler Int
    deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
    getChildren' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
    -> Maybe Int -> Maybe Int -> Handler [Node a]
    getChildren' conn pId p nodeType offset limit = liftIO (getChildren conn pId p nodeType offset limit)
    tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
    tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
    query :: Text -> Handler Text
    query :: Monad m => Text -> m Text
    query s = pure s
    ......
    src/Gargantext/API/Search.hs
    View file @ b13b85bf
    ......@@ -19,17 +19,16 @@ Count API part of Gargantext.
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DeriveAnyClass #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.API.Search
    where
    import GHC.Generics (Generic)
    import Data.Time (UTCTime)
    import Control.Monad.IO.Class (liftIO)
    import Data.Aeson.TH (deriveJSON)
    import Data.Swagger
    import Data.Text (Text)
    import Database.PostgreSQL.Simple (Connection)
    import Servant
    import Test.QuickCheck.Arbitrary
    import Test.QuickCheck (elements)
    ......@@ -40,6 +39,7 @@ import Gargantext.Core.Types.Main (Offset, Limit)
    import Gargantext.Database.Types.Node
    import Gargantext.Database.TextSearch
    import Gargantext.Database.Facet
    import Gargantext.Database.Utils (Cmd)
    -----------------------------------------------------------------------
    -- | SearchIn [NodesId] if empty then global search
    ......@@ -88,12 +88,12 @@ instance ToSchema SearchResults where
    type SearchAPI = Post '[JSON] SearchResults
    -----------------------------------------------------------------------
    search :: Connection -> SearchQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Handler SearchResults
    search c (SearchQuery q pId) o l order =
    liftIO $ SearchResults <$> searchInCorpusWithContacts c pId q o l order
    search :: SearchQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err SearchResults
    search (SearchQuery q pId) o l order =
    SearchResults <$> searchInCorpusWithContacts pId q o l order
    searchIn :: Connection -> NodeId -> SearchInQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Handler SearchResults
    searchIn c nId (SearchInQuery q ) o l order =
    liftIO $ SearchResults <$> searchInCorpusWithContacts c nId q o l order
    searchIn :: NodeId -> SearchInQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err SearchResults
    searchIn nId (SearchInQuery q ) o l order =
    SearchResults <$> searchInCorpusWithContacts nId q o l order
    src/Gargantext/API/Settings.hs
    View file @ b13b85bf
    ......@@ -48,7 +48,7 @@ import qualified Jose.Jwa as Jose
    import Control.Monad.Logger
    import Control.Lens
    import Gargantext.Prelude
    import Gargantext.Database.Utils (databaseParameters)
    import Gargantext.Database.Utils (databaseParameters, HasConnection(..))
    import Gargantext.API.Orchestrator.Types
    type PortNumber = Int
    ......@@ -136,6 +136,9 @@ data Env = Env
    makeLenses ''Env
    instance HasConnection Env where
    connection = env_conn
    data MockEnv = MockEnv
    { _menv_firewall :: !FireWall
    }
    ......
    src/Gargantext/Database.hs
    View file @ b13b85bf
    ......@@ -18,12 +18,8 @@ Gargantext's database.
    module Gargantext.Database ( module Gargantext.Database.Utils
    , module Gargantext.Database.Bashql
    , Connection
    )
    where
    import Gargantext.Database.Utils (connectGargandb)
    import Gargantext.Database.Bashql
    import Database.PostgreSQL.Simple (Connection)
    src/Gargantext/Database/Bashql.hs
    View file @ b13b85bf
    ......@@ -59,6 +59,7 @@ AMS, and by SIAM.
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Bashql ( get
    , ls
    ......@@ -70,7 +71,6 @@ module Gargantext.Database.Bashql ( get
    , rename
    , tree
    -- , mkCorpus, mkAnnuaire
    , runCmd'
    )
    where
    ......@@ -80,51 +80,49 @@ import Data.Text (Text)
    import Data.List (concat, last)
    import Gargantext.Core.Types
    import Gargantext.Database.Utils (connectGargandb, Cmd(..), runCmd, mkCmd)
    import Gargantext.Database.Utils (runOpaQuery, Cmd)
    import Gargantext.Database.Schema.Node
    import qualified Gargantext.Database.Node.Update as U (Update(..), update)
    import Gargantext.Prelude
    import Opaleye hiding (FromField)
    -- List of NodeId
    -- type PWD a = PWD UserId [a]
    type PWD = [NodeId]
    --data PWD' a = a | PWD' [a]
    rename :: NodeId -> Text -> Cmd [Int]
    rename n t = mkCmd $ \conn -> U.update (U.Rename n t) conn
    rename :: NodeId -> Text -> Cmd err [Int]
    rename n t = U.update $ U.Rename n t
    mv :: NodeId -> ParentId -> Cmd [Int]
    mv n p = mkCmd $ \conn -> U.update (U.Move n p) conn
    mv :: NodeId -> ParentId -> Cmd err [Int]
    mv n p = U.update $ U.Move n p
    -- | TODO get Children or Node
    get :: PWD -> Cmd [NodeAny]
    get :: PWD -> Cmd err [NodeAny]
    get [] = pure []
    get pwd = Cmd . ReaderT $ \conn -> runQuery conn $ selectNodesWithParentID (last pwd)
    get pwd = runOpaQuery $ selectNodesWithParentID (last pwd)
    -- | Home, need to filter with UserId
    home :: Cmd PWD
    home = map _node_id <$> Cmd (ReaderT (getNodesWithParentId 0 Nothing))
    home :: Cmd err PWD
    home = map _node_id <$> getNodesWithParentId 0 Nothing
    -- | ls == get Children
    ls :: PWD -> Cmd [NodeAny]
    ls :: PWD -> Cmd err [NodeAny]
    ls = get
    tree :: PWD -> Cmd [NodeAny]
    tree :: PWD -> Cmd err [NodeAny]
    tree p = do
    ns <- get p
    children <- mapM (\n -> get [_node_id n]) ns
    pure $ ns <> concat children
    -- | TODO
    post :: PWD -> [NodeWrite'] -> Cmd Int64
    post :: PWD -> [NodeWrite'] -> Cmd err Int64
    post [] _ = pure 0
    post _ [] = pure 0
    post pth ns = Cmd . ReaderT $ insertNodesWithParent (Just $ last pth) ns
    post pth ns = insertNodesWithParent (Just $ last pth) ns
    --postR :: PWD -> [NodeWrite'] -> Cmd [Int]
    --postR :: PWD -> [NodeWrite'] -> Cmd err [Int]
    --postR [] _ _ = pure [0]
    --postR _ [] _ = pure [0]
    --postR pth ns c = mkNodeR (last pth) ns c
    ......@@ -132,15 +130,15 @@ post pth ns = Cmd . ReaderT $ insertNodesWithParent (Just $ last pth) ns
    -- | WIP
    -- rm : mv to trash
    -- del : empty trash
    --rm :: Connection -> PWD -> [NodeId] -> IO Int
    --rm :: PWD -> [NodeId] -> IO Int
    --rm = del
    del :: [NodeId] -> Cmd Int
    del :: [NodeId] -> Cmd err Int
    del [] = pure 0
    del ns = deleteNodes ns
    -- | TODO
    put :: U.Update -> Cmd [Int]
    put u = mkCmd $ U.update u
    put :: U.Update -> Cmd err [Int]
    put = U.update
    -- | TODO
    -- cd (Home UserId) | (Node NodeId)
    ......@@ -151,7 +149,7 @@ put u = mkCmd $ U.update u
    -- type Name = Text
    --mkCorpus :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
    --mkCorpus :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd err NewNode
    --mkCorpus name title ns = do
    -- pid <- home
    --
    ......@@ -167,7 +165,7 @@ put u = mkCmd $ U.update u
    ---- |
    ---- import IMTClient as C
    ---- postAnnuaire "Annuaire IMT" (\n -> (maybe "" identity (C.prenom n)) <> " " <> (maybe "" identity (C.nom n))) (take 30 annuaire)
    --mkAnnuaire :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
    --mkAnnuaire :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd err NewNode
    --mkAnnuaire name title ns = do
    -- pid <- lastMay <$> home
    -- let pid' = case lastMay pid of
    ......@@ -185,6 +183,3 @@ put u = mkCmd $ U.update u
    -- let myCorpus' = Prelude.filter (\n -> T.length (maybe "" identity (hyperdataDocument_title n)) > 30) myCorpus
    -- corporaOf :: Username -> IO [Corpus]
    runCmd' :: Cmd a -> IO a
    runCmd' f = connectGargandb "gargantext.ini" >>= \c -> runCmd c f
    src/Gargantext/Database/Cooc.hs
    View file @ b13b85bf
    ......@@ -13,26 +13,24 @@ Portability : POSIX
    --{-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Cooc where
    import Control.Monad ((>>=))
    import Database.PostgreSQL.Simple
    import Database.PostgreSQL.Simple.SqlQQ
    import Gargantext.Prelude
    import Gargantext (connectGargandb)
    import Gargantext.Database.Utils (Cmd, runCmdDevNoErr, runPGSQuery)
    type CorpusId = Int
    type MainListId = Int
    type GroupListId = Int
    coocTest :: IO [(Int, Int, Int)]
    coocTest = connectGargandb "gargantext.ini"
    >>= \conn -> dBcooc conn 421968 446602 446599
    coocTest = runCmdDevNoErr $ dBcooc 421968 446602 446599
    dBcooc :: Connection -> CorpusId -> MainListId -> GroupListId -> IO [(Int, Int, Int)]
    dBcooc conn corpus mainList groupList = query conn [sql|
    dBcooc :: CorpusId -> MainListId -> GroupListId -> Cmd err [(Int, Int, Int)]
    dBcooc corpus mainList groupList = runPGSQuery [sql|
    set work_mem='1GB';
    --EXPLAIN ANALYZE
    ......
    src/Gargantext/Database/Facet.hs
    View file @ b13b85bf
    ......@@ -21,6 +21,7 @@ Portability : POSIX
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE NoMonomorphismRestriction #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    ------------------------------------------------------------------------
    module Gargantext.Database.Facet
    ......@@ -37,7 +38,6 @@ import Data.Swagger
    import Data.Text (Text)
    import Data.Time (UTCTime)
    import Data.Time.Segment (jour)
    import Database.PostgreSQL.Simple (Connection)
    import GHC.Generics (Generic)
    import Gargantext.Core.Types
    import Gargantext.Core.Utils.Prefix (unPrefix)
    ......@@ -204,8 +204,8 @@ instance Arbitrary OrderBy
    arbitrary = elements [minBound..maxBound]
    runViewAuthorsDoc :: Connection -> ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
    runViewAuthorsDoc c cId t o l order = runQuery c (filterWith o l order $ viewAuthorsDoc cId t ntId)
    runViewAuthorsDoc :: ContactId -> Trash -> 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
    ntId = NodeDocument
    ......@@ -244,13 +244,9 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
    ------------------------------------------------------------------------
    runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
    runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
    -- | TODO use only Cmd with Reader and delete function below
    runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
    runViewDocuments' c cId t o l order = runQuery c ( filterWith o l order
    $ viewDocuments cId t ntId)
    runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
    runViewDocuments cId t o l order =
    runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
    where
    ntId = nodeTypeId NodeDocument
    ......
    src/Gargantext/Database/Flow.hs
    View file @ b13b85bf
    ......@@ -12,11 +12,13 @@ Portability : POSIX
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
    where
    --import Control.Lens (view)
    import Control.Monad.IO.Class (liftIO)
    --import Gargantext.Core.Types
    --import Gargantext.Database.Node.Contact (HyperdataContact(..))
    import Data.Map (Map, lookup)
    ......@@ -29,21 +31,20 @@ import Gargantext.Core.Types (NodePoly(..), ListType(..), listTypeId, Terms(..))
    import Gargantext.Core.Types.Individu (Username)
    import Gargantext.Core.Types.Main
    import Gargantext.Core (Lang(..))
    import Gargantext.Database.Bashql (runCmd') -- , del)
    import Gargantext.Database.Config (userMaster, userArbitrary, corpusMasterName)
    import Gargantext.Database.Flow.Utils (insertToNodeNgrams)
    import Gargantext.Text.Terms (extractTerms)
    import Gargantext.Database.Node.Document.Add (add)
    import Gargantext.Database.Node.Document.Insert (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
    import Gargantext.Database.Root (getRootCmd)
    import Gargantext.Database.Root (getRoot)
    import Gargantext.Database.Schema.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, NgramsType(..), text2ngrams)
    import Gargantext.Database.Schema.Node (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId')
    import Gargantext.Database.Schema.Node (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError)
    import Gargantext.Database.Schema.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
    import Gargantext.Database.Schema.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
    import Gargantext.Database.Schema.User (getUser, UserLight(..))
    import Gargantext.Database.Types.Node (HyperdataDocument(..))
    import Gargantext.Database.Types.Node (NodeType(..), NodeId)
    import Gargantext.Database.Utils (Cmd(..))
    import Gargantext.Database.Utils (Cmd)
    import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Ext.IMT (toSchoolName)
    import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
    ......@@ -52,56 +53,57 @@ import Gargantext.Text.Parsers (parseDocs, FileFormat)
    import System.FilePath (FilePath)
    import qualified Data.Map as DM
    flowCorpus :: FileFormat -> FilePath -> CorpusName -> IO CorpusId
    flowCorpus :: HasNodeError err => FileFormat -> FilePath -> CorpusName -> Cmd err CorpusId
    flowCorpus ff fp cName = do
    hyperdataDocuments' <- map addUniqIdsDoc <$> parseDocs ff fp
    hyperdataDocuments' <- map addUniqIdsDoc <$> liftIO (parseDocs ff fp)
    params <- flowInsert NodeCorpus hyperdataDocuments' cName
    flowCorpus' NodeCorpus hyperdataDocuments' params
    flowInsert :: NodeType -> [HyperdataDocument] -> CorpusName
    -> IO ([ReturnId], MasterUserId, MasterCorpusId, UserId, CorpusId)
    -> Cmd err ([ReturnId], MasterUserId, MasterCorpusId, UserId, CorpusId)
    flowInsert _nt hyperdataDocuments cName = do
    let hyperdataDocuments' = map (\h -> ToDbDocument h) hyperdataDocuments
    (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
    ids <- runCmd' $ insertDocuments masterUserId masterCorpusId NodeDocument hyperdataDocuments'
    ids <- insertDocuments masterUserId masterCorpusId NodeDocument hyperdataDocuments'
    (userId, _, userCorpusId) <- subFlowCorpus userArbitrary cName
    _ <- runCmd' $ add userCorpusId (map reId ids)
    _ <- add userCorpusId (map reId ids)
    pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
    flowAnnuaire :: FilePath -> IO ()
    flowAnnuaire :: FilePath -> Cmd err ()
    flowAnnuaire filePath = do
    contacts <- deserialiseImtUsersFromFile filePath
    contacts <- liftIO $ deserialiseImtUsersFromFile filePath
    ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
    printDebug "length annuaire" ps
    flowInsertAnnuaire :: CorpusName -> [ToDbData]
    -> IO ([ReturnId], UserId, CorpusId, UserId, CorpusId)
    -> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
    flowInsertAnnuaire name children = do
    (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
    ids <- runCmd' $ insertDocuments masterUserId masterCorpusId NodeContact children
    ids <- insertDocuments masterUserId masterCorpusId NodeContact children
    (userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
    _ <- runCmd' $ add userCorpusId (map reId ids)
    _ <- add userCorpusId (map reId ids)
    printDebug "AnnuaireID" userCorpusId
    pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
    flowCorpus' :: NodeType -> [HyperdataDocument]
    flowCorpus' :: HasNodeError err
    => NodeType -> [HyperdataDocument]
    -> ([ReturnId], UserId, CorpusId, UserId, CorpusId)
    -> IO CorpusId
    -> Cmd err CorpusId
    flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, userId,userCorpusId) = do
    --------------------------------------------------
    -- List Ngrams Flow
    userListId <- runCmd' $ flowListUser userId userCorpusId
    userListId <- flowListUser userId userCorpusId
    printDebug "Working on User ListId : " userListId
    let documentsWithId = mergeData (toInserted ids) (toInsert hyperdataDocuments)
    ......@@ -111,22 +113,22 @@ flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, user
    let maps = mapNodeIdNgrams docsWithNgrams
    -- printDebug "maps" (maps)
    indexedNgrams <- runCmd' $ indexNgrams maps
    indexedNgrams <- indexNgrams maps
    -- printDebug "inserted ngrams" indexedNgrams
    _ <- runCmd' $ insertToNodeNgrams indexedNgrams
    _ <- insertToNodeNgrams indexedNgrams
    listId2 <- runCmd' $ flowList masterUserId masterCorpusId indexedNgrams
    listId2 <- flowList masterUserId masterCorpusId indexedNgrams
    printDebug "Working on ListId : " listId2
    --}
    --------------------------------------------------
    _ <- runCmd' $ mkDashboard userCorpusId userId
    _ <- runCmd' $ mkGraph userCorpusId userId
    _ <- mkDashboard userCorpusId userId
    _ <- mkGraph userCorpusId userId
    -- Annuaire Flow
    -- _ <- runCmd' $ mkAnnuaire rootUserId userId
    -- _ <- mkAnnuaire rootUserId userId
    pure userCorpusId
    -- runCmd' $ del [corpusId2, corpusId]
    -- del [corpusId2, corpusId]
    flowCorpus' NodeAnnuaire _hyperdataDocuments (_ids,_masterUserId,_masterCorpusId,_userId,_userCorpusId) = undefined
    flowCorpus' _ _ _ = undefined
    ......@@ -134,19 +136,19 @@ flowCorpus' _ _ _ = undefined
    type CorpusName = Text
    subFlowCorpus :: Username -> CorpusName -> IO (UserId, RootId, CorpusId)
    subFlowCorpus :: Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
    subFlowCorpus username cName = do
    maybeUserId <- runCmd' (getUser username)
    maybeUserId <- getUser username
    let userId = case maybeUserId of
    Nothing -> panic "Error: User does not exist (yet)"
    -- mk NodeUser gargantua_id "Node Gargantua"
    Just user -> userLight_id user
    rootId' <- map _node_id <$> runCmd' (getRootCmd username)
    rootId' <- map _node_id <$> getRoot username
    rootId'' <- case rootId' of
    [] -> runCmd' (mkRoot username userId)
    [] -> mkRoot username userId
    n -> case length n >= 2 of
    True -> panic "Error: more than 1 userNode / user"
    False -> pure rootId'
    ......@@ -154,14 +156,14 @@ subFlowCorpus username cName = do
    corpusId'' <- if username == userMaster
    then do
    ns <- runCmd' $ getCorporaWithParentId' rootId
    ns <- getCorporaWithParentId rootId
    pure $ map _node_id ns
    else
    pure []
    corpusId' <- if corpusId'' /= []
    then pure corpusId''
    else runCmd' $ mkCorpus (Just cName) Nothing rootId userId
    else mkCorpus (Just cName) Nothing rootId userId
    let corpusId = maybe (panic "error corpusId") identity (head corpusId')
    ......@@ -170,25 +172,25 @@ subFlowCorpus username cName = do
    pure (userId, rootId, corpusId)
    subFlowAnnuaire :: Username -> CorpusName -> IO (UserId, RootId, CorpusId)
    subFlowAnnuaire :: Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
    subFlowAnnuaire username _cName = do
    maybeUserId <- runCmd' (getUser username)
    maybeUserId <- getUser username
    let userId = case maybeUserId of
    Nothing -> panic "Error: User does not exist (yet)"
    -- mk NodeUser gargantua_id "Node Gargantua"
    Just user -> userLight_id user
    rootId' <- map _node_id <$> runCmd' (getRootCmd username)
    rootId' <- map _node_id <$> getRoot username
    rootId'' <- case rootId' of
    [] -> runCmd' (mkRoot username userId)
    [] -> mkRoot username userId
    n -> case length n >= 2 of
    True -> panic "Error: more than 1 userNode / user"
    False -> pure rootId'
    let rootId = maybe (panic "error rootId") identity (head rootId'')
    corpusId' <- runCmd' $ mkAnnuaire rootId userId
    corpusId' <- mkAnnuaire rootId userId
    let corpusId = maybe (panic "error corpusId") identity (head corpusId')
    ......@@ -232,14 +234,14 @@ data DocumentIdWithNgrams =
    -- add f :: Text -> Text
    -- newtype Ngrams = Ngrams Text
    -- TODO group terms
    extractNgramsT :: HyperdataDocument -> IO (Map (NgramsT Ngrams) Int)
    extractNgramsT :: HyperdataDocument -> Cmd err (Map (NgramsT Ngrams) Int)
    extractNgramsT doc = do
    let source = text2ngrams $ maybe "Nothing" identity $ _hyperdataDocument_source doc
    let institutes = map text2ngrams $ maybe ["Nothing"] (map toSchoolName . (splitOn ", ")) $ _hyperdataDocument_institutes doc
    let authors = map text2ngrams $ maybe ["Nothing"] (splitOn ", ") $ _hyperdataDocument_authors doc
    let leText = catMaybes [_hyperdataDocument_title doc, _hyperdataDocument_abstract doc]
    terms' <- map text2ngrams <$> map (intercalate " " . _terms_label) <$> concat <$> extractTerms (Multi EN) leText
    terms' <- map text2ngrams <$> map (intercalate " " . _terms_label) <$> concat <$> liftIO (extractTerms (Multi EN) leText)
    pure $ DM.fromList $ [(NgramsT Sources source, 1)]
    <> [(NgramsT Institutes i' , 1)| i' <- institutes ]
    ......@@ -249,8 +251,8 @@ extractNgramsT doc = do
    documentIdWithNgrams :: (HyperdataDocument -> IO (Map (NgramsT Ngrams) Int))
    -> [DocumentWithId] -> IO [DocumentIdWithNgrams]
    documentIdWithNgrams :: (HyperdataDocument -> Cmd err (Map (NgramsT Ngrams) Int))
    -> [DocumentWithId] -> Cmd err [DocumentIdWithNgrams]
    documentIdWithNgrams f = mapM toDocumentIdWithNgrams
    where
    toDocumentIdWithNgrams d = do
    ......@@ -265,7 +267,7 @@ mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
    n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
    indexNgrams :: Map (NgramsT Ngrams ) (Map NodeId Int)
    -> Cmd (Map (NgramsT NgramsIndexed) (Map NodeId Int))
    -> Cmd err (Map (NgramsT NgramsIndexed) (Map NodeId Int))
    indexNgrams ng2nId = do
    terms2id <- insertNgrams (map _ngramsT $ DM.keys ng2nId)
    pure $ DM.mapKeys (indexNgramsT terms2id) ng2nId
    ......@@ -273,7 +275,7 @@ indexNgrams ng2nId = do
    ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    flowList :: UserId -> CorpusId -> Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd ListId
    flowList :: HasNodeError err => UserId -> CorpusId -> Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd err ListId
    flowList uId cId ngs = do
    -- printDebug "ngs:" ngs
    lId <- getOrMkList cId uId
    ......@@ -291,7 +293,7 @@ flowList uId cId ngs = do
    pure lId
    flowListUser :: UserId -> CorpusId -> Cmd Int
    flowListUser :: HasNodeError err => UserId -> CorpusId -> Cmd err Int
    flowListUser uId cId = getOrMkList cId uId
    ------------------------------------------------------------------------
    ......@@ -304,11 +306,11 @@ groupNgramsBy isEqual cId = DM.fromList $ catMaybes [ isEqual n1 n2 | n1 <- DM.k
    -- TODO check: do not insert duplicates
    insertGroups :: ListId -> Map NgramsIndexed NgramsIndexed -> Cmd Int
    insertGroups :: ListId -> Map NgramsIndexed NgramsIndexed -> Cmd err Int
    insertGroups lId ngrs =
    insertNodeNgramsNgramsNew [ NodeNgramsNgrams lId ng1 ng2 (Just 1)
    | (ng1, ng2) <- map (both _ngramsId) $ DM.toList ngrs
    , ng1 /= ng2
    | (ng1, ng2) <- map (both _ngramsId) $ DM.toList ngrs
    , ng1 /= ng2
    ]
    ------------------------------------------------------------------------
    ......@@ -317,7 +319,7 @@ ngrams2list :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> [(ListType,Ngrams
    ngrams2list = zip (repeat CandidateList) . map (\(NgramsT _lost_t ng) -> ng) . DM.keys
    -- | TODO: weight of the list could be a probability
    insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd Int
    insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd err Int
    insertLists lId lngs =
    insertNodeNgrams [ NodeNgram Nothing lId ngr (fromIntegral $ listTypeId l) (listTypeId l)
    | (l,ngr) <- map (second _ngramsId) lngs
    ......
    src/Gargantext/Database/Flow/Pairing.hs
    View file @ b13b85bf
    ......@@ -9,9 +9,10 @@ Portability : POSIX
    -}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    -- {-# LANGUAGE Arrows #-}
    module Gargantext.Database.Flow.Pairing
    ......@@ -19,7 +20,6 @@ module Gargantext.Database.Flow.Pairing
    --import Debug.Trace (trace)
    import Control.Lens (_Just,view)
    import Database.PostgreSQL.Simple (Connection, query)
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    -- import Opaleye
    -- import Opaleye.Aggregate
    ......@@ -36,27 +36,26 @@ import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
    --import Gargantext.Database.Types.Node -- (Hyperdata(..))
    import Gargantext.Database.Node.Contact
    import Gargantext.Database.Flow.Utils
    import Gargantext.Database.Utils (Cmd, mkCmd)
    import Gargantext.Database.Utils (Cmd, runPGSQuery)
    import Gargantext.Database.Node.Children
    import Gargantext.Core.Types.Main
    import Gargantext.Core.Types (NodeType(..))
    import Gargantext.Database.Bashql (runCmd')
    -- TODO mv this type in Types Main
    type Terms = Text
    -- | TODO : add paring policy as parameter
    pairing :: AnnuaireId -> CorpusId -> IO Int
    pairing :: AnnuaireId -> CorpusId -> Cmd err Int
    pairing aId cId = do
    contacts' <- runCmd' $ getContacts aId (Just NodeContact)
    contacts' <- getContacts aId (Just NodeContact)
    let contactsMap = pairingPolicyToMap toLower $ toMaps extractNgramsT contacts'
    ngramsMap' <- runCmd' $ getNgramsTindexed cId Authors
    ngramsMap' <- getNgramsTindexed cId Authors
    let ngramsMap = pairingPolicyToMap lastName ngramsMap'
    let indexedNgrams = pairMaps contactsMap ngramsMap
    runCmd' $ insertToNodeNgrams indexedNgrams
    insertToNodeNgrams indexedNgrams
    -- TODO add List
    lastName :: Terms -> Terms
    ......@@ -92,13 +91,13 @@ pairMaps m1 m2 = DM.fromList $ catMaybes $ map (\(k,n) -> (,) <$> lookup' k m2 <
    -----------------------------------------------------------------------
    getNgramsTindexed:: CorpusId -> NgramsType -> Cmd (Map (NgramsT Ngrams) NgramsId)
    getNgramsTindexed corpusId ngramsType' = mkCmd $ \c -> fromList
    getNgramsTindexed:: CorpusId -> NgramsType -> Cmd err (Map (NgramsT Ngrams) NgramsId)
    getNgramsTindexed corpusId ngramsType' = fromList
    <$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
    <$> selectNgramsTindexed c corpusId ngramsType'
    <$> selectNgramsTindexed corpusId ngramsType'
    selectNgramsTindexed :: Connection -> CorpusId -> NgramsType -> IO [(NgramsId, Terms, Int)]
    selectNgramsTindexed c corpusId ngramsType'' = query c selectQuery (corpusId, ngramsTypeId 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
    ......
    src/Gargantext/Database/Flow/Utils.hs
    View file @ b13b85bf
    ......@@ -11,6 +11,7 @@ Portability : POSIX
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Flow.Utils
    where
    ......@@ -53,11 +54,11 @@ data DocumentIdWithNgrams a =
    } deriving (Show)
    insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd Int
    insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd err Int
    insertToNodeNgrams m = insertNodeNgrams [ NodeNgram Nothing nId ((_ngramsId . _ngramsT ) ng)
    (fromIntegral n) ((ngramsTypeId . _ngramsType) ng)
    | (ng, nId2int) <- DM.toList m
    , (nId, n) <- DM.toList nId2int
    | (ng, nId2int) <- DM.toList m
    , (nId, n) <- DM.toList nId2int
    ]
    src/Gargantext/Database/Node/Children.hs
    View file @ b13b85bf
    ......@@ -14,10 +14,10 @@ Portability : POSIX
    {-# LANGUAGE Arrows #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Node.Children where
    import Database.PostgreSQL.Simple (Connection)
    import Opaleye
    import Gargantext.Core.Types
    import Gargantext.Database.Schema.Node
    ......@@ -29,12 +29,12 @@ import Gargantext.Database.Node.Contact (HyperdataContact)
    import Control.Arrow (returnA)
    -- | TODO: use getChildren with Proxy ?
    getContacts :: ParentId -> Maybe NodeType -> Cmd [Node HyperdataContact]
    getContacts pId maybeNodeType = mkCmd $ \c -> runQuery c $ selectChildren pId maybeNodeType
    getContacts :: ParentId -> Maybe NodeType -> Cmd err [Node HyperdataContact]
    getContacts pId maybeNodeType = runOpaQuery $ selectChildren pId maybeNodeType
    getChildren :: JSONB a => Connection -> ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [Node a]
    getChildren c pId _ maybeNodeType maybeOffset maybeLimit = runQuery c
    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
    ......
    src/Gargantext/Database/Node/Document/Add.hs
    View file @ b13b85bf
    ......@@ -17,6 +17,7 @@ Add Documents/Contact to a Corpus/Annuaire.
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TypeSynonymInstances #-}
    ------------------------------------------------------------------------
    module Gargantext.Database.Node.Document.Add where
    ......@@ -24,7 +25,7 @@ module Gargantext.Database.Node.Document.Add where
    import Data.ByteString.Internal (ByteString)
    import Data.Typeable (Typeable)
    import Database.PostgreSQL.Simple (Query, formatQuery, query, Only(..))
    import Database.PostgreSQL.Simple (Query, Only(..))
    import Database.PostgreSQL.Simple.SqlQQ
    import Database.PostgreSQL.Simple.ToField (toField)
    import Database.PostgreSQL.Simple.ToRow (ToRow(..))
    ......@@ -32,7 +33,7 @@ import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import Data.Text (Text)
    import Gargantext.Database.Utils (mkCmd, Cmd(..))
    import Gargantext.Database.Utils (Cmd, runPGSQuery, formatPGSQuery)
    import Gargantext.Database.Types.Node
    import Gargantext.Prelude
    ......@@ -41,14 +42,14 @@ import GHC.Generics (Generic)
    type ParentId = Int
    add :: ParentId -> [NodeId] -> Cmd [Only Int]
    add pId ns = mkCmd $ \c -> query c queryAdd (Only $ Values fields inputData)
    add :: ParentId -> [NodeId] -> Cmd err [Only Int]
    add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
    inputData = prepare pId ns
    add_debug :: ParentId -> [NodeId] -> Cmd ByteString
    add_debug pId ns = mkCmd $ \c -> formatQuery c queryAdd (Only $ Values fields inputData)
    add_debug :: ParentId -> [NodeId] -> Cmd err ByteString
    add_debug pId ns = formatPGSQuery queryAdd (Only $ Values fields inputData)
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
    inputData = prepare pId ns
    ......
    src/Gargantext/Database/Node/Document/Insert.hs
    View file @ b13b85bf
    ......@@ -44,8 +44,7 @@ the concatenation of the parameters defined by @hashParameters@.
    > -- * Example
    > insertTest :: FromRow r => CorpusId -> [Node HyperdataDocument] -> IO [r]
    > insertTest :: IO [ReturnId]
    > insertTest = connectGargandb "gargantext.ini"
    > >>= \conn -> insertDocuments conn 1 452162 hyperdataDocuments
    > insertTest = runCmdDev $ insertDocuments 1 452162 hyperdataDocuments
    -}
    ------------------------------------------------------------------------
    ......@@ -55,6 +54,7 @@ the concatenation of the parameters defined by @hashParameters@.
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TypeSynonymInstances #-}
    ------------------------------------------------------------------------
    module Gargantext.Database.Node.Document.Insert where
    ......@@ -66,7 +66,7 @@ import Data.Aeson (toJSON, Value)
    import Data.Maybe (maybe)
    import Data.Text (Text)
    import Data.Typeable (Typeable)
    import Database.PostgreSQL.Simple (FromRow, Query, query, Only(..))
    import Database.PostgreSQL.Simple (FromRow, Query, Only(..))
    import Database.PostgreSQL.Simple.FromRow (fromRow, field)
    import Database.PostgreSQL.Simple.SqlQQ
    import Database.PostgreSQL.Simple.ToField (toField)
    ......@@ -74,7 +74,7 @@ import Database.PostgreSQL.Simple.ToRow (ToRow(..))
    import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import GHC.Generics (Generic)
    import Gargantext.Database.Config (nodeTypeId)
    import Gargantext.Database.Utils (mkCmd, Cmd(..))
    import Gargantext.Database.Utils (Cmd, runPGSQuery)
    import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
    import Gargantext.Database.Types.Node
    import Gargantext.Prelude
    ......@@ -113,8 +113,9 @@ import Database.PostgreSQL.Simple (formatQuery)
    data ToDbData = ToDbDocument HyperdataDocument | ToDbContact HyperdataContact
    insertDocuments :: UserId -> ParentId -> NodeType -> [ToDbData] -> Cmd [ReturnId]
    insertDocuments uId pId nodeType hs = mkCmd $ \c -> query c queryInsert (Only $ Values fields $ prepare uId pId nodeType hs)
    insertDocuments :: UserId -> ParentId -> NodeType -> [ToDbData] -> Cmd err [ReturnId]
    insertDocuments uId pId nodeType =
    runPGSQuery queryInsert . Only . Values fields . prepare uId pId nodeType
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
    ......@@ -123,7 +124,7 @@ insertDocuments uId pId nodeType hs = mkCmd $ \c -> query c queryInsert (Only $
    -- to print rendered query (Debug purpose) use @formatQuery@ function.
    {-
    insertDocuments_Debug :: (Hyperdata a, ToJSON a, ToRow a) => UserId -> ParentId -> [a] -> Cmd ByteString
    insertDocuments_Debug uId pId hs = mkCmd $ \conn -> formatQuery conn queryInsert (Only $ Values fields inputData)
    insertDocuments_Debug uId pId hs = formatPGSQuery queryInsert (Only $ Values fields inputData)
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
    inputData = prepare uId pId hs
    ......
    src/Gargantext/Database/Node/Update.hs
    View file @ b13b85bf
    ......@@ -10,8 +10,9 @@ Portability : POSIX
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Node.Update (Update(..), update) where
    ......@@ -21,10 +22,11 @@ import qualified Data.Text as DT
    import Database.PostgreSQL.Simple
    import Gargantext.Prelude
    import Gargantext.Database.Utils
    -- import Data.ByteString
    --rename :: Connection -> NodeId -> Text -> IO ByteString
    --rename conn nodeId name = formatQuery conn "UPDATE nodes SET name=? where id=?" (name,nodeId)
    --rename :: NodeId -> Text -> IO ByteString
    --rename nodeId name = formatPGSQuery "UPDATE nodes SET name=? where id=?" (name,nodeId)
    ------------------------------------------------------------------------
    type NodeId = Int
    type Name = Text
    ......@@ -41,10 +43,10 @@ data Update = Rename NodeId Name
    unOnly :: Only a -> a
    unOnly (Only a) = a
    update :: Update -> Connection -> IO [Int]
    update (Rename nId name) conn = map unOnly <$> query conn "UPDATE nodes SET name=? where id=? returning id"
    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)
    update (Move nId pId) conn = map unOnly <$> query conn "UPDATE nodes SET parent_id= ? where id=? returning id"
    update (Move nId pId) = map unOnly <$> runPGSQuery "UPDATE nodes SET parent_id= ? where id=? returning id"
    (pId, nId)
    src/Gargantext/Database/Root.hs
    View file @ b13b85bf
    ......@@ -21,12 +21,12 @@ Portability : POSIX
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.Database.Root where
    import Database.PostgreSQL.Simple (Connection)
    import Opaleye (restrict, (.==), Query, runQuery)
    import Opaleye (restrict, (.==), Query)
    import Opaleye.PGTypes (pgStrictText, pgInt4)
    import Control.Arrow (returnA)
    import Gargantext.Prelude
    ......@@ -36,13 +36,10 @@ import Gargantext.Database.Schema.Node (queryNodeTable)
    import Gargantext.Database.Schema.User (queryUserTable, UserPoly(..))
    import Gargantext.Database.Config (nodeTypeId)
    import Gargantext.Core.Types.Individu (Username)
    import Gargantext.Database.Utils (Cmd(..), mkCmd)
    import Gargantext.Database.Utils (Cmd, runOpaQuery)
    getRootCmd :: Username -> Cmd [Node HyperdataUser]
    getRootCmd u = mkCmd $ \c -> getRoot u c
    getRoot :: Username -> Connection -> IO [Node HyperdataUser]
    getRoot uname conn = runQuery conn (selectRoot uname)
    getRoot :: Username -> Cmd err [Node HyperdataUser]
    getRoot = runOpaQuery . selectRoot
    selectRoot :: Username -> Query NodeRead
    selectRoot username = proc () -> do
    ......
    src/Gargantext/Database/Schema/Ngrams.hs
    View file @ b13b85bf
    ......@@ -19,6 +19,7 @@ Ngrams connection to the Database.
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.Database.Schema.Ngrams where
    ......@@ -43,12 +44,12 @@ import Gargantext.Database.Config (nodeTypeId,userMaster)
    import Gargantext.Database.Root (getRoot)
    import Gargantext.Database.Types.Node (NodeType)
    import Gargantext.Database.Schema.Node (getListsWithParentId, getCorporaWithParentId)
    import Gargantext.Database.Utils (mkCmd, Cmd(..))
    import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, formatPGSQuery)
    import Gargantext.Prelude
    import Opaleye
    import Prelude (Enum, Bounded, minBound, maxBound)
    import qualified Data.Set as DS
    import qualified Database.PostgreSQL.Simple as DPS
    import qualified Database.PostgreSQL.Simple as PGS
    --{-
    data NgramsPoly id terms n = NgramsDb { ngrams_id :: id
    ......@@ -85,8 +86,8 @@ ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id = optional "id"
    queryNgramsTable :: Query NgramsRead
    queryNgramsTable = queryTable ngramsTable
    dbGetNgramsDb :: DPS.Connection -> IO [NgramsDb]
    dbGetNgramsDb conn = runQuery conn queryNgramsTable
    dbGetNgramsDb :: Cmd err [NgramsDb]
    dbGetNgramsDb = runOpaQuery queryNgramsTable
    --}
    -- | Main Ngrams Types
    ......@@ -118,7 +119,7 @@ data Ngrams = Ngrams { _ngramsTerms :: Text
    } deriving (Generic, Show, Eq, Ord)
    makeLenses ''Ngrams
    instance DPS.ToRow Ngrams where
    instance PGS.ToRow Ngrams where
    toRow (Ngrams t s) = [toField t, toField s]
    text2ngrams :: Text -> Ngrams
    ......@@ -148,7 +149,7 @@ data NgramIds =
    , ngramTerms :: Text
    } deriving (Show, Generic, Eq, Ord)
    instance DPS.FromRow NgramIds where
    instance PGS.FromRow NgramIds where
    fromRow = NgramIds <$> field <*> field
    ----------------------
    ......@@ -160,21 +161,21 @@ indexNgramsT m ngrId = indexNgramsTWith f ngrId
    indexNgramsTWith :: (NgramsTerms -> NgramsId) -> NgramsT Ngrams-> NgramsT NgramsIndexed
    indexNgramsTWith f (NgramsT t n) = NgramsT t (NgramsIndexed n ((f . _ngramsTerms) n))
    insertNgrams :: [Ngrams] -> Cmd (Map NgramsTerms NgramsId)
    insertNgrams :: [Ngrams] -> Cmd err (Map NgramsTerms NgramsId)
    insertNgrams ns = fromList <$> map (\(NgramIds i t) -> (t, i)) <$> (insertNgrams' ns)
    insertNgrams' :: [Ngrams] -> Cmd [NgramIds]
    insertNgrams' ns = mkCmd $ \conn -> DPS.query conn queryInsertNgrams (DPS.Only $ Values fields ns)
    insertNgrams' :: [Ngrams] -> Cmd err [NgramIds]
    insertNgrams' ns = runPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
    where
    fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
    insertNgrams_Debug :: [(NgramsTerms, Size)] -> Cmd ByteString
    insertNgrams_Debug ns = mkCmd $ \conn -> DPS.formatQuery conn queryInsertNgrams (DPS.Only $ Values fields ns)
    insertNgrams_Debug :: [(NgramsTerms, Size)] -> Cmd err ByteString
    insertNgrams_Debug ns = formatPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
    where
    fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
    ----------------------
    queryInsertNgrams :: DPS.Query
    queryInsertNgrams :: PGS.Query
    queryInsertNgrams = [sql|
    WITH input_rows(terms,n) AS (?)
    , ins AS (
    ......@@ -197,26 +198,25 @@ queryInsertNgrams = [sql|
    -- TODO: the way we are getting main Master Corpus and List ID is not clean
    -- TODO: if ids are not present -> create
    -- TODO: Global Env State Monad to keep in memory the ids without retrieving it each time
    getNgramsTableDb :: DPS.Connection
    -> NodeType -> NgramsType
    -> NgramsTableParamUser
    -> Limit -> Offset
    -> IO ([NgramsTableData], MapToParent, MapToChildren)
    getNgramsTableDb c nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
    getNgramsTableDb :: NodeType -> NgramsType
    -> NgramsTableParamUser
    -> Limit -> Offset
    -> Cmd err ([NgramsTableData], MapToParent, MapToChildren)
    getNgramsTableDb nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
    maybeRoot <- head <$> getRoot userMaster c
    maybeRoot <- head <$> getRoot userMaster
    let path = "Garg.Db.Ngrams.getTableNgrams: "
    let masterRootId = maybe (panic $ path <> "no userMaster Tree") (view node_id) maybeRoot
    -- let errMess = panic "Error"
    corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId c masterRootId
    corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId masterRootId
    listMasterId <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId c corpusMasterId
    listMasterId <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId corpusMasterId
    ngramsTableData <- getNgramsTableData c nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId) limit_ offset_
    ngramsTableData <- getNgramsTableData nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId) limit_ offset_
    (mapToParent,mapToChildren) <- getNgramsGroup c listIdUser listMasterId
    (mapToParent,mapToChildren) <- getNgramsGroup listIdUser listMasterId
    pure (ngramsTableData, mapToParent,mapToChildren)
    ......@@ -234,15 +234,14 @@ data NgramsTableData = NgramsTableData { _ntd_ngrams :: Text
    , _ntd_weight :: Double
    } deriving (Show)
    getNgramsTableData :: DPS.Connection
    -> NodeType -> NgramsType
    getNgramsTableData :: NodeType -> NgramsType
    -> NgramsTableParamUser -> NgramsTableParamMaster
    -> Limit -> Offset
    -> IO [NgramsTableData]
    getNgramsTableData conn nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) limit_ offset_ =
    -> Cmd err [NgramsTableData]
    getNgramsTableData nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) limit_ offset_ =
    trace ("Ngrams table params" <> show params) <$>
    map (\(t,n,nt,w) -> NgramsTableData t n (fromListTypeId nt) w) <$>
    DPS.query conn querySelectTableNgrams params
    runPGSQuery querySelectTableNgrams params
    where
    nodeTId = nodeTypeId nodeT
    ngrmTId = ngramsTypeId ngrmT
    ......@@ -251,7 +250,7 @@ getNgramsTableData conn nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam m
    querySelectTableNgrams :: DPS.Query
    querySelectTableNgrams :: PGS.Query
    querySelectTableNgrams = [sql|
    WITH tableUser AS (
    ......@@ -296,20 +295,14 @@ type ListIdMaster = Int
    type MapToChildren = Map Text (Set Text)
    type MapToParent = Map Text Text
    getNgramsGroup :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO (MapToParent, MapToChildren)
    getNgramsGroup conn lu lm = do
    groups <- getNgramsGroup' conn lu lm
    getNgramsGroup :: ListIdUser -> ListIdMaster -> Cmd err (MapToParent, MapToChildren)
    getNgramsGroup lu lm = do
    groups <- runPGSQuery querySelectNgramsGroup (lu,lm)
    let mapChildren = fromListWith (<>) $ map (\(a,b) -> (a, DS.singleton b)) groups
    let mapParent = fromListWith (<>) $ map (\(a,b) -> (b, a)) groups
    pure (mapParent, mapChildren)
    getNgramsGroup' :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO [(Text,Text)]
    getNgramsGroup' conn lu lm = DPS.query conn querySelectNgramsGroup (lu,lm)
    getNgramsGroup'' :: ListIdUser -> ListIdMaster -> Cmd [(Text, Text)]
    getNgramsGroup'' lu lm = mkCmd $ \conn -> DPS.query conn querySelectNgramsGroup (lu,lm)
    querySelectNgramsGroup :: DPS.Query
    querySelectNgramsGroup :: PGS.Query
    querySelectNgramsGroup = [sql|
    WITH groupUser AS (
    SELECT n1.terms AS t1, n2.terms AS t2 FROM nodes_ngrams_ngrams nnn
    ......
    src/Gargantext/Database/Schema/Node.hs
    View file @ b13b85bf
    ......@@ -20,20 +20,21 @@ Portability : POSIX
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.Database.Schema.Node where
    import Control.Arrow (returnA)
    import Control.Lens (set)
    import Control.Lens (Prism', set, view, (#), (^?))
    import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Control.Monad.Error.Class (MonadError(..))
    import Data.Aeson
    import Data.ByteString (ByteString)
    import Data.Maybe (Maybe(..), fromMaybe)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Data.Text (Text, pack)
    import Data.Time (UTCTime)
    import Database.PostgreSQL.Simple (Connection)
    import Database.PostgreSQL.Simple.FromField (FromField, fromField)
    import GHC.Int (Int64)
    import Gargantext.Core (Lang(..))
    ......@@ -53,8 +54,26 @@ import qualified Data.ByteString.Lazy as DBL
    import qualified Data.Profunctor.Product as PP
    ------------------------------------------------------------------------
    instance FromField HyperdataAny
    where
    data NodeError = NoListFound
    deriving (Show)
    class HasNodeError e where
    _NodeError :: Prism' e NodeError
    nodeError :: (MonadError e m, HasNodeError e) => NodeError -> m a
    nodeError ne = throwError $ _NodeError # ne
    catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
    catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))
    ------------------------------------------------------------------------
    type AnnuaireId = Int
    type DocId = Int
    type TypeId = Int
    ------------------------------------------------------------------------
    instance FromField HyperdataAny where
    fromField = fromField'
    instance FromField HyperdataCorpus
    ......@@ -267,8 +286,8 @@ selectNode id = proc () -> do
    returnA -< row
    runGetNodes :: Query NodeRead -> Cmd [NodeAny]
    runGetNodes q = mkCmd $ \conn -> runQuery conn q
    runGetNodes :: Query NodeRead -> Cmd err [NodeAny]
    runGetNodes = runOpaQuery
    ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    ......@@ -298,53 +317,43 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
    returnA -< node
    -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
    -- deleteNode :: Int -> Cmd' Int
    deleteNode :: Int -> Cmd Int
    deleteNode :: Int -> Cmd err Int
    deleteNode n = mkCmd $ \conn ->
    fromIntegral <$> runDelete conn nodeTable
    (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
    deleteNodes :: [Int] -> Cmd Int
    deleteNodes :: [Int] -> Cmd err Int
    deleteNodes ns = mkCmd $ \conn ->
    fromIntegral <$> runDelete conn nodeTable
    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
    getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
    -> Maybe Offset -> Maybe Limit -> IO [Node a]
    getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
    runQuery conn $ selectNodesWith parentId nodeType maybeOffset maybeLimit
    -- TODO: NodeType should match with `a'
    getNodesWith :: JSONB a => Int -> proxy a -> Maybe NodeType
    -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
    getNodesWith parentId _ nodeType maybeOffset maybeLimit =
    runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
    -- NP check type
    getNodesWithParentId :: Int
    -> Maybe Text -> Connection -> IO [NodeAny]
    getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
    getNodesWithParentId' :: Int
    -> Maybe Text -> Connection -> IO [NodeAny]
    getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
    -- TODO: Why is the second parameter ignored?
    -- TODO: Why not use getNodesWith?
    getNodesWithParentId :: Int -> Maybe Text -> Cmd err [NodeAny]
    getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
    ------------------------------------------------------------------------
    getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
    getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
    getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
    getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
    getDocumentsV3WithParentId :: Int -> Cmd err [Node HyperdataDocumentV3]
    getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
    getListsWithParentId :: Connection -> Int -> IO [Node HyperdataList]
    getListsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeList)
    -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
    getDocumentsWithParentId :: Int -> Cmd err [Node HyperdataDocument]
    getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
    getCorporaWithParentId :: Connection -> Int -> IO [Node HyperdataCorpus]
    getCorporaWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeCorpus)
    getCorporaWithParentId' :: Int -> Cmd [Node HyperdataCorpus]
    getCorporaWithParentId' n = mkCmd $ \conn -> runQuery conn $ selectNodesWith' n (Just NodeCorpus)
    getListsWithParentId :: Int -> Cmd err [Node HyperdataList]
    getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
    getCorporaWithParentId :: Int -> Cmd err [Node HyperdataCorpus]
    getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
    ------------------------------------------------------------------------
    selectNodesWithParentID :: Int -> Query NodeRead
    ......@@ -363,13 +372,12 @@ selectNodesWithType type_id = proc () -> do
    type JSONB = QueryRunnerColumnDefault PGJsonb
    getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
    getNode conn id _ = do
    fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
    getNode :: JSONB a => Int -> proxy a -> Cmd err (Node a)
    getNode id _ = do
    fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgInt4 id))
    getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
    getNodesWithType conn type_id = do
    runQuery conn $ selectNodesWithType type_id
    getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
    getNodesWithType = runOpaQuery . selectNodesWithType
    ------------------------------------------------------------------------
    ......@@ -476,20 +484,19 @@ node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
    ,(pgStrictJSONB hp)
    )
    ------------------------------------------------------------------------
    insertNodesR' :: [NodeWrite'] -> Cmd [Int]
    insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
    insertNodes :: [NodeWrite'] -> Cmd err Int64
    insertNodes ns = mkCmd $ \conn ->
    runInsertMany conn nodeTable' (map node2row ns)
    insertNodes :: [NodeWrite'] -> Connection -> IO Int64
    insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
    insertNodesR :: [NodeWrite'] -> Cmd err [Int]
    insertNodesR ns = mkCmd $ \conn ->
    runInsert_ conn (Insert nodeTable' (node2row <$> ns) (rReturning (\(i,_,_,_,_,_,_) -> i)) Nothing)
    insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
    insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
    -------------------------
    insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
    insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
    insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Cmd err Int64
    insertNodesWithParent pid ns = insertNodes (set node_parentId pid <$> ns)
    insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
    insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
    insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Cmd err [Int]
    insertNodesWithParentR pid ns = insertNodesR (set node_parentId pid <$> ns)
    ------------------------------------------------------------------------
    -- TODO Hierachy of Nodes
    -- post and get same types Node' and update if changes
    ......@@ -529,14 +536,14 @@ type NodeWriteT = ( Maybe (Column PGInt4)
    , Column PGJsonb
    )
    mkNode' :: [NodeWrite] -> Cmd Int64
    mkNode' :: [NodeWrite] -> Cmd err Int64
    mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
    -- TODO: replace mkNodeR'
    mkNodeR'' :: [NodeWrite] -> Cmd [Int]
    mkNodeR'' :: [NodeWrite] -> Cmd err [Int]
    mkNodeR'' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
    mkNodeR' :: [NodeWriteT] -> Cmd [Int]
    mkNodeR' :: [NodeWriteT] -> Cmd err [Int]
    mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
    ------------------------------------------------------------------------
    ......@@ -545,7 +552,7 @@ data NewNode = NewNode { _newNodeId :: Int
    , _newNodeChildren :: [Int] }
    -- | postNode
    postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
    postNode :: 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
    ......@@ -571,72 +578,53 @@ childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a c
    mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
    mk c nt pId name = mk' c nt userId pId name
    mk :: NodeType -> Maybe ParentId -> Text -> Cmd err [Int]
    mk nt pId name = mk' nt userId pId name
    where
    userId = 1
    mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
    mk' c nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
    mk' :: NodeType -> UserId -> Maybe ParentId -> Text -> Cmd err [Int]
    mk' nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId]
    where
    hd = HyperdataUser . Just . pack $ show EN
    type Name = Text
    mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
    mk'' NodeUser Nothing uId name = mkCmd $ \c -> mk' c NodeUser uId Nothing name
    mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [Int]
    mk'' NodeUser Nothing uId name = mk' NodeUser uId Nothing name
    mk'' NodeUser _ _ _ = panic "NodeUser do not have any parent"
    mk'' _ Nothing _ _ = panic "NodeType does have a parent"
    mk'' nt pId uId name = mkCmd $ \c -> mk' c nt uId pId name
    mk'' nt pId uId name = mk' nt uId pId name
    mkRoot :: Username -> UserId -> Cmd [Int]
    mkRoot :: Username -> UserId -> Cmd err [Int]
    mkRoot uname uId = case uId > 0 of
    False -> panic "UserId <= 0"
    True -> mk'' NodeUser Nothing uId uname
    mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
    mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
    mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [Int]
    mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]
    --{-
    getOrMkList :: ParentId -> UserId -> Cmd Int
    getOrMkList pId uId = do
    maybeList <- defaultListSafe' pId
    case maybeList of
    Nothing -> maybe (panic "no list") identity <$> headMay <$> mkList pId uId
    Just x -> pure x
    defaultListSafe' :: CorpusId -> Cmd (Maybe ListId)
    defaultListSafe' cId = mkCmd $ \c -> do
    maybeNode <- headMay <$> getListsWithParentId c cId
    case maybeNode of
    Nothing -> pure Nothing
    (Just node) -> pure $ Just $ _node_id node
    --}
    getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err Int
    getOrMkList pId uId =
    defaultList pId
    `catchNodeError`
    (\NoListFound -> maybe (nodeError NoListFound) pure . headMay =<< mkList pId uId)
    defaultListSafe :: Connection -> CorpusId -> IO (Maybe ListId)
    defaultListSafe c cId = do
    maybeNode <- headMay <$> getListsWithParentId c cId
    case maybeNode of
    Nothing -> pure Nothing
    (Just node) -> pure $ Just $ _node_id node
    defaultList :: Connection -> CorpusId -> IO ListId
    defaultList c cId = maybe (panic errMessage) identity <$> defaultListSafe c cId
    where
    errMessage = "Gargantext.API.Ngrams.defaultList: no list found"
    defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
    defaultList cId =
    maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
    mkList :: ParentId -> UserId -> Cmd [Int]
    mkList p u = insertNodesR' [nodeListW Nothing Nothing p u]
    mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [Int]
    mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
    mkGraph :: ParentId -> UserId -> Cmd [Int]
    mkGraph p u = insertNodesR' [nodeGraphW Nothing Nothing p u]
    mkGraph :: ParentId -> UserId -> Cmd err [Int]
    mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
    mkDashboard :: ParentId -> UserId -> Cmd [Int]
    mkDashboard p u = insertNodesR' [nodeDashboardW Nothing Nothing p u]
    mkDashboard :: ParentId -> UserId -> Cmd err [Int]
    mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
    mkAnnuaire :: ParentId -> UserId -> Cmd [Int]
    mkAnnuaire p u = insertNodesR' [nodeAnnuaireW Nothing Nothing p u]
    mkAnnuaire :: ParentId -> UserId -> Cmd err [Int]
    mkAnnuaire p u = insertNodesR [nodeAnnuaireW Nothing Nothing p u]
    -- | Default CorpusId Master and ListId Master
    src/Gargantext/Database/Schema/NodeNgram.hs
    View file @ b13b85bf
    ......@@ -23,6 +23,7 @@ if Node is a List then it is listing (either Stop, Candidate or Map)
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    ......@@ -35,10 +36,10 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    import Gargantext.Core.Types.Main (ListId, ListTypeId)
    import Gargantext.Database.Utils (mkCmd, Cmd(..))
    import Gargantext.Database.Utils (mkCmd, Cmd, runPGSQuery)
    import Gargantext.Prelude
    import Opaleye
    import qualified Database.PostgreSQL.Simple as PGS (Connection, query, Only(..))
    import qualified Database.PostgreSQL.Simple as PGS (Only(..))
    -- | TODO : remove id
    data NodeNgramPoly id node_id ngram_id weight ngrams_type
    ......@@ -94,14 +95,14 @@ nodeNgramTable = Table "nodes_ngrams"
    queryNodeNgramTable :: Query NodeNgramRead
    queryNodeNgramTable = queryTable nodeNgramTable
    insertNodeNgrams :: [NodeNgram] -> Cmd Int
    insertNodeNgrams :: [NodeNgram] -> Cmd err Int
    insertNodeNgrams = insertNodeNgramW
    . map (\(NodeNgram _ n g w t) ->
    NodeNgram Nothing (pgInt4 n) (pgInt4 g)
    (pgDouble w) (pgInt4 t)
    )
    insertNodeNgramW :: [NodeNgramWrite] -> Cmd Int
    insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
    insertNodeNgramW nns =
    mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
    where
    ......@@ -113,8 +114,8 @@ insertNodeNgramW nns =
    type NgramsText = Text
    updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsText, ListTypeId)] -> IO [PGS.Only Int]
    updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ input)
    updateNodeNgrams :: [(ListId, NgramsText, ListTypeId)] -> Cmd err [PGS.Only Int]
    updateNodeNgrams input = runPGSQuery updateQuery (PGS.Only $ Values fields $ input)
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
    updateQuery = [sql| UPDATE nodes_ngrams as old SET
    ......
    src/Gargantext/Database/Schema/NodeNgramsNgrams.hs
    View file @ b13b85bf
    ......@@ -25,22 +25,25 @@ Next Step benchmark:
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-}
    module Gargantext.Database.Schema.NodeNgramsNgrams
    where
    import Control.Lens (view)
    import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Control.Monad.IO.Class (liftIO)
    import Data.Text (Text)
    import Data.Maybe (Maybe)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import Gargantext.Database.Utils (mkCmd, Cmd(..))
    import Gargantext.Database.Utils (Cmd, runOpaQuery, runPGSQuery, connection)
    import Gargantext.Prelude
    import Opaleye
    import qualified Database.PostgreSQL.Simple as DPS
    import qualified Database.PostgreSQL.Simple as PGS
    data NodeNgramsNgramsPoly node_id ngram1_id ngram2_id weight =
    NodeNgramsNgrams { _nng_NodeId :: node_id
    ......@@ -90,8 +93,8 @@ queryNodeNgramsNgramsTable = queryTable nodeNgramsNgramsTable
    -- | Select NodeNgramsNgrams
    -- TODO not optimized (get all ngrams without filters)
    nodeNgramsNgrams :: DPS.Connection -> IO [NodeNgramsNgrams]
    nodeNgramsNgrams conn = runQuery conn queryNodeNgramsNgramsTable
    nodeNgramsNgrams :: Cmd err [NodeNgramsNgrams]
    nodeNgramsNgrams = runOpaQuery queryNodeNgramsNgramsTable
    instance QueryRunnerColumnDefault PGInt4 (Maybe Int) where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    ......@@ -101,7 +104,7 @@ instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
    -- TODO: Add option on conflict
    insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd Int
    insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd err Int
    insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
    . map (\(NodeNgramsNgrams n ng1 ng2 maybeWeight) ->
    NodeNgramsNgrams (pgInt4 n )
    ......@@ -110,10 +113,10 @@ insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
    (pgDouble <$> maybeWeight)
    )
    insertNodeNgramsNgramsW :: [NodeNgramsNgramsWrite] -> Cmd Int
    insertNodeNgramsNgramsW ns =
    mkCmd $ \c -> fromIntegral
    <$> runInsertMany c nodeNgramsNgramsTable ns
    insertNodeNgramsNgramsW :: [NodeNgramsNgramsWrite] -> Cmd err Int
    insertNodeNgramsNgramsW ns = do
    c <- view connection
    liftIO $ fromIntegral <$> runInsertMany c nodeNgramsNgramsTable ns
    ------------------------------------------------------------------------
    data Action = Del | Add
    ......@@ -121,20 +124,17 @@ data Action = Del | Add
    type NgramsParent = Text
    type NgramsChild = Text
    ngramsGroup :: Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> Cmd [Int]
    ngramsGroup a ngs = mkCmd $ \c -> ngramsGroup' c a ngs
    -- TODO: remove this function (use Reader Monad only)
    ngramsGroup' :: DPS.Connection -> Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> IO [Int]
    ngramsGroup' c action ngs = runNodeNgramsNgrams c q ngs
    ngramsGroup' :: Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)]
    -> Cmd err [Int]
    ngramsGroup' action ngs = runNodeNgramsNgrams q ngs
    where
    q = case action of
    Del -> queryDelNodeNgramsNgrams
    Add -> queryInsertNodeNgramsNgrams
    runNodeNgramsNgrams :: DPS.Connection -> DPS.Query -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> IO [Int]
    runNodeNgramsNgrams c q ngs = map (\(DPS.Only a) -> a) <$> DPS.query c q (DPS.Only $ Values fields ngs' )
    runNodeNgramsNgrams :: PGS.Query -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> Cmd err [Int]
    runNodeNgramsNgrams q ngs = map (\(PGS.Only a) -> a) <$> runPGSQuery q (PGS.Only $ Values fields ngs' )
    where
    ngs' = map (\(n,ng1,ng2,w) -> (n,ng1,ng2,maybe 0 identity w)) ngs
    fields = map (\t -> QualifiedIdentifier Nothing t)
    ......@@ -142,7 +142,7 @@ runNodeNgramsNgrams c q ngs = map (\(DPS.Only a) -> a) <$> DPS.query c q (DPS.On
    --------------------------------------------------------------------
    -- TODO: on conflict update weight
    queryInsertNodeNgramsNgrams :: DPS.Query
    queryInsertNodeNgramsNgrams :: PGS.Query
    queryInsertNodeNgramsNgrams = [sql|
    WITH input_rows(nId,ng1,ng2,w) AS (?)
    INSERT INTO nodes_ngrams_ngrams (node_id,ngram1_id,ngram2_id,weight)
    ......@@ -152,7 +152,7 @@ queryInsertNodeNgramsNgrams = [sql|
    ON CONFLICT (node_id,ngram1_id,ngram2_id) DO NOTHING -- unique index created here
    |]
    queryDelNodeNgramsNgrams :: DPS.Query
    queryDelNodeNgramsNgrams :: PGS.Query
    queryDelNodeNgramsNgrams = [sql|
    WITH input(nId,ng1,ng2,w) AS (?)
    DELETE FROM nodes_ngrams_ngrams nnn
    ......
    src/Gargantext/Database/Schema/NodeNode.hs
    View file @ b13b85bf
    ......@@ -20,11 +20,12 @@ commentary with @some markup@.
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.Database.Schema.NodeNode where
    import qualified Database.PostgreSQL.Simple as PGS (Connection, Query, query, Only(..))
    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)
    ......@@ -82,8 +83,8 @@ queryNodeNodeTable = queryTable nodeNodeTable
    -- | not optimized (get all ngrams without filters)
    nodesNodes :: Cmd [NodeNode]
    nodesNodes = mkCmd $ \c -> runQuery c queryNodeNodeTable
    nodesNodes :: Cmd err [NodeNode]
    nodesNodes = runOpaQuery queryNodeNodeTable
    instance QueryRunnerColumnDefault (Nullable PGInt4) Int where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    ......@@ -97,8 +98,8 @@ instance QueryRunnerColumnDefault PGBool (Maybe Bool) where
    ------------------------------------------------------------------------
    -- | Favorite management
    nodeToFavorite :: PGS.Connection -> CorpusId -> DocId -> Bool -> IO [Int]
    nodeToFavorite c cId dId b = map (\(PGS.Only a) -> a) <$> PGS.query c favQuery (b,cId,dId)
    nodeToFavorite :: CorpusId -> DocId -> Bool -> Cmd err [Int]
    nodeToFavorite cId dId b = map (\(PGS.Only a) -> a) <$> runPGSQuery favQuery (b,cId,dId)
    where
    favQuery :: PGS.Query
    favQuery = [sql|UPDATE nodes_nodes SET favorite = ?
    ......@@ -106,9 +107,9 @@ nodeToFavorite c cId dId b = map (\(PGS.Only a) -> a) <$> PGS.query c favQuery (
    RETURNING node2_id;
    |]
    nodesToFavorite :: PGS.Connection -> [(CorpusId,DocId,Bool)] -> IO [Int]
    nodesToFavorite c inputData = map (\(PGS.Only a) -> a)
    <$> PGS.query c trashQuery (PGS.Only $ Values fields inputData)
    nodesToFavorite :: [(CorpusId,DocId,Bool)] -> Cmd err [Int]
    nodesToFavorite inputData = map (\(PGS.Only a) -> a)
    <$> runPGSQuery trashQuery (PGS.Only $ Values fields inputData)
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
    trashQuery :: PGS.Query
    ......@@ -123,8 +124,8 @@ nodesToFavorite c inputData = map (\(PGS.Only a) -> a)
    ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    -- | Trash management
    nodeToTrash :: PGS.Connection -> CorpusId -> DocId -> Bool -> IO [PGS.Only Int]
    nodeToTrash c cId dId b = PGS.query c trashQuery (b,cId,dId)
    nodeToTrash :: CorpusId -> DocId -> Bool -> Cmd err [PGS.Only Int]
    nodeToTrash cId dId b = runPGSQuery trashQuery (b,cId,dId)
    where
    trashQuery :: PGS.Query
    trashQuery = [sql|UPDATE nodes_nodes SET delete = ?
    ......@@ -133,9 +134,9 @@ nodeToTrash c cId dId b = PGS.query c trashQuery (b,cId,dId)
    |]
    -- | Trash Massive
    nodesToTrash :: PGS.Connection -> [(CorpusId,DocId,Bool)] -> IO [Int]
    nodesToTrash c input = map (\(PGS.Only a) -> a)
    <$> PGS.query c trashQuery (PGS.Only $ Values fields input)
    nodesToTrash :: [(CorpusId,DocId,Bool)] -> Cmd err [Int]
    nodesToTrash input = map (\(PGS.Only a) -> a)
    <$> runPGSQuery trashQuery (PGS.Only $ Values fields input)
    where
    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
    trashQuery :: PGS.Query
    ......@@ -148,8 +149,8 @@ nodesToTrash c input = map (\(PGS.Only a) -> a)
    |]
    -- | /!\ Really remove nodes in the Corpus or Annuaire
    emptyTrash :: PGS.Connection -> CorpusId -> IO [PGS.Only Int]
    emptyTrash c cId = PGS.query c delQuery (PGS.Only cId)
    emptyTrash :: CorpusId -> Cmd err [PGS.Only Int]
    emptyTrash cId = runPGSQuery delQuery (PGS.Only cId)
    where
    delQuery :: PGS.Query
    delQuery = [sql|DELETE from nodes_nodes n
    ......
    src/Gargantext/Database/Schema/NodeNodeNgram.hs
    View file @ b13b85bf
    ......@@ -24,7 +24,7 @@ import Prelude
    import Data.Maybe (Maybe)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import qualified Database.PostgreSQL.Simple as PGS
    import Gargantext.Database.Utils (Cmd, runOpaQuery)
    import Opaleye
    ......@@ -76,8 +76,8 @@ queryNodeNodeNgramTable :: Query NodeNodeNgramRead
    queryNodeNodeNgramTable = queryTable nodeNodeNgramTable
    -- | not optimized (get all ngrams without filters)
    nodeNodeNgrams :: PGS.Connection -> IO [NodeNodeNgram]
    nodeNodeNgrams conn = runQuery conn queryNodeNodeNgramTable
    nodeNodeNgrams :: Cmd err [NodeNodeNgram]
    nodeNodeNgrams = runOpaQuery queryNodeNodeNgramTable
    instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    src/Gargantext/Database/Schema/User.hs
    View file @ b13b85bf
    ......@@ -20,6 +20,7 @@ Functions to deal with users, database side.
    {-# LANGUAGE Arrows #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Schema.User where
    ......@@ -156,15 +157,14 @@ instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    users :: Cmd [User]
    users = mkCmd $ \conn -> runQuery conn queryUserTable
    users :: Cmd err [User]
    users = runOpaQuery queryUserTable
    usersLight :: Cmd [UserLight]
    usersLight = mkCmd $ \conn -> map toUserLight <$> runQuery conn queryUserTable
    usersLight :: Cmd err [UserLight]
    usersLight = map toUserLight <$> users
    getUser :: Username -> Cmd (Maybe UserLight)
    getUser u = mkCmd $ \c -> userLightWithUsername u <$> runCmd c usersLight
    getUser :: Username -> Cmd err (Maybe UserLight)
    getUser u = userLightWithUsername u <$> usersLight
    src/Gargantext/Database/TextSearch.hs
    View file @ b13b85bf
    ......@@ -11,6 +11,7 @@ Portability : POSIX
    {-# LANGUAGE Arrows #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.TextSearch where
    ......@@ -21,7 +22,7 @@ import Data.List (intersperse, take, drop)
    import Data.String (IsString(..))
    import Data.Text (Text, words, unpack, intercalate)
    import Data.Time (UTCTime)
    import Database.PostgreSQL.Simple -- (Query, Connection)
    import Database.PostgreSQL.Simple (Query)
    import Database.PostgreSQL.Simple.ToField
    import Gargantext.Database.Config (nodeTypeId)
    import Gargantext.Database.Types.Node (NodeType(..))
    ......@@ -33,6 +34,7 @@ import Gargantext.Database.Schema.Ngrams
    import Gargantext.Database.Schema.NodeNode
    import Gargantext.Database.Schema.NodeNgram
    import Gargantext.Database.Queries.Join (leftJoin6)
    import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery)
    import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
    import Gargantext.Core.Types
    import Control.Arrow (returnA)
    ......@@ -41,8 +43,8 @@ import Opaleye hiding (Query, Order)
    ------------------------------------------------------------------------
    searchInDatabase :: Connection -> ParentId -> Text -> IO [(NodeId, HyperdataDocument)]
    searchInDatabase c p t = runQuery c (queryInDatabase p t)
    searchInDatabase :: ParentId -> Text -> Cmd err [(NodeId, HyperdataDocument)]
    searchInDatabase p t = runOpaQuery (queryInDatabase p t)
    -- | Global search query where ParentId is Master Node Corpus Id
    queryInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
    ......@@ -54,8 +56,8 @@ queryInDatabase _ q = proc () -> do
    ------------------------------------------------------------------------
    -- | todo add limit and offset and order
    searchInCorpus :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
    searchInCorpus c cId q o l order = runQuery c (filterWith o l order $ queryInCorpus cId q')
    searchInCorpus :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
    searchInCorpus cId q o l order = runOpaQuery (filterWith o l order $ queryInCorpus cId q')
    where
    q' = intercalate " | " $ map stemIt q
    ......@@ -77,20 +79,20 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
    type AuthorName = Text
    -- | TODO Optim: Offset and Limit in the Query
    searchInCorpusWithContacts :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
    searchInCorpusWithContacts c cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
    searchInCorpusWithContacts :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
    searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
    <$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
    <$> toList <$> fromListWith (<>)
    <$> map (\(FacetPaired i u h s p) -> ((i,u,h,s), [maybePair p]))
    <$> searchInCorpusWithContacts' c cId q o l order
    <$> searchInCorpusWithContacts' cId q o l order
    where
    maybePair (Pair Nothing Nothing) = Nothing
    maybePair (Pair _ Nothing) = Nothing
    maybePair (Pair Nothing _) = Nothing
    maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
    searchInCorpusWithContacts' :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
    searchInCorpusWithContacts' c cId q o l order = runQuery c $ queryInCorpusWithContacts cId q' o l order
    searchInCorpusWithContacts' :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
    searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
    where
    q' = intercalate " | " $ map stemIt q
    ......@@ -196,13 +198,12 @@ textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \
    -- | Text Search Function for Master Corpus
    -- TODO : text search for user corpus
    -- Example:
    -- textSearchTest :: ParentId -> TSQuery -> Cmd [(Int, Value, Value, Value, Value, Maybe Int)]
    -- textSearchTest pId q = mkCmd $ \c -> textSearch c q pId 5 0 Asc
    textSearch :: Connection
    -> TSQuery -> ParentId
    -- textSearchTest :: ParentId -> TSQuery -> Cmd err [(Int, Value, Value, Value, Value, Maybe Int)]
    -- textSearchTest pId q = textSearch q pId 5 0 Asc
    textSearch :: TSQuery -> ParentId
    -> Limit -> Offset -> Order
    -> IO [(Int,Value,Value,Value, Value, Maybe Int)]
    textSearch conn q p l o ord = query conn textSearchQuery (q,p,p,typeId,ord,o,l)
    -> Cmd err [(Int,Value,Value,Value, Value, Maybe Int)]
    textSearch q p l o ord = runPGSQuery textSearchQuery (q,p,p,typeId,ord,o,l)
    where
    typeId = nodeTypeId NodeDocument
    ......
    src/Gargantext/Database/Tree.hs
    View file @ b13b85bf
    ......@@ -13,13 +13,13 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
    import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
    import Control.Monad.Error.Class (MonadError(throwError))
    import Control.Monad.IO.Class (MonadIO(liftIO))
    import Data.Map (Map, fromListWith, lookup)
    import Data.Text (Text)
    import Database.PostgreSQL.Simple
    ......@@ -28,11 +28,11 @@ import Database.PostgreSQL.Simple.SqlQQ
    import Gargantext.Prelude
    import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
    import Gargantext.Database.Config (fromNodeTypeId)
    import Gargantext.Database.Utils (Cmd, runPGSQuery)
    ------------------------------------------------------------------------
    -- import Gargantext (connectGargandb)
    -- import Control.Monad ((>>=))
    -- import Gargantext.Database.Utils (runCmdDev)
    -- treeTest :: IO (Tree NodeTree)
    -- treeTest = connectGargandb "gargantext.ini" >>= \c -> treeDB c 347474
    -- treeTest = runCmdDev $ treeDB 347474
    ------------------------------------------------------------------------
    data TreeError = NoRoot | EmptyRoot | TooManyRoots
    ......@@ -45,9 +45,8 @@ treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
    treeError te = throwError $ _TreeError # te
    -- | Returns the Tree of Nodes in Database
    treeDB :: (MonadIO m, MonadError e m, HasTreeError e)
    => Connection -> RootId -> m (Tree NodeTree)
    treeDB c r = toTree =<< (toTreeParent <$> liftIO (dbTree c r))
    treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
    treeDB r = toTree =<< (toTreeParent <$> dbTree r)
    type RootId = Int
    type ParentId = Int
    ......@@ -83,8 +82,8 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: Int
    -- | Main DB Tree function
    -- TODO add typenames as parameters
    dbTree :: Connection -> RootId -> IO [DbTreeNode]
    dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> query conn [sql|
    dbTree :: RootId -> Cmd err [DbTreeNode]
    dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
    WITH RECURSIVE
    -- starting node(s)
    starting (id, typename, parent_id, name) AS
    ......
    src/Gargantext/Database/Utils.hs
    View file @ b13b85bf
    ......@@ -11,15 +11,18 @@ Here is a longer description of this module, containing some
    commentary with @some markup@.
    -}
    {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Utils where
    import Control.Applicative (Applicative)
    import Control.Lens (Getter, view)
    import Control.Monad.Reader
    import Control.Monad.Except
    import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
    import Data.Either.Extra (Either(Left, Right))
    import Data.Ini (readIniFile, lookupValue)
    ......@@ -33,36 +36,54 @@ import Database.PostgreSQL.Simple (Connection, connect)
    import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
    import Database.PostgreSQL.Simple.Internal (Field)
    import Gargantext.Prelude
    import Opaleye (Query, Unpackspec, showSqlForPostgres)
    import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
    import System.IO (FilePath)
    import Text.Read (read)
    import qualified Data.ByteString as DB
    import qualified Database.PostgreSQL.Simple as PGS
    ------------------------------------------------------------------------
    {- | Reader Monad reinvented here:
    class HasConnection env where
    connection :: Getter env Connection
    newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
    instance HasConnection Connection where
    connection = identity
    instance Monad Cmd where
    return a = Cmd $ \_ -> return a
    type CmdM env err m =
    ( MonadReader env m
    , HasConnection env
    , MonadError err m
    , MonadIO m
    )
    m >>= f = Cmd $ \c -> do
    a <- unCmd m c
    unCmd (f a) c
    -}
    type Cmd err a = forall m env. CmdM env err m => m a
    -- TODO: ideally there should be very few calls to this functions.
    mkCmd :: (Connection -> IO a) -> Cmd err a
    mkCmd k = do
    conn <- view connection
    liftIO $ k conn
    runCmd :: Connection -> Cmd err a -> IO (Either err a)
    runCmd conn m = runExceptT $ runReaderT m conn
    --type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
    -- Use only for dev
    runCmdDev :: Show err => Cmd err a -> IO a
    runCmdDev f = do
    conn <- connectGargandb "gargantext.ini"
    either (fail . show) pure =<< runCmd conn f
    newtype Cmd a = Cmd (ReaderT Connection IO a)
    deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
    -- Use only for dev
    runCmdDevNoErr :: Cmd () a -> IO a
    runCmdDevNoErr = runCmdDev
    runCmd :: Connection -> Cmd a -> IO a
    runCmd c (Cmd f) = runReaderT f c
    runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
    runOpaQuery q = mkCmd $ \c -> runQuery c q
    mkCmd :: (Connection -> IO a) -> Cmd a
    mkCmd = Cmd . ReaderT
    formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
    formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
    runPGSQuery :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
    runPGSQuery q a = mkCmd $ \conn -> PGS.query conn q a
    ------------------------------------------------------------------------
    databaseParameters :: FilePath -> IO PGS.ConnectInfo
    ......
    src/Gargantext/Text/Flow.hs
    View file @ b13b85bf
    ......@@ -17,6 +17,7 @@ From text to viz, all the flow of texts in Gargantext.
    module Gargantext.Text.Flow
    where
    import Control.Monad.Reader
    import GHC.IO (FilePath)
    import qualified Data.Text as T
    import Data.Text.IO (readFile)
    ......@@ -27,7 +28,7 @@ import qualified Data.Set as DS
    import qualified Data.Array.Accelerate as A
    import qualified Data.Map.Strict as M
    ----------------------------------------------
    import Gargantext.Database (Connection)
    import Database.PostgreSQL.Simple (Connection)
    import Gargantext.Database.Schema.Node
    import Gargantext.Database.Types.Node
    ......@@ -86,7 +87,7 @@ textFlow termType workType = do
    FullText path -> splitBy (Sentences 5) <$> readFile path
    CSV path -> readCsvOn [csv_title, csv_abstract] path
    Contexts ctxt -> pure ctxt
    DBV3 con corpusId -> catMaybes <$> map (\n -> hyperdataDocumentV3_title (_node_hyperdata n) <> hyperdataDocumentV3_abstract (_node_hyperdata n))<$> getDocumentsV3WithParentId con corpusId
    DBV3 con corpusId -> catMaybes <$> map (\n -> hyperdataDocumentV3_title (_node_hyperdata n) <> hyperdataDocumentV3_abstract (_node_hyperdata n))<$> runReaderT (getDocumentsV3WithParentId corpusId) con
    _ -> undefined -- TODO Query not supported
    textFlow' termType contexts
    ......
    src/Gargantext/Viz/Graph.hs
    View file @ b13b85bf
    ......@@ -18,6 +18,7 @@ module Gargantext.Viz.Graph
    ------------------------------------------------------------------------
    import Control.Lens (makeLenses)
    import Control.Monad.IO.Class (MonadIO(liftIO))
    import GHC.IO (FilePath)
    import GHC.Generics (Generic)
    import Data.Aeson.TH (deriveJSON)
    ......@@ -207,7 +208,7 @@ graphV3ToGraphWithFiles g1 g2 = do
    DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
    readGraphFromJson :: FilePath -> IO (Maybe Graph)
    readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
    readGraphFromJson fp = do
    graph <- DBL.readFile fp
    graph <- liftIO $ DBL.readFile fp
    pure $ DA.decode graph
    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