Skip to content

haskell-gargantext
haskell-gargantext
Commit 87b64d29 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli
Browse files
Options

Add test for searchInCorpus

parent 2c4e9d9a
Show whitespace changes
Inline Side-by-side
Showing with 101 additions and 58 deletions
bin/gargantext-init/Main.hs
View file @ 87b64d29
......@@ -73,7 +73,7 @@ main = do
pure (masterUserId, masterRootId, masterCorpusId, masterListId)
withDevEnv iniPath $ \env -> do
_ <- runCmdDev env (initFirstTriggers secret :: Cmd GargError [Int64])
_ <- runCmdDev env (initFirstTriggers secret :: DBCmd GargError [Int64])
_ <- runCmdDev env createUsers
x <- runCmdDev env initMaster
_ <- runCmdDev env mkRoots
......
gargantext.cabal
View file @ 87b64d29
......@@ -86,6 +86,7 @@ library
Gargantext.Core.Text.Terms
Gargantext.Core.Text.Terms.Eleve
Gargantext.Core.Text.Terms.Mono
Gargantext.Core.Text.Terms.Mono.Stem.En
Gargantext.Core.Text.Terms.Multi
Gargantext.Core.Text.Terms.Multi.Lang.En
Gargantext.Core.Text.Terms.Multi.Lang.Fr
......@@ -113,6 +114,7 @@ library
Gargantext.Core.Viz.Types
Gargantext.Database.Action.Flow
Gargantext.Database.Action.Flow.Types
Gargantext.Database.Action.Search
Gargantext.Database.Action.User
Gargantext.Database.Action.User.New
Gargantext.Database.Admin.Config
......@@ -253,7 +255,6 @@ library
Gargantext.Core.Text.Samples.PL
Gargantext.Core.Text.Samples.ZH
Gargantext.Core.Text.Terms.Mono.Stem
Gargantext.Core.Text.Terms.Mono.Stem.En
Gargantext.Core.Text.Terms.Mono.Token
Gargantext.Core.Text.Terms.Mono.Token.En
Gargantext.Core.Text.Terms.Multi.Group
......@@ -291,7 +292,6 @@ library
Gargantext.Database.Action.Metrics.NgramsByContext
Gargantext.Database.Action.Metrics.TFICF
Gargantext.Database.Action.Node
Gargantext.Database.Action.Search
Gargantext.Database.Action.Share
Gargantext.Database.Action.TSQuery
Gargantext.Database.Admin.Access
......
src/Gargantext/Database/Action/Flow.hs
View file @ 87b64d29
......@@ -324,7 +324,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
pure ids
------------------------------------------------------------------------
createNodes :: ( FlowCmdM env err m
createNodes :: ( DbCmd' env err m, HasNodeError err
, MkCorpus c
)
=> User
......
src/Gargantext/Database/Action/Search.hs
View file @ 87b64d29
......@@ -11,7 +11,13 @@ Portability : POSIX
{-# LANGUAGE Arrows #-}
{-# LANGUAGE LambdaCase #-}
module Gargantext.Database.Action.Search where
module Gargantext.Database.Action.Search (
searchInCorpus
, searchInCorpusWithContacts
, searchCountInCorpus
, searchInCorpusWithNgrams
, searchDocInDatabase
) where
import Control.Arrow (returnA)
import Control.Lens ((^.), view)
......@@ -25,7 +31,7 @@ import Gargantext.Core
import Gargantext.Core.Types
import Gargantext.Core.Types.Query (IsTrash, Limit, Offset)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..), HyperdataContact(..))
import Gargantext.Database.Prelude (Cmd, runOpaQuery, runCountOpaQuery)
import Gargantext.Database.Prelude (runOpaQuery, runCountOpaQuery, DBCmd)
import Gargantext.Database.Query.Facet
import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Table.Node
......@@ -48,7 +54,7 @@ import qualified Opaleye as O hiding (Order)
searchDocInDatabase :: HasDBid NodeType
=> ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
-> DBCmd err [(NodeId, HyperdataDocument)]
searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
where
-- | Global search query where ParentId is Master Node Corpus Id
......@@ -71,7 +77,7 @@ searchInCorpusWithNgrams :: HasDBid NodeType
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetDoc]
-> DBCmd err [FacetDoc]
searchInCorpusWithNgrams _cId _lId _t _ngt _q _o _l _order = undefined
-- | Compute TF-IDF for all 'ngramIds' in given 'CorpusId'. In this
......@@ -79,11 +85,11 @@ searchInCorpusWithNgrams _cId _lId _t _ngt _q _o _l _order = undefined
-- ratio of "number of times our terms appear in given document" and
-- "number of all terms in document" and return a sorted list of
-- document ids
tfidfAll :: (HasDBid NodeType, HasNodeError err) => CorpusId -> [Int] -> Cmd err [Int]
tfidfAll cId ngramIds = do
_tfidfAll :: (HasDBid NodeType, HasNodeError err) => CorpusId -> [Int] -> DBCmd err [Int]
_tfidfAll cId ngramIds = do
let ngramIdsSet = Set.fromList ngramIds
lId <- defaultList cId
docsWithNgrams <- runOpaQuery (queryListWithNgrams lId ngramIds) :: Cmd err [(Int, Int, Int)]
docsWithNgrams <- runOpaQuery (_queryListWithNgrams lId ngramIds) :: DBCmd err [(Int, Int, Int)]
-- NOTE The query returned docs with ANY ngramIds. We need to further
-- restrict to ALL ngramIds.
let docsNgramsM =
......@@ -111,8 +117,8 @@ tfidfAll cId ngramIds = do
-- | Query for searching the 'context_node_ngrams' table so that we
-- find docs with ANY given 'ngramIds'.
queryListWithNgrams :: ListId -> [Int] -> Select (Column SqlInt4, Column SqlInt4, Column SqlInt4)
queryListWithNgrams lId ngramIds = proc () -> do
_queryListWithNgrams :: ListId -> [Int] -> Select (Column SqlInt4, Column SqlInt4, Column SqlInt4)
_queryListWithNgrams lId ngramIds = proc () -> do
row <- queryContextNodeNgramsTable -< ()
restrict -< (_cnng_node_id row) .== (pgNodeId lId)
restrict -< in_ (sqlInt4 <$> ngramIds) (_cnng_ngrams_id row)
......@@ -137,7 +143,7 @@ searchInCorpus :: HasDBid NodeType
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetDoc]
-> DBCmd err [FacetDoc]
searchInCorpus cId t q o l order = runOpaQuery
$ filterWith o l order
$ queryInCorpus cId t
......@@ -148,7 +154,7 @@ searchCountInCorpus :: HasDBid NodeType
=> CorpusId
-> IsTrash
-> [Text]
-> Cmd err Int
-> DBCmd err Int
searchCountInCorpus cId t q = runCountOpaQuery
$ queryInCorpus cId t
$ intercalate " | "
......@@ -189,7 +195,7 @@ searchInCorpusWithContacts
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetPaired Int UTCTime HyperdataContact Int]
-> DBCmd err [FacetPaired Int UTCTime HyperdataContact Int]
searchInCorpusWithContacts cId aId q o l _order =
runOpaQuery $ limit' l
$ offset' o
......
src/Gargantext/Database/Admin/Trigger/ContextNodeNgrams.hs
View file @ 87b64d29
......@@ -20,11 +20,12 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core
-- import Gargantext.Core.Types.Main (ListType(CandidateTerm))
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery)
-- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerCountInsert :: HasDBid NodeType => Cmd err Int64
triggerCountInsert :: HasDBid NodeType => DBCmd err Int64
triggerCountInsert = execPGSQuery query (toDBid NodeDocument, toDBid NodeList)
where
query :: DPS.Query
......@@ -60,7 +61,7 @@ triggerCountInsert = execPGSQuery query (toDBid NodeDocument, toDBid NodeList)
EXECUTE PROCEDURE set_ngrams_global_count();
|]
triggerCountInsert2 :: HasDBid NodeType => Cmd err Int64
triggerCountInsert2 :: HasDBid NodeType => DBCmd err Int64
triggerCountInsert2 = execPGSQuery query ( toDBid NodeCorpus
, toDBid NodeDocument
, toDBid NodeList
......
src/Gargantext/Database/Admin/Trigger/Contexts.hs
View file @ 87b64d29
......@@ -20,12 +20,13 @@ import Data.Text (Text)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core (HasDBid(..))
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery)
-- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerSearchUpdate :: HasDBid NodeType => Cmd err Int64
triggerSearchUpdate :: HasDBid NodeType => DBCmd err Int64
triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
, toDBid NodeDocument
, toDBid NodeContact
......@@ -69,7 +70,7 @@ triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
type Secret = Text
triggerUpdateHash :: HasDBid NodeType => Secret -> Cmd err Int64
triggerUpdateHash :: HasDBid NodeType => Secret -> DBCmd err Int64
triggerUpdateHash secret = execPGSQuery query ( toDBid NodeDocument
, toDBid NodeContact
, secret
......
src/Gargantext/Database/Admin/Trigger/Init.hs
View file @ 87b64d29
......@@ -20,16 +20,17 @@ import Data.Text (Text)
import Gargantext.Database.Admin.Trigger.ContextNodeNgrams (triggerCountInsert, triggerCountInsert2)
import Gargantext.Database.Admin.Trigger.Contexts (triggerSearchUpdate, triggerUpdateHash)
import Gargantext.Database.Admin.Trigger.NodesContexts ({-triggerDeleteCount,-} triggerInsertCount, triggerUpdateAdd, triggerUpdateDel, MasterListId) -- , triggerCoocInsert)
import Gargantext.Database.Prelude (Cmd)
-- , triggerCoocInsert)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Prelude
------------------------------------------------------------------------
initFirstTriggers :: Text -> Cmd err [Int64]
initFirstTriggers :: Text -> DBCmd err [Int64]
initFirstTriggers secret = do
t0 <- triggerUpdateHash secret
pure [t0]
initLastTriggers :: MasterListId -> Cmd err [Int64]
initLastTriggers :: MasterListId -> DBCmd err [Int64]
initLastTriggers lId = do
t0 <- triggerSearchUpdate
t1 <- triggerCountInsert
......
src/Gargantext/Database/Admin/Trigger/NodesContexts.hs
View file @ 87b64d29
......@@ -20,13 +20,14 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery)
-- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
type MasterListId = ListId
triggerInsertCount :: MasterListId -> Cmd err Int64
triggerInsertCount :: MasterListId -> DBCmd err Int64
triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
......@@ -62,7 +63,7 @@ triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
|]
triggerUpdateAdd :: MasterListId -> Cmd err Int64
triggerUpdateAdd :: MasterListId -> DBCmd err Int64
triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
......@@ -102,7 +103,7 @@ triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList)
|]
triggerUpdateDel :: MasterListId -> Cmd err Int64
triggerUpdateDel :: MasterListId -> DBCmd err Int64
triggerUpdateDel lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
......@@ -144,7 +145,7 @@ triggerUpdateDel lId = execPGSQuery query (lId, nodeTypeId NodeList)
triggerDeleteCount :: MasterListId -> Cmd err Int64
triggerDeleteCount :: MasterListId -> DBCmd err Int64
triggerDeleteCount lId = execPGSQuery query (lId, toDBid NodeList)
where
query :: DPS.Query
......
src/Gargantext/Database/Prelude.hs
View file @ 87b64d29
......@@ -138,7 +138,7 @@ runOpaQuery :: Default FromFields fields haskells
-> DBCmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runSelect c q
runCountOpaQuery :: Select a -> Cmd err Int
runCountOpaQuery :: Select a -> DBCmd err Int
runCountOpaQuery q = do
counts <- mkCmd $ \c -> runSelect c $ countRows q
-- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
......@@ -189,7 +189,7 @@ runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
hPutStrLn stderr (fromQuery q)
throw (SomeException e)
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
------------------------------------------------------------------------
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ 87b64d29
......@@ -171,7 +171,7 @@ getClosestParentIdByType' nId nType = do
getChildrenByType :: HasDBid NodeType
=> NodeId
-> NodeType
-> Cmd err [NodeId]
-> DBCmd err [NodeId]
getChildrenByType nId nType = do
result <- runPGSQuery query (PGS.Only nId)
children_lst <- mapM (\(id, _) -> getChildrenByType id nType) result
......@@ -275,7 +275,7 @@ insertDefaultNode :: HasDBid NodeType
insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
insertDefaultNodeIfNotExists :: HasDBid NodeType
=> NodeType -> ParentId -> UserId -> Cmd err [NodeId]
=> NodeType -> ParentId -> UserId -> DBCmd err [NodeId]
insertDefaultNodeIfNotExists nt p u = do
children <- getChildrenByType p nt
case children of
......@@ -406,7 +406,7 @@ getOrMkList pId uId =
mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
-- | TODO remove defaultList
defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> DBCmd err ListId
defaultList cId =
maybe (nodeError (NoListFound cId)) (pure . view node_id) . headMay =<< getListsWithParentId cId
......
test/Database/Operations.hs
View file @ 87b64d29
......@@ -22,7 +22,7 @@ import Gargantext.Database.Action.User
import Gargantext.Database.Action.User.New
import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node (mk, getCorporaWithParentId)
import Gargantext.Database.Query.Table.Node (mk, getCorporaWithParentId, getOrMkList)
import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Database.Schema.Node (NodePoly(..))
import Gargantext.Prelude
......@@ -44,6 +44,9 @@ import Test.Hspec
import Test.QuickCheck.Monadic
import Test.Tasty.HUnit hiding (assert)
import Test.Tasty.QuickCheck
import Gargantext.Database.Admin.Trigger.Init
import Gargantext.Database.Action.Flow
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
-- | Keeps a log of usernames we have already generated, so that our
-- roundtrip tests won't fail.
......@@ -110,6 +113,8 @@ withTestDB = bracket setup teardown
tests :: Spec
tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
describe "Prelude" $ do
it "setup DB triggers" setupEnvironment
describe "Read/Writes" $ do
describe "User creation" $ do
it "Simple write/read" writeRead01
......@@ -119,6 +124,9 @@ tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
it "Simple write/read" corpusReadWrite01
it "Can add language to Corpus" corpusAddLanguage
it "Can add documents to a Corpus" corpusAddDocuments
describe "Corpus search" $ do
it "Can stem query terms" stemmingTest
it "Can perform a simple search inside documents" corpusSearch01
data ExpectedActual a =
Expected a
......@@ -130,6 +138,16 @@ instance Eq a => Eq (ExpectedActual a) where
(Actual a) == (Expected b) = a == b
_ == _ = False
setupEnvironment :: TestEnv -> IO ()
setupEnvironment env = flip runReaderT env $ runTestMonad $ do
void $ initFirstTriggers "secret_key"
void $ new_user $ mkNewUser (userMaster <> "@cnrs.com") (GargPassword "secret_key")
(masterUserId, _masterRootId, masterCorpusId)
<- getOrMk_RootWithCorpus (UserName userMaster)
(Left corpusMasterName)
(Nothing :: Maybe HyperdataCorpus)
masterListId <- getOrMkList masterCorpusId masterUserId
void $ initLastTriggers masterListId
writeRead01 :: TestEnv -> Assertion
writeRead01 env = do
......@@ -140,14 +158,14 @@ writeRead01 env = do
uid1 <- new_user nur1
uid2 <- new_user nur2
liftBase $ uid1 `shouldBe` 1
liftBase $ uid2 `shouldBe` 2
liftBase $ uid1 `shouldBe` 2
liftBase $ uid2 `shouldBe` 3
-- Getting the users by username returns the expected IDs
uid1' <- getUserId (UserName "alfredo")
uid2' <- getUserId (UserName "paul")
liftBase $ uid1' `shouldBe` 1
liftBase $ uid2' `shouldBe` 2
liftBase $ uid1' `shouldBe` 2
liftBase $ uid2' `shouldBe` 3
mkUserDup :: TestEnv -> Assertion
mkUserDup env = do
......@@ -184,7 +202,7 @@ corpusReadWrite01 env = do
uid <- getUserId (UserName "alfredo")
parentId <- getRootId (UserName "alfredo")
[corpusId] <- mk (Just "Test_Corpus") (Nothing :: Maybe HyperdataCorpus) parentId uid
liftIO $ corpusId `shouldBe` NodeId 409
liftIO $ corpusId `shouldBe` NodeId 416
-- Retrieve the corpus by Id
[corpus] <- getCorporaWithParentId parentId
liftIO $ corpusId `shouldBe` (_node_id corpus)
......
test/Database/Operations/DocumentSearch.hs
View file @ 87b64d29
......@@ -11,24 +11,25 @@ import Data.Maybe
import Gargantext.Core
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.User
import Gargantext.Database.Action.User.New
import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Action.Search
import Gargantext.Database.Admin.Types.Hyperdata.Document
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Tree.Root
import Gargantext.Database.Schema.Node (NodePoly(..))
import Network.URI (parseURI)
import Test.Tasty.HUnit
import Database.Operations.Types
import Test.Hspec.Expectations
import Test.Tasty.HUnit
import Gargantext.Core.Text.Terms.Mono.Stem.En
import Gargantext.Database.Admin.Config (userMaster)
exampleDocument_01 :: HyperdataDocument
exampleDocument_01 = either error id $ parseEither parseJSON $ [aesonQQ|
{ "doi":"sdfds"
, "publication_day":6
, "language_iso2":"en"
, "language_iso2":"EN"
, "publication_minute":0
, "publication_month":7
, "language_iso3":"eng"
......@@ -49,7 +50,7 @@ exampleDocument_02 :: HyperdataDocument
exampleDocument_02 = either error id $ parseEither parseJSON $ [aesonQQ|
{ "doi":"sdfds"
, "publication_day":6
, "language_iso2":"en"
, "language_iso2":"EN"
, "publication_minute":0
, "publication_month":7
, "language_iso3":"eng"
......@@ -74,19 +75,33 @@ nlpServerConfig =
corpusAddDocuments :: TestEnv -> Assertion
corpusAddDocuments env = do
flip runReaderT env $ runTestMonad $ do
-- NOTE(adn) We need to create user 'gargantua'(!!) in order
-- for 'addDocumentsToHyperCorpus' to work.
let nur = mkNewUser "gargantua@foo.com" (GargPassword "my_secret")
void $ new_user nur
uid <- getUserId (UserName "alfredo")
parentId <- getRootId (UserName "gargantua")
void $ mk (Just "Test_Corpus") (Nothing :: Maybe HyperdataCorpus) parentId uid
parentId <- getRootId (UserName userMaster)
[corpus] <- getCorporaWithParentId parentId
let corpusId = _node_id corpus
_ids <- addDocumentsToHyperCorpus nlpServerConfig
ids <- addDocumentsToHyperCorpus nlpServerConfig
(Just $ _node_hyperdata $ corpus)
(Multi EN)
(_node_id corpus)
[exampleDocument_01]
pure ()
corpusId
[exampleDocument_01, exampleDocument_02]
liftIO $ length ids `shouldBe` 2
stemmingTest :: TestEnv -> Assertion
stemmingTest _env = do
stemIt "Ajeje" `shouldBe` "Ajeje"
stemIt "PyPlasm:" `shouldBe` "PyPlasm:"
corpusSearch01 :: TestEnv -> Assertion
corpusSearch01 env = do
flip runReaderT env $ runTestMonad $ do
parentId <- getRootId (UserName "gargantua")
[corpus] <- getCorporaWithParentId parentId
results1 <- searchInCorpus (_node_id corpus) False ["mineral"] Nothing Nothing Nothing
results2 <- searchInCorpus (_node_id corpus) False ["computational"] Nothing Nothing Nothing
liftIO $ length results1 `shouldBe` 1
liftIO $ length results2 `shouldBe` 1
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment