Merge remote-tracking branch 'origin/adinapoli/issue-287' into dev

gargantext.cabal

@@ -28,6 +28,8 @@ 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/ngrams/simple.csv
     test-data/phylo/bpa_phylo_test.json
     test-data/phylo/open_science.json
     test-data/test_config.ini
@@ -58,6 +60,8 @@ library
       Gargantext.API.Errors.Types.Backend
       Gargantext.API.HashedResponse
       Gargantext.API.Ngrams
+      Gargantext.API.Ngrams.List
+      Gargantext.API.Ngrams.List.Types
       Gargantext.API.Ngrams.Prelude
       Gargantext.API.Ngrams.Tools
       Gargantext.API.Ngrams.Types
@@ -186,8 +190,6 @@ library
       Gargantext.API.Job
       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
@@ -445,6 +447,7 @@ library
     , fgl ^>= 5.7.0.3
     , filelock ^>= 0.1.1.5
     , filepath ^>= 1.4.2.1
+    , fmt
     , formatting ^>= 7.1.3
     , full-text-search ^>= 0.2.1.4
     , fullstop ^>= 0.1.4
@@ -974,10 +977,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
@@ -992,6 +997,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
@@ -1010,6 +1016,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
@@ -1042,6 +1049,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
@@ -1080,6 +1088,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
@@ -1099,6 +1108,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/Admin/EnvTypes.hs

@@ -165,7 +165,9 @@ instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
 
 -- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
 -- constructor it's not exported, to not leak internal details of its implementation.
