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
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