diff --git a/src/Gargantext/API.hs b/src/Gargantext/API.hs
index 0f939f59a9752fff57a8876e15b67bf2d3d540c9..7764535cedfd1bb61e2e79f8417c656d9665afc3 100644
--- a/src/Gargantext/API.hs
+++ b/src/Gargantext/API.hs
@@ -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"))
diff --git a/src/Gargantext/API/Auth.hs b/src/Gargantext/API/Auth.hs
index 46d8306d465b87a938d2f1b8c2da070d43e81b94..a720d2f2bae09f1cdbed89c80ce215f24d3337fc 100644
--- a/src/Gargantext/API/Auth.hs
+++ b/src/Gargantext/API/Auth.hs
@@ -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")
diff --git a/src/Gargantext/API/Count.hs b/src/Gargantext/API/Count.hs
index cca261095a9201027f8530dca78afaa8d630e273..3fddf7f2bb7e165ba0f5f9c54d03f0f62f89b585 100644
--- a/src/Gargantext/API/Count.hs
+++ b/src/Gargantext/API/Count.hs
@@ -146,5 +146,5 @@ instance ToSchema Count
-- arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
-----------------------------------------------------------------------
-count :: Query -> Handler Counts
+count :: Monad m => Query -> m Counts
count _ = undefined
diff --git a/src/Gargantext/API/Ngrams.hs b/src/Gargantext/API/Ngrams.hs
index fdd31af68ae777efe521c667a5d9d4edc1d6fafb..b53301fff2f7e033d35196d9a6661b4ed98cf3e7 100644
--- a/src/Gargantext/API/Ngrams.hs
+++ b/src/Gargantext/API/Ngrams.hs
@@ -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
diff --git a/src/Gargantext/API/Node.hs b/src/Gargantext/API/Node.hs
index e0f80cde0f6e889cb7e2f521b7cfc882b1169eee..c5713e174509445eea86bbf9aa08bc017d983a67 100644
--- a/src/Gargantext/API/Node.hs
+++ b/src/Gargantext/API/Node.hs
@@ -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
diff --git a/src/Gargantext/API/Search.hs b/src/Gargantext/API/Search.hs
index f7ab709cd74712042749a1f046e0c9905a1d5a0e..0e2d76906aca69f54847d15b23ea9fced8660dae 100644
--- a/src/Gargantext/API/Search.hs
+++ b/src/Gargantext/API/Search.hs
@@ -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
diff --git a/src/Gargantext/API/Settings.hs b/src/Gargantext/API/Settings.hs
index e49c367cb8ae6e80de829634decc283f6dd943b7..8ee03b14f3fdb8eb5538cc7730983c4ec94ad392 100644
--- a/src/Gargantext/API/Settings.hs
+++ b/src/Gargantext/API/Settings.hs
@@ -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
}
diff --git a/src/Gargantext/Database.hs b/src/Gargantext/Database.hs
index 02b7e6367d10d8a3180348a656ae063e83eff1f4..4a7cd1ddf7e6b7dbbb090f42d4f1bc7d035634dd 100644
--- a/src/Gargantext/Database.hs
+++ b/src/Gargantext/Database.hs
@@ -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)
-
-
diff --git a/src/Gargantext/Database/Bashql.hs b/src/Gargantext/Database/Bashql.hs
index a284d470efa1f0099e76bb381c6720fc5f410480..7df8693871a56ccd871eff3e890e0b0c9824d233 100644
--- a/src/Gargantext/Database/Bashql.hs
+++ b/src/Gargantext/Database/Bashql.hs
@@ -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
diff --git a/src/Gargantext/Database/Cooc.hs b/src/Gargantext/Database/Cooc.hs
index 74d0fee52a5ed56613d065ce26628bca6d621eef..f8d77e7777211495ab5e0db1138ef407f13da770 100644
--- a/src/Gargantext/Database/Cooc.hs
+++ b/src/Gargantext/Database/Cooc.hs
@@ -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
diff --git a/src/Gargantext/Database/Facet.hs b/src/Gargantext/Database/Facet.hs
index 3882401c045d0ccd369d8ef7a16ac5613547bb52..1c2dbca798e5838dd79ff849b14fe27553cb91e7 100644
--- a/src/Gargantext/Database/Facet.hs
+++ b/src/Gargantext/Database/Facet.hs
@@ -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
diff --git a/src/Gargantext/Database/Flow.hs b/src/Gargantext/Database/Flow.hs
index f553cfd813f6187cce35dcb04f6dbea82d1812fd..8f84d5e72d6d52ee63218b7644ce61c690ffc804 100644
--- a/src/Gargantext/Database/Flow.hs
+++ b/src/Gargantext/Database/Flow.hs
@@ -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
diff --git a/src/Gargantext/Database/Flow/Pairing.hs b/src/Gargantext/Database/Flow/Pairing.hs
index dd47ec23248a0c1b89db5f47fff1ff197df3ddc5..aa71683b15b29d71c266624378a0a4630a09662a 100644
--- a/src/Gargantext/Database/Flow/Pairing.hs
+++ b/src/Gargantext/Database/Flow/Pairing.hs
@@ -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
diff --git a/src/Gargantext/Database/Flow/Utils.hs b/src/Gargantext/Database/Flow/Utils.hs
index e6442342c3bc0d518b495845b8f6f7998c245b22..1cd185db4abab1c879bb80ad40d157829478d37e 100644
--- a/src/Gargantext/Database/Flow/Utils.hs
+++ b/src/Gargantext/Database/Flow/Utils.hs
@@ -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
]
diff --git a/src/Gargantext/Database/Node/Children.hs b/src/Gargantext/Database/Node/Children.hs
index 71c70f6cb3004935353e735bd1c89d0f3d60ac60..476656d8b35fa852dbefd08d41085f47138cad9a 100644
--- a/src/Gargantext/Database/Node/Children.hs
+++ b/src/Gargantext/Database/Node/Children.hs
@@ -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
diff --git a/src/Gargantext/Database/Node/Document/Add.hs b/src/Gargantext/Database/Node/Document/Add.hs
index 819f2cbc04f9858bccf83f850ae6d9c29b5d87f7..c067b47759302de56d465e04eead38a8ef184510 100644
--- a/src/Gargantext/Database/Node/Document/Add.hs
+++ b/src/Gargantext/Database/Node/Document/Add.hs
@@ -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
diff --git a/src/Gargantext/Database/Node/Document/Insert.hs b/src/Gargantext/Database/Node/Document/Insert.hs
index 4e84abe3002180acbef48ce3b7b4a06005892a09..d4498290effcc7ca90b68578c3a8b07220ac8e62 100644
--- a/src/Gargantext/Database/Node/Document/Insert.hs
+++ b/src/Gargantext/Database/Node/Document/Insert.hs
@@ -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
diff --git a/src/Gargantext/Database/Node/Update.hs b/src/Gargantext/Database/Node/Update.hs
index ecf2df2f7a8360c4c066ac85d3a97e98d1f5a59c..d30b5f2d21778e41c891e804787e41c7a2731025 100644
--- a/src/Gargantext/Database/Node/Update.hs
+++ b/src/Gargantext/Database/Node/Update.hs
@@ -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)
diff --git a/src/Gargantext/Database/Root.hs b/src/Gargantext/Database/Root.hs
index 22715ed7a72afcb5963a63ae189ec0d937b5cd5b..e997bdf1f79fcc779726c74ffeef302c77fdb65d 100644
--- a/src/Gargantext/Database/Root.hs
+++ b/src/Gargantext/Database/Root.hs
@@ -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
diff --git a/src/Gargantext/Database/Schema/Ngrams.hs b/src/Gargantext/Database/Schema/Ngrams.hs
index a1071b345350f8b0e9f5e2eca05678b42213165f..d678cae6698afd6be9d1d5ae1c983a185d806a9e 100644
--- a/src/Gargantext/Database/Schema/Ngrams.hs
+++ b/src/Gargantext/Database/Schema/Ngrams.hs
@@ -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
diff --git a/src/Gargantext/Database/Schema/Node.hs b/src/Gargantext/Database/Schema/Node.hs
index ce66e54d6b60e7a27da218fdcabfc7f004fb6af6..f3315223ae41709288765328712ef0136d6c5185 100644
--- a/src/Gargantext/Database/Schema/Node.hs
+++ b/src/Gargantext/Database/Schema/Node.hs
@@ -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
diff --git a/src/Gargantext/Database/Schema/NodeNgram.hs b/src/Gargantext/Database/Schema/NodeNgram.hs
index 0beaf5e2c9f0d0d4d8880d1f111c1c38d4e3b0eb..84a337803ac0ad38ad867f88b4153039bdf728f5 100644
--- a/src/Gargantext/Database/Schema/NodeNgram.hs
+++ b/src/Gargantext/Database/Schema/NodeNgram.hs
@@ -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
diff --git a/src/Gargantext/Database/Schema/NodeNgramsNgrams.hs b/src/Gargantext/Database/Schema/NodeNgramsNgrams.hs
index 305841d53a3543686c63ad17e60d32945e439432..285d007bef532c10cf14f23e193cb3cb45dd4aca 100644
--- a/src/Gargantext/Database/Schema/NodeNgramsNgrams.hs
+++ b/src/Gargantext/Database/Schema/NodeNgramsNgrams.hs
@@ -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
diff --git a/src/Gargantext/Database/Schema/NodeNode.hs b/src/Gargantext/Database/Schema/NodeNode.hs
index c905c3b341213ad6b85b574ebe32d891c30a641f..72fdc43443d2014bacdfe9892f0824cf24831596 100644
--- a/src/Gargantext/Database/Schema/NodeNode.hs
+++ b/src/Gargantext/Database/Schema/NodeNode.hs
@@ -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
diff --git a/src/Gargantext/Database/Schema/NodeNodeNgram.hs b/src/Gargantext/Database/Schema/NodeNodeNgram.hs
index 9f58043a6c4f6423250bb4c4710a2b4571b7ab3d..23ff6af502392bf800d8240441ce8029772365f7 100644
--- a/src/Gargantext/Database/Schema/NodeNodeNgram.hs
+++ b/src/Gargantext/Database/Schema/NodeNodeNgram.hs
@@ -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
diff --git a/src/Gargantext/Database/Schema/User.hs b/src/Gargantext/Database/Schema/User.hs
index 0cff318b46ebe8a475c3ab15efa4985572764809..a642ca9008a8eee53bfcd7b917cc76819cab5d06 100644
--- a/src/Gargantext/Database/Schema/User.hs
+++ b/src/Gargantext/Database/Schema/User.hs
@@ -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
diff --git a/src/Gargantext/Database/TextSearch.hs b/src/Gargantext/Database/TextSearch.hs
index 7bff15ea758dcefb771e12334fd8738524feec6f..c3b9d06f242d485c10db277d5865e0c40dd987b1 100644
--- a/src/Gargantext/Database/TextSearch.hs
+++ b/src/Gargantext/Database/TextSearch.hs
@@ -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
diff --git a/src/Gargantext/Database/Tree.hs b/src/Gargantext/Database/Tree.hs
index 0e605043ff8d2bf4c2a740522ee407dae7b6381f..fe97dc8b20d03cd24499b7b3c26597a3fd175fa7 100644
--- a/src/Gargantext/Database/Tree.hs
+++ b/src/Gargantext/Database/Tree.hs
@@ -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
diff --git a/src/Gargantext/Database/Utils.hs b/src/Gargantext/Database/Utils.hs
index 71b554e5c941d81d0968d341105131a99382f1f0..af2e047f1da51fbf28aadc4fe6b20a98fbe75d89 100644
--- a/src/Gargantext/Database/Utils.hs
+++ b/src/Gargantext/Database/Utils.hs
@@ -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
diff --git a/src/Gargantext/Text/Flow.hs b/src/Gargantext/Text/Flow.hs
index 2f23f25ea4e9b3933ebfbcffd8e711f660b0ce23..5f714c39449eaaf86134de6538f38c4db551c75b 100644
--- a/src/Gargantext/Text/Flow.hs
+++ b/src/Gargantext/Text/Flow.hs
@@ -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
diff --git a/src/Gargantext/Viz/Graph.hs b/src/Gargantext/Viz/Graph.hs
index 40308bb34f778ef62b25ff9b472f9e9873aa39d4..70e6deb08ec5a2ec0b990e74b1c98b0254026548 100644
--- a/src/Gargantext/Viz/Graph.hs
+++ b/src/Gargantext/Viz/Graph.hs
@@ -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