[tests] add aeson tests, some test fixes

gargantext.cabal

@@ -836,6 +836,7 @@ common testDependencies
     , crawlerArxiv
     , cryptohash
     , directory
+    , epo-api-client
     , extra ^>= 1.7.9
     , fast-logger ^>= 3.0.5
     , fmt
@@ -874,6 +875,7 @@ common testDependencies
     , servant-client-core
     , servant-job
     , servant-server
+    , servant-websockets >= 2.0.0 && < 2.1
     , shelly >= 1.9 && < 2
     , split
     , stm ^>= 2.5.0.1
@@ -898,6 +900,27 @@ common testDependencies
     , wai
     , wai-extra
     , warp
+    , servant-websockets >= 2.0.0 && < 2.1
+    , shelly >= 1.9 && < 2
+    , stm ^>= 2.5.0.1
+    , streaming-commons
+    , tasty ^>= 1.4.2.1
+    , tasty-hspec
+    , tasty-hunit
+    , tasty-quickcheck
+    , tasty-smallcheck
+    , template-haskell
+    , text ^>= 1.2.4.1
+    , time ^>= 1.9.3
+    , tmp-postgres >= 1.34.1 && < 1.35
+    , tree-diff
+    , unliftio
+    , unordered-containers ^>= 0.2.16.0
+    , validity ^>= 0.11.0.1
+    , wai
+    , wai-extra
+    , warp
+    , websockets
 
 test-suite garg-test-tasty
   import:
@@ -906,8 +929,9 @@ test-suite garg-test-tasty
   type: exitcode-stdio-1.0
   main-is: drivers/tasty/Main.hs
   other-modules:
-      Test.API.Routes
       CLI.Phylo.Common
+      Paths_gargantext
+      Test.API.Routes
       Test.API.Setup
       Test.Core.AsyncUpdates
       Test.Core.Similarity
@@ -924,6 +948,7 @@ test-suite garg-test-tasty
       Test.Database.Types
       Test.Graph.Clustering
       Test.Graph.Distance
+      Test.Instances
       Test.Ngrams.Lang
       Test.Ngrams.Lang.En
       Test.Ngrams.Lang.Fr
@@ -944,85 +969,9 @@ test-suite garg-test-tasty
       Test.Utils
       Test.Utils.Crypto
       Test.Utils.Jobs
-      Paths_gargantext
   hs-source-dirs:
       test bin/gargantext-cli
   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      QuickCheck ^>= 2.14.2
-    , aeson ^>= 1.5.6.0
-    , aeson-pretty ^>= 0.8.9
-    , aeson-qq
-    , async ^>= 2.2.4
-    , boolexpr ^>= 0.2
-    , bytestring ^>= 0.10.12.0
-    , case-insensitive
-    , conduit ^>= 1.3.4.2
-    , containers ^>= 0.6.5.1
-    , crawlerArxiv
-    , cryptohash
-    , directory
-    , extra ^>= 1.7.9
-    , fast-logger ^>= 3.0.5
-    , fmt
-    , gargantext
-    , gargantext-prelude
-    , graphviz ^>= 2999.20.1.0
-    , hspec ^>= 2.7.10
-    , hspec-core
-    , 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
-    , lens >= 5.2.2 && < 5.3
-    , monad-control >= 1.0.3 && < 1.1
-    , mtl ^>= 2.2.2
-    , network-uri
-    , parsec ^>= 3.1.14.0
-    , patches-class ^>= 0.1.0.1
-    , patches-map ^>= 0.1.0.1
-    , postgres-options >= 0.2 && < 0.3
-    , postgresql-simple >= 0.6.4 && < 0.7
-    , pretty
-    , process ^>= 1.6.13.2
-    , quickcheck-instances ^>= 0.3.25.2
-    , raw-strings-qq
-    , recover-rtti >= 0.4 && < 0.5
-    , resource-pool >= 0.2.3.2 && < 0.2.4
-    -- , servant >= 0.18.3 && < 0.20
-    , servant-auth
-    , servant-auth-client
-    , servant-client
-    , servant-client-core
-    , servant-job
-    , servant-server
-    , servant-websockets >= 2.0.0 && < 2.1
-    , shelly >= 1.9 && < 2
-    , stm ^>= 2.5.0.1
-    , streaming-commons
-    , split
-    , tasty ^>= 1.4.2.1
-    , tasty-golden
-    , tasty-hspec
-    , tasty-hunit
-    , tasty-quickcheck
-    , tasty-smallcheck
-    , template-haskell
-    , text ^>= 1.2.4.1
-    , time ^>= 1.9.3
-    , tmp-postgres >= 1.34.1 && < 1.35
-    , tree-diff
-    , unordered-containers ^>= 0.2.16.0
-    , unicode-collation >= 0.1.3.6
-    , unliftio
-    , validity ^>= 0.11.0.1
-    , vector ^>= 0.12.3.0
-    , wai
-    , wai-extra
-    , warp
 
 test-suite garg-test-hspec
   import:
