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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Test.API.UpdateList (
tests
, newCorpusForUser
, JobPollHandle(..)
, pollUntilFinished
) where
import Control.Lens (mapped, over)
import Control.Monad.Fail (fail)
import Data.Aeson qualified as JSON
import Data.Aeson.QQ
import Data.Map.Strict qualified as Map
import Data.Map.Strict.Patch qualified as PM
import Data.Set qualified as Set
import Data.String (fromString)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Fmt
import Gargantext.API.Admin.Auth.Types (Token)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors
import Gargantext.API.Ngrams qualified as APINgrams
import Gargantext.API.Ngrams.List ( ngramsListFromTSVData )
import Gargantext.API.Ngrams.Types ( MSet(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTablePatch(..), NgramsTerm(..), Versioned(..), mSetToList, toNgramsPatch, ne_children, ne_ngrams, vc_data, _NgramsTable )
import Gargantext.API.Node.Corpus.New.Types qualified as FType
import Gargantext.API.Node.Types
import Gargantext.API.Routes.Named
import Gargantext.API.Routes.Named.Corpus
import Gargantext.API.Routes.Named.Private
import Gargantext.Core qualified as Lang
import Gargantext.Core.Text.List.Social
import Gargantext.Core.Text.Ngrams
import Gargantext.Core.Types ( CorpusId, ListId, ListType(..), NodeId, _NodeId )
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.User
import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Tree.Root
import Gargantext.Prelude hiding (get)
import Network.Wai.Handler.Warp qualified as Wai
import Paths_gargantext (getDataFileName)
import Servant
import Servant.Client
import Servant.Job.Async
import Test.API.Routes (mkUrl, table_ngrams_get_api, table_ngrams_put_api, toServantToken, clientRoutes)
import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
import Test.Database.Types
import Test.Hspec
import Test.Hspec.Wai (shouldRespondWith)
import Test.Hspec.Wai.Internal (withApplication, WaiSession)
import Test.Hspec.Wai.JSON (json)
import Test.Types (JobPollHandle(..))
import Test.Utils (getJSON, pollUntilFinished, postJSONUrlEncoded, protectedJSON, withValidLogin)
import Web.FormUrlEncoded
newCorpusForUser :: TestEnv -> T.Text -> IO NodeId
newCorpusForUser env uname = flip runReaderT env $ runTestMonad $ do
uid <- getUserId (UserName uname)
parentId <- getRootId (UserName uname)
let corpusName = "Test_Corpus"
(corpusId:_) <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
pure corpusId
uploadJSONList :: Wai.Port -> Token -> CorpusId -> WaiSession () ListId
uploadJSONList port token cId = do
([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
-- Upload the JSON doc
simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/simple.json")
let jsonFileFormData = [ (T.pack "_wjf_data", simpleNgrams)
, ("_wjf_filetype", "JSON")
, ("_wjf_name", "simple_ngrams.json")
]
let url = "/lists/" +|listId|+ "/add/form/async"
let mkPollUrl j = "/corpus/" +|listId|+ "/add/form/async/" +|_jph_id j|+ "/poll?limit=1"
(j :: JobPollHandle) <- postJSONUrlEncoded token (mkUrl port url) (urlEncodeFormStable $ toForm jsonFileFormData)
j' <- pollUntilFinished token port mkPollUrl j
liftIO (_jph_status j' `shouldBe` "IsFinished")
pure listId
-- uploadListPatch :: Wai.Port
-- -> Token
-- -> CorpusId
-- -> ListId
-- -> APINgrams.Version
-- -> PM.PatchMap NgramsTerm NgramsPatch
-- -> WaiSession () ()
-- uploadListPatch port token cId listId version patch = do
-- let js = JSON.toJSON (Versioned version $ NgramsTablePatch patch)
-- -- panicTrace $ "[uploadListPatch] js: " <> show js
-- -- APINgrams.tableNgramsPut Terms listId (Versioned 0 $ NgramsTablePatch $ fst patch)
-- (_res :: Versioned NgramsTablePatch) <- protectedJSON token "PUT" (mkUrl port ("/node/" <> build cId <> "/ngrams?ngramsType=Terms&list=" <> build listId)) js
-- -- panicTrace $ "[uploadListPatch] res: " <> show res
-- pure ()
tests :: Spec
tests = sequential $ aroundAll withTestDBAndPort $ do
describe "UpdateList API" $ do
it "setup DB triggers and users" $ \((testEnv, _), _) -> do
setupEnvironment testEnv
createAliceAndBob testEnv
describe "POST /api/v1.0/lists/:id/add/form/async (JSON)" $ do
it "allows uploading a JSON ngrams file" $ \((testEnv, port), app) -> do
cId <- newCorpusForUser testEnv "alice"
withApplication app $ do
withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
listId <- uploadJSONList port token cId
-- Now check that we can retrieve the ngrams
let getUrl = "/node/" +| listId |+ "/ngrams?ngramsType=Terms&listType=MapTerm&list="+| listId |+"&limit=50"
getJSON token (mkUrl port getUrl)
`shouldRespondWith` [json| { "version": 0,
"count": 1,
"data": [
{
"ngrams": "abelian group",
"size": 2,
"list": "MapTerm",
"occurrences": [],
"children": []
}
]
} |]
it "does not create duplicates when uploading JSON (#313)" $ \((testEnv, port), app) -> do
cId <- newCorpusForUser testEnv "alice"
withApplication app $ do
withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
-- this term is imported from the .json file
let importedTerm = NgramsTerm "abelian group"
-- this is the new term, under which importedTerm will be grouped
let newTerm = NgramsTerm "new abelian group"
listId <- uploadJSONList port token cId
let checkNgrams expected = do
eng <- liftIO $ runClientM (table_ngrams_get_api token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
case eng of
Left err -> fail (show err)
Right r ->
let real = over mapped (\nt -> ( nt ^. ne_ngrams
, mSetToList $ nt ^. ne_children ))
(r ^. vc_data . _NgramsTable) in
liftIO $ Set.fromList real `shouldBe` Set.fromList expected
-- The #313 error is about importedTerm being duplicated
-- in a specific case
checkNgrams [ (importedTerm, []) ]
let nre = NgramsRepoElement 1 MapTerm Nothing Nothing (MSet mempty)
let patch = PM.fromList [
( newTerm
, NgramsReplace { _patch_old = Nothing
, _patch_new = Just nre } )
]
_ <- liftIO $ runClientM (table_ngrams_put_api token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst patch)) clientEnv
-- check that new term is added (with no parent)
checkNgrams [ (newTerm, [])
, (importedTerm, []) ]
-- now patch it so that we have a group
let patchChildren = PM.fromList [
( newTerm
, toNgramsPatch [importedTerm] )
]
_ <- liftIO $ runClientM (table_ngrams_put_api token cId APINgrams.Terms listId (Versioned 32 $ NgramsTablePatch $ fst patchChildren)) clientEnv
-- check that new term is parent of old one
checkNgrams [ (newTerm, [importedTerm]) ]
-- finally, upload the list again, the group should be as
-- it was before (the bug in #313 was that "abelian group"
-- was created again as a term with no parent)
_ <- uploadJSONList port token cId
-- old (imported) term shouldn't become parentless
-- (#313 error was that we had [newTerm, importedTerm] instead)
-- NOTE: Unfortunately, I'm not able to reproduce this
-- error here, though I tried. Something is missing, maybe
-- some nodestory integration with tests?
checkNgrams [ (newTerm, [importedTerm]) ]
pure ()
describe "POST /api/v1.0/lists/:id/csv/add/form/async (CSV)" $ do
it "parses CSV via ngramsListFromCSVData" $ \((_testEnv, _port), _app) -> do
simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/simple.tsv")
ngramsListFromTSVData simpleNgrams `shouldBe`
Right (Map.fromList [ (NgramsTerms, Versioned 0 $ Map.fromList [
(NgramsTerm "abelian group", NgramsRepoElement 1 MapTerm Nothing Nothing (MSet mempty))
, (NgramsTerm "brazorf", NgramsRepoElement 1 StopTerm Nothing Nothing (MSet mempty))
])])
it "allows uploading a CSV ngrams file" $ \((testEnv, port), app) -> do
cId <- newCorpusForUser testEnv "alice"
withApplication app $ do
withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
-- Upload the CSV doc
simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/simple.tsv")
let tsvFileFormData = [ (T.pack "_wtf_data", simpleNgrams)
, ("_wtf_filetype", "TSV")
, ("_wtf_name", "simple.tsv")
]
let url = "/lists/" <> fromString (show $ _NodeId listId) <> "/tsv/add/form/async"
let mkPollUrl j = "/corpus/" <> fromString (show $ _NodeId listId) <> "/add/form/async/" +|_jph_id j|+ "/poll?limit=1"
(j :: JobPollHandle) <- postJSONUrlEncoded token (mkUrl port url) (urlEncodeFormStable $ toForm tsvFileFormData)
j' <- pollUntilFinished token port mkPollUrl j
liftIO (_jph_status j' `shouldBe` "IsFinished")
-- Now check that we can retrieve the ngrams
let getTermsUrl = "/node/" +| listId |+ "/ngrams?ngramsType=Terms&listType=MapTerm&list="+| listId |+"&limit=50"
getJSON token (mkUrl port getTermsUrl)
`shouldRespondWith` [json| {"version":0
,"count":1
,"data":[
{"ngrams":"abelian group"
,"size":1
,"list":"MapTerm"
,"occurrences":[],"children":[]}
]
} |]
let getStopUrl = "/node/" +| listId |+ "/ngrams?ngramsType=Terms&listType=StopTerm&list="+| listId |+"&limit=50"
getJSON token (mkUrl port getStopUrl)
`shouldRespondWith` [json| {"version":0
,"count":1
,"data":[
{"ngrams":"brazorf"
,"size":1
,"list":"StopTerm"
,"occurrences":[],"children":[]}
]
} |]
describe "POST /api/v1.0/corpus/:id/add/form/async (JSON)" $ do
it "allows uploading a JSON docs file" $ \((testEnv, port), app) -> do
cId <- newCorpusForUser testEnv "alice"
withApplication app $ do
withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
-- Import the docsList with only two documents, both containing a \"fortran\" term.
([corpusId] :: [CorpusId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeCorpus","pn_name":"Testing"}|]
simpleDocs <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/GarganText_DocsList-nodeId-177.json")
let newWithForm = mkNewWithForm simpleDocs "GarganText_DocsList-nodeId-177.json"
(j :: JobPollHandle) <- checkEither $ fmap toJobPollHandle <$> liftIO (runClientM (add_file_async token corpusId newWithForm) clientEnv)
let mkPollUrl jh = "/corpus/" <> fromString (show $ _NodeId corpusId) <> "/add/form/async/" +|_jph_id jh|+ "/poll?limit=1"
j' <- pollUntilFinished token port mkPollUrl j
liftIO (_jph_status j' `shouldBe` "IsFinished")
toJobPollHandle :: JobStatus 'Safe JobLog -> JobPollHandle
toJobPollHandle = either (\x -> panicTrace $ "toJobPollHandle:" <> T.pack x) identity . JSON.eitherDecode . JSON.encode
checkEither :: (Show a, Monad m) => m (Either a b) -> m b
checkEither = fmap (either (\x -> panicTrace $ "checkEither:" <> T.pack (show x)) identity)
mkNewWithForm :: T.Text -> T.Text -> NewWithForm
mkNewWithForm content name = NewWithForm
{ _wf_filetype = FType.JSON
, _wf_fileformat = FType.Plain
, _wf_data = content
, _wf_lang = Just Lang.EN
, _wf_name = name
, _wf_selection = FlowSocialListWithPriority MySelfFirst
}
add_file_async :: Token
-> CorpusId
-> NewWithForm
-> ClientM (JobStatus 'Safe JobLog)
add_file_async (toServantToken -> token) corpusId nwf =
clientRoutes & apiWithCustomErrorScheme
& ($ GES_new)
& backendAPI
& backendAPI'
& mkBackEndAPI
& gargAPIVersion
& gargPrivateAPI
& mkPrivateAPI
& ($ token)
& addWithFormAPI
& addWithFormEp
& ($ corpusId)
& asyncJobsAPI'
& (\(_ :<|> submitForm :<|> _) -> submitForm (JobInput nwf Nothing))