Merge branch 'dev-api-node-count' of...

Merge branch 'dev-api-node-count' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantext into dev

src/Gargantext/API/Node.hs

@@ -55,6 +55,7 @@ import Gargantext.API.Ngrams.NTree (MyTree)
 import Gargantext.API.Search (SearchDocsAPI, searchDocs)
 import Gargantext.API.Table
 import Gargantext.API.Types
+import Gargantext.Core.Types (NodeTableResult)
 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
 import Gargantext.Database.Config (nodeTypeId)
 import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
@@ -158,7 +159,8 @@ type ChildrenApi a = Summary " Summary children"
                  :> QueryParam "type"   NodeType
                  :> QueryParam "offset" Int
                  :> QueryParam "limit"  Int
-                 :> Get '[JSON] [Node a]
+                 -- :> Get '[JSON] [Node a]
+                 :> Get '[JSON] (NodeTableResult a)
 
 ------------------------------------------------------------------------
 type NodeNodeAPI a = Get '[JSON] (Node a)

src/Gargantext/API/Table.hs

@@ -44,7 +44,7 @@ import Data.Swagger
 import Data.Text (Text())
 import GHC.Generics (Generic)
 import Gargantext.API.Ngrams (TabType(..))
-import Gargantext.Core.Types (Offset, Limit)
+import Gargantext.Core.Types (Offset, Limit, TableResult(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..))
 import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
@@ -60,7 +60,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 type TableApi = Summary " Table API"
               :> ReqBody '[JSON] TableQuery
-              :> Post    '[JSON] TableResult
+              :> Post    '[JSON] FacetTableResult
 
 data TableQuery = TableQuery
   { tq_offset  :: Int
@@ -70,17 +70,7 @@ data TableQuery = TableQuery
   , tq_query  :: Text
   } deriving (Generic)
 
-data TableResult = TableResult { tr_count :: Int
-                               , tr_docs  :: [FacetDoc]
-                               } deriving (Generic)
-
-$(deriveJSON (unPrefix "tr_") ''TableResult)
-
-instance ToSchema TableResult where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tr_")
-
-instance Arbitrary TableResult where
-  arbitrary = TableResult <$> arbitrary <*> arbitrary
+type FacetTableResult = TableResult FacetDoc
 
 $(deriveJSON (unPrefix "tq_") ''TableQuery)
 
@@ -91,7 +81,7 @@ instance Arbitrary TableQuery where
   arbitrary = elements [TableQuery 0 10 DateAsc Docs "electrodes"]
 
 
-tableApi :: NodeId -> TableQuery -> Cmd err TableResult
+tableApi :: NodeId -> TableQuery -> Cmd err FacetTableResult
 tableApi cId (TableQuery o l order ft "") = getTable cId (Just ft) (Just o) (Just l) (Just order)
 tableApi cId (TableQuery o l order ft q) = case ft of
       Docs  -> searchInCorpus' cId False [q] (Just o) (Just l) (Just order)
@@ -104,20 +94,21 @@ searchInCorpus' :: CorpusId
                 -> Maybe Offset
                 -> Maybe Limit
                 -> Maybe OrderBy
-                -> Cmd err TableResult
+                -> Cmd err FacetTableResult
 searchInCorpus' cId t q o l order = do
   docs <- searchInCorpus cId t q o l order
-  allDocs  <- searchInCorpus cId t q Nothing Nothing Nothing
-  pure (TableResult (length allDocs) docs)
+  countAllDocs  <- searchCountInCorpus cId t q
+  pure $ TableResult { tr_docs = docs, tr_count = countAllDocs }
 
 
 getTable :: NodeId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit
-         -> Maybe OrderBy -> Cmd err TableResult
+         -> Maybe OrderBy -> Cmd err FacetTableResult
 getTable cId ft o l order = do
   docs <- getTable' cId ft o l order
+  -- TODO: Rewrite to use runCountOpaQuery and avoid (length allDocs)
   allDocs  <- getTable' cId ft Nothing Nothing Nothing
-  pure (TableResult (length allDocs) docs)
+  pure $ TableResult { tr_docs = docs, tr_count = length allDocs }
 
 getTable' :: NodeId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit

src/Gargantext/Core/Types.hs

@@ -14,6 +14,7 @@ commentary with @some markup@.
 ------------------------------------------------------------------------
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE TemplateHaskell      #-}
 
 module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              , module Gargantext.Database.Types.Node
@@ -22,21 +23,28 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              , Label, Stems
                              , HasInvalidError(..), assertValid
                              , Name
