Setup tests for UpdateList via the JSON API

gargantext.cabal

@@ -28,6 +28,7 @@ data-files:
     ekg-assets/chart_line_add.png
     ekg-assets/cross.png
     test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json
+    test-data/ngrams/simple.json
     test-data/phylo/bpa_phylo_test.json
     test-data/phylo/open_science.json
     test-data/test_config.ini
@@ -58,6 +59,7 @@ library
       Gargantext.API.Errors.Types.Backend
       Gargantext.API.HashedResponse
       Gargantext.API.Ngrams
+      Gargantext.API.Ngrams.List.Types
       Gargantext.API.Ngrams.Prelude
       Gargantext.API.Ngrams.Tools
       Gargantext.API.Ngrams.Types
@@ -186,7 +188,6 @@ library
       Gargantext.API.Members
       Gargantext.API.Metrics
       Gargantext.API.Ngrams.List
-      Gargantext.API.Ngrams.List.Types
       Gargantext.API.Ngrams.NgramsTree
       Gargantext.API.Node.Contact
       Gargantext.API.Node.Corpus.Annuaire
@@ -939,10 +940,12 @@ test-suite garg-test-tasty
   build-depends:
       QuickCheck ^>= 2.14.2
     , aeson ^>= 1.5.6.0
+    , aeson-qq
     , async ^>= 2.2.4
     , base ^>= 4.14.3.0
     , boolexpr ^>= 0.2
     , bytestring ^>= 0.10.12.0
+    , case-insensitive
     , conduit ^>= 1.3.4.2
     , containers ^>= 0.6.5.1
     , crawlerArxiv
@@ -957,6 +960,7 @@ test-suite garg-test-tasty
     , hspec-expectations >= 0.8 && < 0.9
     , hspec-wai
     , hspec-wai-json
+    , http-api-data
     , http-client ^>= 0.6.4.1
     , http-client-tls ^>= 0.3.5.3
     , http-types
@@ -975,6 +979,7 @@ test-suite garg-test-tasty
     , recover-rtti >= 0.4 && < 0.5
     , resource-pool >= 0.2.3.2 && < 0.2.4
     , servant-auth
+    , servant-auth
     , servant-auth-client
     , servant-client
     , servant-job
@@ -1007,6 +1012,7 @@ test-suite garg-test-hspec
       Test.API.GraphQL
       Test.API.Private
       Test.API.Setup
+      Test.API.UpdateList
       Test.Database.Operations
       Test.Database.Operations.DocumentSearch
       Test.Database.Operations.NodeStory
@@ -1045,6 +1051,7 @@ test-suite garg-test-hspec
   build-depends:
       QuickCheck ^>= 2.14.2
     , aeson ^>= 1.5.6.0
+    , aeson-qq
     , async ^>= 2.2.4
     , base ^>= 4.14.3.0
     , boolexpr ^>= 0.2
@@ -1064,6 +1071,7 @@ test-suite garg-test-hspec
     , hspec-expectations >= 0.8 && < 0.9
     , hspec-wai
     , hspec-wai-json
+    , http-api-data
     , http-types
     , http-client ^>= 0.6.4.1
     , http-client-tls ^>= 0.3.5.3

src/Gargantext/API/Ngrams/List.hs

@@ -161,7 +161,7 @@ postAsync' l (WithJsonFile m _) jobHandle = do
   markProgress 1 jobHandle
 
   corpus_node <- getNode l -- (Proxy :: Proxy HyperdataList)
-  let corpus_id = fromMaybe (panic "") (_node_parent_id corpus_node)
+  let corpus_id = fromMaybe (panic "no parent_id") (_node_parent_id corpus_node)
   _ <- reIndexWith corpus_id l NgramsTerms (Set.fromList [MapTerm, CandidateTerm])
 
   markComplete jobHandle

test-data/ngrams/simple.json

+{ "Authors":    { "version":30 ,"data":{ "Alain Connes":{"size":2,"list":"MapTerm","children":[]} } }
+, "Institutes": { "version":30 ,"data":{ "College de France":{"size":3,"list":"MapTerm","children":[]} } }
+, "Sources":    { "version":30 ,"data":{ "Annales Henri Poincare 3 (2002) 411-433":{"size":6,"list":"MapTerm","children":[]} } }
+, "NgramsTerms":{ "version":30 ,"data":{ "abelian group":{"size":2,"list":"MapTerm","children":[]} } }
+}

test/Test/API.hs

@@ -4,9 +4,10 @@ module Test.API where
 import Prelude
 import Test.Hspec
 import qualified Test.API.Authentication as Auth
-import qualified Test.API.Private as Private
-import qualified Test.API.GraphQL as GraphQL
 import qualified Test.API.Errors as Errors
