1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.Database.Operations (
tests
, nodeStoryTests
) where
import Control.Monad.Except
import Control.Monad.Reader
import Data.Text qualified as T
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.API.Node.Corpus.Update
import Gargantext.Core
import Gargantext.Core.Types.Individu
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.Prelude (runPGSQuery)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Database.Schema.Node (NodePoly(..))
import Gargantext.Prelude
import Test.API.Setup (setupEnvironment)
import Test.Database.Operations.DocumentSearch
import Test.Database.Operations.NodeStory
import Test.Database.Setup (withTestDB)
import Test.Database.Types
import Test.Hspec
import Test.QuickCheck.Monadic
import Test.Tasty.HUnit hiding (assert)
import Test.Tasty.QuickCheck
-- | Keeps a log of usernames we have already generated, so that our
-- roundtrip tests won't fail.
uniqueArbitraryNewUser :: Int -> Gen (NewUser GargPassword)
uniqueArbitraryNewUser currentIx = do
ur <- (`mappend` ((show currentIx :: Text) <> "-")) <$> ascii_txt
let email = ur <> "@foo.com"
NewUser <$> pure ur <*> pure email <*> elements arbitraryPassword
where
ascii_txt :: Gen T.Text
ascii_txt = fmap (T.pack . getPrintableString) arbitrary
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
it "Simple duplicate" mkUserDup
it "Read/Write roundtrip" prop_userCreationRoundtrip
describe "Corpus creation" $ 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
it "Can perform search by author in documents" corpusSearch02
it "Can perform more complex searches using the boolean API" corpusSearch03
it "Can correctly count doc score" corpusScore01
nodeStoryTests :: Spec
nodeStoryTests = sequential $
-- run 'withTestDB' before _every_ test item
around setupDBAndCorpus $
describe "Database - node story" $ do
describe "Node story" $ do
it "[#281] Can create a list" createListTest
it "[#281] Can query node story" queryNodeStoryTest
it "[#218] Can add new terms to node story" insertNewTermsToNodeStoryTest
it "[#281] Can add new terms (with children) to node story" insertNewTermsWithChildrenToNodeStoryTest
it "[#281] Fixes child terms to match parents' terms" insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest
it "[#281] Can update node story when 'setListNgrams' is called" setListNgramsUpdatesNodeStoryTest
it "[#281] When 'setListNgrams' is called, childrens' parents are updated" setListNgramsUpdatesNodeStoryWithChildrenTest
it "[#281] Correctly commits patches to node story - simple" commitPatchSimpleTest
where
setupDBAndCorpus testsFunc = withTestDB $ \env -> do
setupEnvironment env
testsFunc env
data ExpectedActual a =
Expected a
| Actual a
deriving Show
instance Eq a => Eq (ExpectedActual a) where
(Expected a) == (Actual b) = a == b
(Actual a) == (Expected b) = a == b
_ == _ = False
writeRead01 :: TestEnv -> Assertion
writeRead01 env = do
flip runReaderT env $ runTestMonad $ do
let nur1 = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
let nur2 = mkNewUser "paul@acme.com" (GargPassword "my_secret")
uid1 <- new_user nur1
uid2 <- new_user nur2
liftBase $ uid1 `shouldBe` UnsafeMkUserId 2
liftBase $ uid2 `shouldBe` UnsafeMkUserId 3
-- Getting the users by username returns the expected IDs
uid1' <- getUserId (UserName "alfredo")
uid2' <- getUserId (UserName "paul")
liftBase $ uid1' `shouldBe` UnsafeMkUserId 2
liftBase $ uid2' `shouldBe` UnsafeMkUserId 3
mkUserDup :: TestEnv -> Assertion
mkUserDup env = do
let x = flip runReaderT env $ runTestMonad $ do
-- This should fail, because user 'alfredo' exists already.
let nur = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
new_user nur
--
-- SqlError {sqlState = "23505", sqlExecStatus = FatalError
-- , sqlErrorMsg = "duplicate key value violates unique constraint \"auth_user_username_idx1\""
-- , sqlErrorDetail = "Key (username)=(alfredo) already exists.", sqlErrorHint = ""
-- }
--
-- Postgres increments the underlying SERIAL for the user even if the request fails, see
-- https://stackoverflow.com/questions/37204749/serial-in-postgres-is-being-increased-even-though-i-added-on-conflict-do-nothing
-- This means that the next available ID is '3'.
x `shouldThrow` (\SqlError{..} -> sqlErrorDetail == "Key (username)=(alfredo) already exists.")
runEnv :: TestEnv -> TestMonad a -> PropertyM IO a
runEnv env act = run (flip runReaderT env $ runTestMonad act)
prop_userCreationRoundtrip :: TestEnv -> Property
prop_userCreationRoundtrip env = monadicIO $ do
nextAvailableCounter <- run (nextCounter $ test_usernameGen env)
nur <- pick (uniqueArbitraryNewUser nextAvailableCounter)
uid <- runEnv env (new_user nur)
ur' <- runEnv env (getUserId (UserName $ _nu_username nur))
run (Expected uid `shouldBe` Actual ur')
-- | We test that we can create and later read-back a 'Corpus'.
corpusReadWrite01 :: TestEnv -> Assertion
corpusReadWrite01 env = do
flip runReaderT env $ runTestMonad $ do
uid <- getUserId (UserName "alfredo")
parentId <- getRootId (UserName "alfredo")
let corpusName = "Test_Corpus"
[corpusId] <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
[Only corpusId'] <- runPGSQuery [sql|SELECT id FROM nodes WHERE name = ?|] (Only corpusName)
liftIO $ corpusId `shouldBe` UnsafeMkNodeId corpusId'
-- Retrieve the corpus by Id
[corpus] <- getCorporaWithParentId parentId
liftIO $ corpusId `shouldBe` (_node_id corpus)
-- | We test that we can update the existing language for a 'Corpus'.
corpusAddLanguage :: TestEnv -> Assertion
corpusAddLanguage env = do
flip runReaderT env $ runTestMonad $ do
parentId <- getRootId (UserName "alfredo")
[corpus] <- getCorporaWithParentId parentId
liftIO $ (_hc_lang . _node_hyperdata $ corpus) `shouldBe` Just EN -- defaults to English
addLanguageToCorpus (_node_id corpus) IT
[corpus'] <- getCorporaWithParentId parentId
liftIO $ (_hc_lang . _node_hyperdata $ corpus') `shouldBe` Just IT