@@ -1053,73 +1002,6 @@ test-suite garg-test-hspec
   hs-source-dirs:
       test
   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      QuickCheck ^>= 2.14.2
-    , aeson ^>= 1.5.6.0
-    , aeson-qq
-    , async ^>= 2.2.4
-    , boolexpr ^>= 0.2
-    , bytestring ^>= 0.10.12.0
-    , case-insensitive
-    , conduit ^>= 1.3.4.2
-    , containers ^>= 0.6.5.1
-    , crawlerArxiv
-    , extra ^>= 1.7.9
-    , fast-logger ^>= 3.0.5
-    , fmt
-    , gargantext
-    , gargantext-prelude
-    , hspec ^>= 2.7.10
-    , hspec-core
-    , 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
-    , lens >= 5.2.2 && < 5.3
-    , monad-control >= 1.0.3 && < 1.1
-    , mtl ^>= 2.2.2
-    , network-uri
-    , parsec ^>= 3.1.14.0
-    , patches-class ^>= 0.1.0.1
-    , patches-map ^>= 0.1.0.1
-    , postgres-options >= 0.2 && < 0.3
-    , postgresql-simple >= 0.6.4 && < 0.7
-    , process ^>= 1.6.13.2
-    , quickcheck-instances ^>= 0.3.25.2
-    , raw-strings-qq
-    , recover-rtti >= 0.4 && < 0.5
-    , resource-pool >= 0.2.3.2 && < 0.2.4
-    -- , servant >= 0.18.3 && < 0.20
-    , servant-auth
-    , servant-auth-client
-    , servant-client
-    , servant-client-core
-    , servant-job
-    , servant-server
-    , servant-websockets >= 2.0.0 && < 2.1
-    , shelly >= 1.9 && < 2
-    , stm ^>= 2.5.0.1
-    , streaming-commons
-    , tasty ^>= 1.4.2.1
-    , tasty-hspec
-    , tasty-hunit
-    , tasty-quickcheck
-    , tasty-smallcheck
-    , template-haskell
-    , text ^>= 1.2.4.1
-    , time ^>= 1.9.3
-    , tmp-postgres >= 1.34.1 && < 1.35
-    , tree-diff
-    , unliftio
-    , unordered-containers ^>= 0.2.16.0
-    , validity ^>= 0.11.0.1
-    , wai
-    , wai-extra
-    , warp
-    , websockets
 
 benchmark garg-bench
   main-is:       Main.hs

src/Gargantext/API/Admin/Orchestrator/Types.hs

@@ -22,12 +22,6 @@ import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 
 ------------------------------------------------------------------------
-instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
-  arbitrary = panicTrace "TODO"
-
-instance Arbitrary a => Arbitrary (JobOutput a) where
-  arbitrary = JobOutput <$> arbitrary
-
 -- | Main Types
 -- TODO IsidoreAuth
 data ExternalAPIs = OpenAlex

src/Gargantext/API/Node/Corpus/New.hs