+                             , TableResult(..)
+                             , NodeTableResult
                              ) where
 
 import Control.Lens (Prism', (#))
 import Control.Monad.Error.Class (MonadError, throwError)
 
 import Data.Aeson
-import Data.Semigroup
+import Data.Aeson.TH (deriveJSON)
 import Data.Monoid
+import Data.Semigroup
 import Data.Set (Set, empty)
+import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
 --import qualified Data.Set as S
 
 import Data.Text (Text, unpack)
 import Data.Validity
 
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
 import Gargantext.Core.Types.Main
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Types.Node
 import Gargantext.Prelude
 
@@ -135,3 +143,18 @@ assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
 assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
 -- assertValid :: MonadIO m => Validation -> m ()
 -- assertValid v = when (not $ validationIsValid v) $ fail $ show v
+
+
+data TableResult a = TableResult { tr_count :: Int
+                                 , tr_docs :: [a]
+                                 } deriving (Generic)
+
+$(deriveJSON (unPrefix "tr_") ''TableResult)
+
+instance ToSchema a => ToSchema (TableResult a) where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tr_")
+
+instance Arbitrary a => Arbitrary (TableResult a) where
+  arbitrary = TableResult <$> arbitrary <*> arbitrary
+
+type NodeTableResult a = TableResult (Node a)

src/Gargantext/Database/Flow/Pairing.hs

@@ -32,6 +32,7 @@ import qualified Data.Map as DM
 import Data.Text (Text, toLower)
 import qualified Data.Text as DT
 import Gargantext.Prelude hiding (sum)
+import Gargantext.Core.Types (TableResult(..))
 import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
 import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
 import Gargantext.Database.Flow.Utils
@@ -50,7 +51,7 @@ pairing :: AnnuaireId
 pairing aId cId lId = do
   contacts' <- getAllContacts aId
   let contactsMap = pairingPolicyToMap toLower
-                  $ toMaps extractNgramsT contacts'
+                  $ toMaps extractNgramsT (tr_docs contacts')
 
   ngramsMap' <- getNgramsTindexed cId Authors
   let ngramsMap = pairingPolicyToMap lastName ngramsMap'

src/Gargantext/Database/Node/Children.hs

@@ -30,12 +30,11 @@ import Gargantext.Database.Node.Contact (HyperdataContact)
 import Gargantext.Database.Schema.Node (pgNodeId)
 import Control.Arrow (returnA)
 
-
-getAllDocuments :: ParentId -> Cmd err [Node HyperdataDocument]
+getAllDocuments :: ParentId -> Cmd err (TableResult (Node HyperdataDocument))
 getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
                                          (Just NodeDocument)
 
-getAllContacts :: ParentId -> Cmd err [Node HyperdataContact]
+getAllContacts :: ParentId -> Cmd err (TableResult (Node HyperdataContact))
 getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
                                         (Just NodeContact)
 
@@ -43,7 +42,7 @@ getAllChildren :: JSONB a
                => ParentId
                -> proxy a
                -> Maybe NodeType
-               -> Cmd err [Node a]
+               -> Cmd err (NodeTableResult a)
 getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing
 
 getChildren :: JSONB a
@@ -52,11 +51,19 @@ getChildren :: JSONB 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
+            -> Cmd err (NodeTableResult a)
+getChildren pId _ maybeNodeType maybeOffset maybeLimit = do
+  docs <- runOpaQuery
+          $ limit' maybeLimit $ offset' maybeOffset
+          $ orderBy (asc _node_id)
+          $ query
+
+  docCount <- runCountOpaQuery query
+
+  pure $ TableResult { tr_docs = docs, tr_count = docCount }
+
+  where
+    query = selectChildren pId maybeNodeType
 
 selectChildren :: ParentId
                -> Maybe NodeType

src/Gargantext/Database/TextSearch.hs

@@ -35,7 +35,7 @@ import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Schema.NodeNode hiding (joinInCorpus)
 import Gargantext.Database.Schema.NodeNodeNgrams
 import Gargantext.Database.Queries.Join (leftJoin6)
-import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery)
+import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, runCountOpaQuery)
 import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
 import Gargantext.Core.Types
 import Control.Arrow (returnA)
@@ -72,6 +72,15 @@ searchInCorpus cId t q o l order = runOpaQuery
                                  $ intercalate " | "
                                  $ map stemIt q
 
+searchCountInCorpus :: CorpusId
+                    -> IsTrash
+                    -> [Text]
+                    -> Cmd err Int
+searchCountInCorpus cId t q = runCountOpaQuery
+                            $ queryInCorpus cId t
+                            $ intercalate " | "
+                            $ map stemIt q
+
 queryInCorpus :: CorpusId
               -> IsTrash
               -> Text

src/Gargantext/Database/Utils.hs

@@ -30,6 +30,7 @@ import Control.Monad.Except
 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
 import Data.Either.Extra (Either(Left, Right))
 import Data.Ini (readIniFile, lookupValue)
+import qualified Data.List as DL
 import Data.Maybe (maybe)
 import Data.Monoid ((<>))
 import Data.Profunctor.Product.Default (Default)
@@ -41,6 +42,7 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
 import Database.PostgreSQL.Simple.Internal  (Field)
 import Gargantext.Prelude
 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
+import Opaleye.Aggregate (countRows)
 import System.IO (FilePath)
 import Text.Read (read)
 import qualified Data.ByteString      as DB
@@ -67,6 +69,9 @@ type Cmd' env err a = forall m. CmdM' env err m => m a
 
 type Cmd err a = forall m env. CmdM env err m => m a
 
+fromInt64ToInt :: Int64 -> Int
+fromInt64ToInt = fromIntegral
+
 -- TODO: ideally there should be very few calls to this functions.
 mkCmd :: (Connection -> IO a) -> Cmd err a
 mkCmd k = do
@@ -82,6 +87,12 @@ runOpaQuery :: Default FromFields fields haskells
             => Select fields -> Cmd err [haskells]
 runOpaQuery q = mkCmd $ \c -> runQuery c q
 
+runCountOpaQuery :: Select a -> Cmd err Int
+runCountOpaQuery q = do
+  counts <- mkCmd $ \c -> runQuery c $ countRows q
+  -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
+  pure $ fromInt64ToInt $ DL.head counts
+
 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a