+import qualified Test.API.GraphQL as GraphQL
+import qualified Test.API.Private as Private
+import qualified Test.API.UpdateList as UpdateList
 
 tests :: Spec
 tests = describe "API" $ do
@@ -14,3 +15,4 @@ tests = describe "API" $ do
   Private.tests
   GraphQL.tests
   Errors.tests
+  UpdateList.tests

test/Test/API/Private.hs

@@ -10,10 +10,13 @@ module Test.API.Private (
   , withValidLogin
   , getJSON
   , protected
-  , protectedWith
+  , protectedJSON
+  , postJSONUrlEncoded
   , protectedNewError
+  , protectedWith
   ) where
 
+import Data.Aeson qualified as JSON
 import Data.ByteString.Lazy qualified as L
 import Data.CaseInsensitive qualified as CI
 import Data.Text.Encoding qualified as TE
@@ -24,7 +27,7 @@ import Gargantext.Prelude hiding (get)
 import Network.HTTP.Client hiding (Proxy)
 import Network.HTTP.Types
 import Network.Wai.Handler.Warp qualified as Wai
-import Network.Wai.Test (SResponse)
+import Network.Wai.Test (SResponse (..))
 import Prelude qualified
 import Servant
 import Servant.Auth.Client ()
@@ -36,19 +39,46 @@ import Test.Hspec
 import Test.Hspec.Wai hiding (pendingWith)
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Utils (jsonFragment, shouldRespondWith')
+import qualified Data.Map.Strict as Map
+import qualified Data.ByteString.Lazy.Char8 as C8L
 
 -- | Issue a request with a valid 'Authorization: Bearer' inside.
 protected :: Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
 protected tkn mth url = protectedWith mempty tkn mth url
 
+protectedJSON :: forall a. (JSON.FromJSON a, Typeable a)
+              => Token
+              -> Method
+              -> ByteString
+              -> JSON.Value
+              -> WaiSession () a
+protectedJSON tkn mth url = protectedJSONWith mempty tkn mth url
+
+protectedJSONWith :: forall a. (JSON.FromJSON a, Typeable a)
+                  => [Network.HTTP.Types.Header]
+                  -> Token
+                  -> Method
+                  -> ByteString
+                  -> JSON.Value
+                  -> WaiSession () a
+protectedJSONWith hdrs tkn mth url jsonV = do
+  SResponse{..} <- protectedWith hdrs tkn mth url (JSON.encode jsonV)
+  case JSON.eitherDecode simpleBody of
+    Left err -> Prelude.fail $ "protectedJSON failed when parsing " <> show (typeRep $ Proxy @a) <> ": " <> err
+    Right x  -> pure x
+
 protectedWith :: [Network.HTTP.Types.Header]
               -> Token
               -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
 protectedWith extraHeaders tkn mth url payload =
-  request mth url ([ (hAccept, "application/json;charset=utf-8")
-                  , (hContentType, "application/json")
-                  , (hAuthorization, "Bearer " <> TE.encodeUtf8 tkn)
-                  ] <> extraHeaders) payload
+  -- Using a map means that if any of the extra headers contains a clashing header name,
+  -- the extra headers will take precedence.
+  let defaultHeaders = [ (hAccept, "application/json;charset=utf-8")
+                       , (hContentType, "application/json")
+                       , (hAuthorization, "Bearer " <> TE.encodeUtf8 tkn)
+                       ]
+      hdrs = Map.toList $ Map.fromList $ defaultHeaders <> extraHeaders
+  in request mth url hdrs payload
 
 protectedNewError :: Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
 protectedNewError tkn mth url = protectedWith newErrorFormat tkn mth url
@@ -59,6 +89,17 @@ getJSON :: ByteString -> WaiSession () SResponse
 getJSON url =
   request "GET" url [(hContentType, "application/json")] ""
 
+postJSONUrlEncoded :: forall a. (JSON.FromJSON a, Typeable a)
+                   => Token
+                   -> ByteString
+                   -> L.ByteString
+                   -> WaiSession () a
+postJSONUrlEncoded tkn url queryPaths = do
+  SResponse{..} <- protectedWith [(hContentType, "application/x-www-form-urlencoded")] tkn "POST" url queryPaths
+  case JSON.eitherDecode simpleBody of
+    Left err -> Prelude.fail $ "postJSONUrlEncoded failed when parsing " <> show (typeRep $ Proxy @a) <> ": " <> err <> "\nPayload was: " <> (C8L.unpack simpleBody)
+    Right x  -> pure x
+
 withValidLogin :: (MonadFail m, MonadIO m) => Wai.Port -> Username -> GargPassword -> (Token -> m a) -> m a
 withValidLogin port ur pwd act = do
   baseUrl <- liftIO $ parseBaseUrl "http://localhost"

test/Test/API/UpdateList.hs

+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NumericUnderscores #-}
+
+module Test.API.UpdateList (
+    tests
+  ) where
+
+import Data.Aeson qualified as JSON
+import Data.Aeson.QQ
+import Data.ByteString.Lazy qualified as BL
+import Data.String (fromString)
+import Data.Text qualified as T
+import Data.Text.Encoding 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.Core.Types.Individu
+import Gargantext.Database.Action.User
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus
+import Gargantext.Database.Admin.Types.Node
+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 Prelude (error)
+import Test.API.Private (withValidLogin, protectedJSON, postJSONUrlEncoded)
+import Test.API.Setup (withTestDBAndPort, setupEnvironment, mkUrl, createAliceAndBob)
+import Test.Database.Types
+import Test.Hspec
+import Test.Hspec.Wai.Internal (withApplication, WaiSession)
+import Web.FormUrlEncoded
+
+data JobPollHandle = JobPollHandle {
+    _jph_id     :: !Text
+  , _jph_log    :: [JobLog]
+  , _jph_status :: !Text
+  , _jph_error  :: !(Maybe Text)
+    }
+
+instance JSON.FromJSON JobPollHandle where
+  parseJSON = JSON.withObject "JobPollHandle" $ \o -> do
+    _jph_id     <- o JSON..: "id"
+    _jph_log    <- o JSON..: "log"
+    _jph_status <- o JSON..: "status"
+    _jph_error  <- o JSON..:? "error"
+    pure JobPollHandle{..}
+
+instance JSON.ToJSON JobPollHandle where
+  toJSON JobPollHandle{..} = JSON.object [
+      "id"      JSON..= JSON.toJSON _jph_id
+    , "log"     JSON..= JSON.toJSON _jph_log
+    , "status"  JSON..= JSON.toJSON _jph_status
+    , "error"   JSON..= JSON.toJSON _jph_error
+    ]
+
+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
+
+-- | Poll the given URL every second until it finishes.
+-- Retries up to 60 times (i.e. for 1 minute, before giving up)
+pollUntilFinished :: Token -> Wai.Port -> (JobPollHandle -> Builder) -> JobPollHandle -> WaiSession () JobPollHandle
+pollUntilFinished tkn port mkUrlPiece = go 60
+  where
+   go :: Int -> JobPollHandle -> WaiSession () JobPollHandle
+   go 0 h  = error $ T.unpack $ "pollUntilFinished exhausted attempts. Last found JobPollHandle: " <> T.decodeUtf8 (BL.toStrict $ JSON.encode h)
+   go n h = case _jph_status h == "IsPending" || _jph_status h == "IsRunning" of
+    True -> do
+      liftIO $ threadDelay 1_000_000
+      h' <- protectedJSON tkn "GET" (mkUrl port $ mkUrlPiece h) ""
+      go (n-1) h'
+    False -> pure h
+
+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") $ \token -> do
+            ([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> (fromString $ show $ _NodeId 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/"  <> (fromString $ show $ _NodeId listId) <> "/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 jsonFileFormData)
+            j' <- pollUntilFinished token port mkPollUrl j
+            liftIO (_jph_status j' `shouldBe` "IsFinished")

test/Test/Utils.hs

@@ -10,6 +10,7 @@ import Data.Aeson
 import Data.Aeson.QQ.Simple (aesonQQ)
 import Data.Char (isSpace)
 import Language.Haskell.TH.Quote
+import Network.HTTP.Types
 import Network.Wai.Test
 import Prelude
 import Test.Hspec.Expectations
@@ -17,6 +18,7 @@ import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Test.Hspec.Wai.Matcher
 import Test.Tasty.HUnit
+import qualified Data.Aeson as JSON
 import qualified Data.ByteString.Char8 as B
 import qualified Data.HashMap.Strict as HM
 
@@ -65,6 +67,14 @@ instance FromValue JsonFragmentResponseMatcher where
       breakAt c = fmap (B.drop 1) . B.break (== c)
       strip = B.reverse . B.dropWhile isSpace . B.reverse . B.dropWhile isSpace
 
+shouldRespondWithJSON :: (FromJSON a, ToJSON a, HasCallStack)
+                      => WaiSession st a
+                      -> JsonFragmentResponseMatcher
+                      -> WaiExpectation st
+shouldRespondWithJSON action matcher = do
+  r <- action
+  forM_ (match (SResponse status200 mempty (JSON.encode r)) (getJsonMatcher matcher)) (liftIO . expectationFailure)
+
 containsJSON :: Value -> MatchBody
 containsJSON expected = MatchBody matcher
   where