@@ -60,7 +60,6 @@ import Gargantext.Prelude
 import Gargantext.Core.Config (gc_max_docs_parsers)
 import Gargantext.System.Logging ( logLocM, LogLevel(..) )
 import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
-import Test.QuickCheck.Arbitrary (Arbitrary(..))
 
 ------------------------------------------------------------------------
 {-
@@ -120,8 +119,6 @@ api uid (Query q _ as) = do
 -- TODO use this route for Client implementation
 data ApiInfo = ApiInfo { api_info :: [API.ExternalAPIs]}
   deriving (Generic)
-instance Arbitrary ApiInfo where
-  arbitrary = ApiInfo <$> arbitrary
 
 deriveJSON (unPrefix "") 'ApiInfo
 

src/Gargantext/API/Node/Types.hs

@@ -29,7 +29,6 @@ import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
 import Gargantext.Database.GargDB qualified as GargDB
 import Gargantext.Prelude
 import Servant.Job.Utils (jsonOptions)
-import Test.QuickCheck
 import Web.FormUrlEncoded          (FromForm, ToForm)
 
 -------------------------------------------------------
@@ -104,25 +103,12 @@ instance ToJSON WithQuery where
 instance ToSchema WithQuery where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wq_")
 
-instance Arbitrary WithQuery where
-  arbitrary = WithQuery <$> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-                        <*> arbitrary
-
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
   deriving (Generic)
 
 $(deriveJSON (unPrefix "r_"       ) ''RenameNode )
 instance ToSchema  RenameNode
-instance Arbitrary RenameNode where
-  arbitrary = elements [RenameNode "test"]
 
 data NodesToScore = NodesToScore { nts_nodesId :: [NodeId]
                                  , nts_score :: Int

src/Gargantext/Core/AsyncUpdates/CentralExchange/Types.hs

@@ -25,7 +25,7 @@ import Gargantext.Core.Types (NodeId)
 import Gargantext.Prelude
 import Prelude qualified
 import Servant.Job.Core (Safety(Safe))
-import Servant.Job.Types (JobStatus(_job_id))
+import Servant.Job.Types (JobStatus)
     
 {-
 
@@ -39,11 +39,6 @@ various events).
 data CEMessage =
     UpdateJobProgress (JobStatus 'Safe JobLog)
   | UpdateTreeFirstLevel NodeId
--- | This is for testing
-instance Eq CEMessage where
-  (==) (UpdateJobProgress js1) (UpdateJobProgress js2) = _job_id js1 == _job_id js2
-  (==) (UpdateTreeFirstLevel n1) (UpdateTreeFirstLevel n2) = n1 == n2
-  (==) _ _ = False
 instance Prelude.Show CEMessage where
   show (UpdateJobProgress js) = "UpdateJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode js)
   show (UpdateTreeFirstLevel nodeId) = "UpdateTreeFirstLevel " <> show nodeId
@@ -58,11 +53,10 @@ instance FromJSON CEMessage where
         node_id <- o .: "node_id"
         pure $ UpdateTreeFirstLevel node_id
       s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
-
 instance ToJSON CEMessage where
   toJSON (UpdateJobProgress js) = object [
-      "type"    .= toJSON ("update_job_progress" :: Text)
-      , "js" .= toJSON js
+        "type" .= toJSON ("update_job_progress" :: Text)
+      , "js"   .= toJSON js
     ]
   toJSON (UpdateTreeFirstLevel node_id) = object [
       "type"    .= toJSON ("update_tree_first_level" :: Text)

src/Gargantext/Core/AsyncUpdates/Dispatcher/Types.hs

@@ -47,7 +47,7 @@ import Servant
 import Servant.API.WebSocket qualified as WS
 import Servant.Auth.Server (verifyJWT)
 import Servant.Job.Core (Safety(Safe))
-import Servant.Job.Types (JobID, JobStatus)
+import Servant.Job.Types (JobID, JobStatus(_job_id))
 import Servant.Server.Generic (AsServer, AsServerT)
 import StmContainers.Set as SSet
 
@@ -94,6 +94,11 @@ instance ToJSON Topic where
 data Message =
     MJobProgress (JobStatus 'Safe JobLog)
   | MEmpty
+-- | For tests
+instance Eq Message where
+  (==) (MJobProgress js1) (MJobProgress js2) = _job_id js1 == _job_id js2
+  (==) MEmpty MEmpty = True
+  (==) _ _ = False
 instance Prelude.Show Message where
   show (MJobProgress jobStatus) = "MJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode jobStatus)
   show MEmpty = "MEmpty"
@@ -105,6 +110,15 @@ instance ToJSON Message where
   toJSON MEmpty = Aeson.object [
       "type" .= toJSON ("MEmpty" :: Text)  
     ]
+instance FromJSON Message where
+  parseJSON = Aeson.withObject "Message" $ \o -> do
+    type_ <- o .: "type"
+    case type_ of
+      "MJobProgress" -> do
+        job_status <- o .: "job_status"
+        pure $ MJobProgress job_status
+      "MEmpty" -> pure MEmpty
+      s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
 
     
 data ConnectedUser =

test/Test/Core/AsyncUpdates.hs

@@ -9,12 +9,20 @@ Portability : POSIX
 
 -}
 
-module Test.Core.AsyncUpdates where
+module Test.Core.AsyncUpdates
+  ( test
+  , qcTests )
+where
 
 import Data.Aeson qualified as A
 import Gargantext.Core.AsyncUpdates.CentralExchange.Types
+import Gargantext.Core.AsyncUpdates.Dispatcher.Types
 import Gargantext.Prelude
 import Test.Hspec
+import Test.Instances ()
+import Test.Tasty
+import Test.Tasty.QuickCheck qualified as QC
+
 
 test :: Spec
 test = do
@@ -22,3 +30,11 @@ test = do
     it "UpdateTreeFirstLevel serialization" $ do
       let ce = UpdateTreeFirstLevel 15
       A.decode (A.encode ce) `shouldBe` (Just ce)
+
+qcTests :: TestTree
+qcTests =
+  testGroup "Notifications QuickCheck tests" $ do
+    [ QC.testProperty "CEMessage aeson encoding" $ \m -> A.decode (A.encode (m :: CEMessage)) == Just m
+      , QC.testProperty "Topic aeson encoding" $ \t -> A.decode (A.encode (t :: Topic)) == Just t
+      , QC.testProperty "Message aeson encoding" $ \m -> A.decode (A.encode (m :: Message)) == Just m
+      , QC.testProperty "WSRequest aeson encoding" $ \ws -> A.decode (A.encode (ws :: WSRequest)) == Just ws ]

test/Test/Offline/JSON.hs

@@ -18,6 +18,7 @@ import Gargantext.Core.Types.Phylo
 import Gargantext.Database.Admin.Types.Node
 import Paths_gargantext
 import Prelude
+import Test.Instances ()
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck

test/Test/Utils.hs

@@ -32,6 +32,7 @@ import Network.Wai.Test (SResponse(..))
 import Prelude qualified
 import Servant.Client (ClientEnv, baseUrlPort, defaultMakeClientRequest, makeClientRequest, mkClientEnv, parseBaseUrl, runClientM)
 import Servant.Client.Core.Request (addHeader)
+import System.Timeout qualified as Timeout
 import Test.API.Routes (auth_api, mkUrl)
 import Test.Hspec.Expectations
 import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
@@ -227,3 +228,22 @@ pollUntilFinished tkn port mkUrlPiece = go 60
 (@??=) :: (HasCallStack, ToExpr a, Eq a) => a -> a -> Assertion
 actual @??= expected =
   assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
+
+
+-- | Given a predicate IO action, test it for given number of
+-- milliseconds or fail
+waitUntil :: HasCallStack => IO Bool -> Int -> Expectation
+waitUntil pred' timeoutMs = do
+  _mTimeout <- Timeout.timeout (timeoutMs * 1000) performTest
+  -- shortcut for testing mTimeout
+  p <- pred'
+  unless p (expectationFailure "Predicate test failed")
+  
+  where
+    performTest = do
+      p <- pred'
+      if p
+        then return ()
+        else do
+          threadDelay 50
+          performTest

test/Test/Utils/Jobs.hs

@@ -42,6 +42,7 @@ import Servant.Job.Types qualified as SJ
 import System.IO.Unsafe
 import Test.Hspec
 import Test.Hspec.Expectations.Contrib (annotate)
+import Test.Utils (waitUntil)
 
 
 data JobT = A
@@ -62,8 +63,9 @@ addJobToSchedule jobt mvar = do
 data Counts = Counts { countAs :: Int, countBs :: Int }
   deriving (Eq, Show)
 
+-- | In ms
 jobDuration :: Int
-jobDuration = 100000
+jobDuration = 100
 
 type Timer = TVar Bool
 
@@ -167,9 +169,10 @@ testPrios = do
 
   -- wait for the jobs to finish, waiting for more than the total duration,
   -- so that we are sure that all jobs have finished, then check the schedule.
-  threadDelay jobDuration
-  finalSchedule <- readMVar pickedSchedule
-  finalSchedule `shouldBe` JobSchedule (fromList [B, D, C, A])
+  -- threadDelay jobDuration
+  waitUntil (do
+    finalSchedule <- readMVar pickedSchedule
+    pure $ finalSchedule == JobSchedule (fromList [B, D, C, A])) jobDuration
 
 testExceptions :: IO ()
 testExceptions = do
@@ -210,9 +213,10 @@ testFairness = do
   atomically $ forM_ (zip [0,2 ..] jobs) $ \(timeDelta, (t, f)) -> void $
     pushJobWithTime (addUTCTime (fromInteger timeDelta) time) t () f settings st
 
-  threadDelay jobDuration
-  finalSchedule <- readMVar pickedSchedule
-  finalSchedule `shouldBe` JobSchedule (fromList [A, A, B, A, A])
+  -- threadDelay jobDuration
+  waitUntil (do
+    finalSchedule <- readMVar pickedSchedule
+    pure $ finalSchedule == JobSchedule (fromList [A, A, B, A, A])) jobDuration
 
 
 newtype MyDummyMonad a =
@@ -300,9 +304,13 @@ testFetchJobStatus = do
     liftIO $ modifyMVar_ evts (\xs -> pure $ mb_status : mb_status' : mb_status'' : xs)
     pure ()
 
-  threadDelay 500_000
+  -- threadDelay 500_000
   -- Check the events
-  readMVar evts >>= \expected -> map _scst_remaining expected `shouldBe` [Nothing, Just 10, Just 5]
+  -- readMVar evts >>= \expected -> map _scst_remaining expected `shouldBe` [Nothing, Just 10, Just 5]
+  waitUntil (do
+    evts' <- readMVar evts
+    pure $ map _scst_remaining evts' == [Nothing, Just 10, Just 5]
+    ) 1000
 
 testFetchJobStatusNoContention :: IO ()
 testFetchJobStatusNoContention = do
@@ -324,10 +332,14 @@ testFetchJobStatusNoContention = do
         pure ()
 
   Async.forConcurrently_ [job1, job2] ($ ())
-  threadDelay 500_000
+  -- threadDelay 500_000
   -- Check the events
-  readMVar evts1 >>= \expected -> map _scst_remaining expected `shouldBe` [Just 100]
-  readMVar evts2 >>= \expected -> map _scst_remaining expected `shouldBe` [Just 50]
+  waitUntil (do
+    evts1' <- readMVar evts1
+    evts2' <- readMVar evts2
+    pure $ (map _scst_remaining evts1' == [Just 100]) &&
+           (map _scst_remaining evts2' == [Just 50])
+            ) 500
 
 testMarkProgress :: IO ()
 testMarkProgress = do

test/drivers/tasty/Main.hs

@@ -58,4 +58,5 @@ main = do
     , Phylo.tests
     , testGroup "Stemming" [ Lancaster.tests ]
     , asyncUpdatesSpec
+    , AsyncUpdates.qcTests
     ]