-data ConcreteJobHandle err = JobHandle {
+data ConcreteJobHandle err =
+    ConcreteNullHandle
+  | JobHandle {
       _jh_id     :: !(SJ.JobID 'SJ.Safe)
     , _jh_logger :: LoggerM (GargM Env err) JobLog
     }
@@ -179,6 +181,7 @@ mkJobHandle jId = JobHandle jId
 
 -- | Updates the status of a 'JobHandle' by using the input 'updateJobStatus' function.
 updateJobProgress :: ConcreteJobHandle err -> (JobLog -> JobLog) -> GargM Env err ()
+updateJobProgress ConcreteNullHandle _ = pure ()
 updateJobProgress hdl@(JobHandle _ logStatus) updateJobStatus =
   Jobs.getLatestJobStatus hdl >>= logStatus . updateJobStatus
 
@@ -189,6 +192,9 @@ instance Jobs.MonadJobStatus (GargM Env err) where
   type JobOutputType  (GargM Env err) = JobLog
   type JobEventType   (GargM Env err) = JobLog
 
+  noJobHandle Proxy = ConcreteNullHandle
+
+  getLatestJobStatus ConcreteNullHandle = pure noJobLog
   getLatestJobStatus (JobHandle jId _) = do
     mb_jb <- Jobs.findJob jId
     case mb_jb of
@@ -203,6 +209,7 @@ instance Jobs.MonadJobStatus (GargM Env err) where
                                    EmptyL -> noJobLog
                                    l :< _ -> l
 
+  withTracer _ ConcreteNullHandle f  = f ConcreteNullHandle
   withTracer extraLogger (JobHandle jId logger) n = n (JobHandle jId (\w -> logger w >> liftIO (extraLogger w)))
 
   markStarted n jh = updateJobProgress jh (const $ jobLogStart (RemainingSteps n))
@@ -276,6 +283,8 @@ instance Jobs.MonadJobStatus (GargM DevEnv err) where
   type JobOutputType  (GargM DevEnv err) = JobLog
   type JobEventType   (GargM DevEnv err) = JobLog
 
+  noJobHandle Proxy = DevJobHandle
+
   getLatestJobStatus DevJobHandle = pure noJobLog
 
   withTracer _ DevJobHandle n = n DevJobHandle

src/Gargantext/Database/Admin/Types/Node.hs

@@ -35,6 +35,7 @@ import Data.Time (UTCTime)
 import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
 import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
 import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
+import Fmt
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
 import Gargantext.Database.Schema.Context
 import Gargantext.Database.Schema.Node
@@ -250,6 +251,9 @@ newtype NodeId = UnsafeMkNodeId { _NodeId :: Int }
 instance ResourceId NodeId where
   isPositive = (> 0) . _NodeId
 
+instance Buildable NodeId where
+  build (UnsafeMkNodeId nid) = build nid
+
 instance GQLType NodeId
 instance Prelude.Show NodeId where
   show (UnsafeMkNodeId n) = "nodeId-" <> show n

src/Gargantext/Utils/Jobs.hs

@@ -50,13 +50,16 @@ serveJobsAPI
    , MonadJobStatus m
    , m ~ (GargM Env BackendInternalError)
    , JobEventType m ~ JobOutputType m
+   , MonadLogger m
    )
   => JobType m
   -> (JobHandle m -> input -> m ())
   -> SJ.AsyncJobsServerT' ctI ctO callbacks (JobEventType m) input (JobOutputType m) m
 serveJobsAPI jobType f = Internal.serveJobsAPI mkJobHandle ask jobType jobErrorToGargError $ \env jHandle i -> do
-  putStrLn ("Running job of type: " ++ show jobType)
-  runExceptT $ runReaderT (f jHandle i >> getLatestJobStatus jHandle) env
+  runExceptT $ flip runReaderT env $ do
+    $(logLocM) INFO (T.pack $ "Running job of type: " ++ show jobType)
+    f jHandle i
+    getLatestJobStatus jHandle
 
 parseGargJob :: String -> Maybe GargJob
 parseGargJob s = case s of

src/Gargantext/Utils/Jobs/Monad.hs

@@ -44,6 +44,7 @@ import Prelude
 
 import qualified Servant.Job.Core as SJ
 import qualified Servant.Job.Types as SJ
+import Data.Proxy
 
 data JobEnv t w a = JobEnv
   { jeSettings :: JobSettings
@@ -188,6 +189,11 @@ class MonadJobStatus m where
   type JobOutputType  m :: Type
   type JobEventType   m :: Type
 
+  -- | A job handle that doesn't do anything. Sometimes useful in all those circumstances
+  -- where we need to test a function taking a 'JobHandle' as input but we are not interested
+  -- in the progress tracking.
+  noJobHandle :: Proxy m -> JobHandle m
+
   -- | Retrevies the latest 'JobEventType' from the underlying monad. It can be
   -- used to query the latest status for a particular job, given its 'JobHandle' as input.
   getLatestJobStatus :: JobHandle m -> m (JobEventType m)

test-data/ngrams/simple.csv

+status	label	forms
+map	abelian group	
+stop	brazorf	

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/GraphQL.hs

@@ -32,4 +32,4 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
           withValidLogin port "alice" (GargPassword "alice") $ \token -> do
             protected token "POST" "/gql" [r| {
                "query": "{ user_infos(user_id: 2) { ui_id, ui_email } }"
-               } |] `shouldRespondWith'` [jsonFragment| {"data":{"user_infos":[{"ui_id":2,"ui_email":"alice@gargan.text"}]}} |]
+               } |] `shouldRespondWithFragment` [jsonFragment| {"data":{"user_infos":[{"ui_id":2,"ui_email":"alice@gargan.text"}]}} |]

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 ()
@@ -35,29 +38,72 @@ import Test.API.Setup (withTestDBAndPort, setupEnvironment, mkUrl, createAliceAn
 import Test.Hspec
 import Test.Hspec.Wai hiding (pendingWith)
 import Test.Hspec.Wai.Internal (withApplication)
-import Test.Utils (jsonFragment, shouldRespondWith')
+import Test.Utils (jsonFragment, shouldRespondWithFragment)
+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 :: HasCallStack
+          => Token
+          -> Method
+          -> ByteString
+          -> L.ByteString
+          -> WaiSession () SResponse
 protected tkn mth url = protectedWith mempty tkn mth url
 
-protectedWith :: [Network.HTTP.Types.Header]
+protectedJSON :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
+              => Token
+              -> Method
+              -> ByteString
+              -> JSON.Value
+              -> WaiSession () a
+protectedJSON tkn mth url = protectedJSONWith mempty tkn mth url
+
+protectedJSONWith :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
+                  => [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 :: HasCallStack
+              => [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
-
-protectedNewError :: Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
+  -- 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 :: HasCallStack => Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
 protectedNewError tkn mth url = protectedWith newErrorFormat tkn mth url
   where
     newErrorFormat = [(CI.mk "X-Garg-Error-Scheme", "new")]
 
-getJSON :: ByteString -> WaiSession () SResponse
-getJSON url =
-  request "GET" url [(hContentType, "application/json")] ""
+getJSON :: Token -> ByteString -> WaiSession () SResponse
+getJSON tkn url = protectedWith mempty tkn "GET" url ""
+
+postJSONUrlEncoded :: forall a. (JSON.FromJSON a, Typeable a, HasCallStack)
+                   => 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
@@ -119,7 +165,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \token -> do
             protected token "GET" (mkUrl port "/node/8") ""
-              `shouldRespondWith'` [jsonFragment| {"id":8,"user_id":2,"name":"alice" } |]
+              `shouldRespondWithFragment` [jsonFragment| {"id":8,"user_id":2,"name":"alice" } |]
 
       it "forbids 'alice' to see others node private info" $ \((_testEnv, port), app) -> do
         withApplication app $ do
@@ -135,7 +181,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \token -> do
             protected token "GET" (mkUrl port "/tree/8") ""
-              `shouldRespondWith'` [jsonFragment| { "node": {"id":8, "name":"alice", "type": "NodeUser" } } |]
+              `shouldRespondWithFragment` [jsonFragment| { "node": {"id":8, "name":"alice", "type": "NodeUser" } } |]
 
       it "forbids 'alice' to see others node private info" $ \((_testEnv, port), app) -> do
         withApplication app $ do

test/Test/API/UpdateList.hs

+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ViewPatterns #-}
+
+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.API.Ngrams.List ( ngramsListFromCSVData )
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types
+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.Database.Schema.Ngrams
+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, getJSON)
+import Test.API.Setup (withTestDBAndPort, setupEnvironment, mkUrl, createAliceAndBob)
+import Test.Database.Types
+import Test.Hspec
+import Test.Hspec.Wai.Internal (withApplication, WaiSession)
+import Test.Hspec.Wai.JSON (json)
+import Test.Hspec.Wai (shouldRespondWith)
+import Web.FormUrlEncoded
+import qualified Data.Map.Strict as Map
+
+data JobPollHandle = JobPollHandle {
+    _jph_id     :: !Text
+  , _jph_log    :: [JobLog]
+  , _jph_status :: !Text
+  , _jph_error  :: !(Maybe Text)
+    } deriving Show
+
+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 :: HasCallStack
+                  => 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
+     | _jph_status h == "IsFailure"
+     -> error $ T.unpack $ "JobPollHandle contains a failure: " <> T.decodeUtf8 (BL.toStrict $ JSON.encode h)
+     | otherwise
+     -> 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/" <> 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")
+
+            -- 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": []
+                                                }
+                                            ]
+                                        } |]
+
+    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.csv")
+        ngramsListFromCSVData 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") $ \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.csv")
+            let tsvFileFormData = [ (T.pack "_wtf_data", simpleNgrams)
+                                  , ("_wtf_filetype", "CSV")
+                                  , ("_wtf_name", "simple.csv")
+                                  ]
+            let url         = "/lists/"  <> (fromString $ show $ _NodeId listId) <> "/csv/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":[]}
+                                           ]
+                                         } |]
+

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
 
@@ -39,11 +41,14 @@ jsonFragment = QuasiQuoter {
 
 newtype JsonFragmentResponseMatcher = JsonFragmentResponseMatcher { getJsonMatcher :: ResponseMatcher }
 
-shouldRespondWith' :: HasCallStack
-                   => WaiSession st SResponse
-                   -> JsonFragmentResponseMatcher
-                   -> WaiExpectation st
-shouldRespondWith' action matcher = do
+-- | Succeeds if the full body matches the input /fragment/. Careful in using this
+-- combinator, as it won't check that the full body matches the input, but rather
+-- that the body contains the input fragment, which might lead to confusion.
+shouldRespondWithFragment :: HasCallStack
+                          => WaiSession st SResponse
+                          -> JsonFragmentResponseMatcher
+                          -> WaiExpectation st
+shouldRespondWithFragment action matcher = do
   r <- action
   forM_ (match r (getJsonMatcher matcher)) (liftIO . expectationFailure)
 
@@ -65,6 +70,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