[tests] add missing files

src/Gargantext/Core/Viz/Types.hs

@@ -5,13 +5,12 @@ module Gargantext.Core.Viz.Types where
 import Data.Aeson.TH (deriveJSON)
 import Data.Swagger
 import Data.Vector (Vector)
-import qualified Data.Vector as V
+import Data.Vector qualified as V
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Protolude
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
-
 ---------------
 -- | Chart | --
 ---------------

test/Test/API/Notifications.hs

+{-|
+Module      : Test.API.Notifications
+Description : Tests for the notification mechanism (central exchange, dispatcher, websockets)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# OPTIONS_GHC -Wno-orphans  #-}
+
+{-# LANGUAGE QuasiQuotes #-}
+    
+module Test.API.Notifications (
+    tests
+  ) where
+
+import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Concurrent.STM.TChan qualified as TChan
+import Control.Monad.STM (atomically)
+import Data.Aeson qualified as Aeson
+import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
+import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DT
+import Network.WebSockets.Client qualified as WS
+import Network.WebSockets.Connection qualified as WS
+import Prelude
+import System.Timeout qualified as Timeout
+import Test.API.Setup (withTestDBAndPort)  -- , setupEnvironment, createAliceAndBob)
+import Test.Hspec
+import Test.Instances ()
+import Text.RawString.QQ (r)
+
+
+tests :: Spec
+tests = sequential $ aroundAll withTestDBAndPort $ do
+  describe "Dispatcher, Central Exchange, WebSockets" $ do
+    it "simple WS notification works" $ \((_testEnv, port), _) -> do
+      tchan <- TChan.newTChanIO
+      -- setup a websocket connection
+      let wsConnect = do
+            putStrLn $ "Creating WS client (port " <> show port <> ")"
+            WS.runClient "127.0.0.1" port "/ws" $ \conn -> do
+              WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe $ DT.UpdateTree 0)
+              d <- WS.receiveData conn
+              atomically $ TChan.writeTChan tchan (Aeson.eitherDecode d)
+            putStrLn "After WS client"
+            
+      -- wait a bit to settle
+      putStrLn "settling a bit initially"
+      threadDelay 1000000
+    
+      putStrLn "forking wsConnection"
+      wsConnection <- forkIO $ wsConnect
+      
+      -- wait a bit to connect
+      threadDelay 1000000
+      putStrLn "settling a bit for connection"
+      threadDelay 1000000
+
+      let msg = CET.UpdateTreeFirstLevel 0
+      putStrLn "Notifying CE"
+      CE.notify msg
+
+      putStrLn "Reading tvar with timeout"
+      d <- Timeout.timeout 1000000 (atomically $ TChan.readTChan tchan)
+      putStrLn "Killing wsConnection thread" 
+      killThread wsConnection
+
+      putStrLn "Checking d" 
+
+      d `shouldBe` (Just $ Right msg)

test/Test/Instances.hs

+{-|
+Module      : Test.Instances
+Description : Instances for test data
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Test.Instances where
+
+import EPO.API.Client.Types qualified as EPO
+import Gargantext.API.Node.Corpus.New (ApiInfo(..))
+import Gargantext.API.Node.Types (RenameNode(..), WithQuery(..))
+import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
+import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DET
+import Gargantext.Prelude
+import Servant.Job.Core qualified as SJ
+import Servant.Job.Types qualified as SJ
+import Test.QuickCheck
+
+
+
+smallLetter :: [Char]
+smallLetter = ['a'..'z']
+
+largeLetter :: [Char]
+largeLetter = ['A'..'Z']
+
+digit :: [Char]
+digit = ['0'..'9']
+
+alphanum :: [Char]
+alphanum = smallLetter <> largeLetter <> digit
+
+
+instance Arbitrary EPO.AuthKey where
+  arbitrary = do
+    user <- arbitrary
+    token <- arbitrary
+    pure $ EPO.AuthKey { .. }
+
+instance Arbitrary EPO.User where
+  arbitrary = EPO.User <$> arbitrary
+
+instance Arbitrary EPO.Token where
+  arbitrary = EPO.Token <$> arbitrary
+
+
+instance Arbitrary ApiInfo where
+  arbitrary = ApiInfo <$> arbitrary
+
+
+instance Arbitrary WithQuery where
+  arbitrary = do
+    _wq_query <- arbitrary
+    _wq_databases <- arbitrary
+    _wq_datafield <- arbitrary
+    _wq_lang <- arbitrary
+    _wq_node_id <- arbitrary
+    _wq_flowListWith <- arbitrary
+    _wq_pubmedAPIKey <- arbitrary
+    _wq_epoAPIUser <- arbitrary
+    _wq_epoAPIToken <- arbitrary
+    pure $ WithQuery { .. }
+
+
+-- Servant job
+instance Arbitrary a => Arbitrary (SJ.JobOutput a) where
+  arbitrary = SJ.JobOutput <$> arbitrary
+
+instance Arbitrary RenameNode where
+  arbitrary = elements [RenameNode "test"]
+  
+instance Arbitrary SJ.States where
+  arbitrary = oneof $ pure <$> [ SJ.IsPending
+                               , SJ.IsReceived
+                               , SJ.IsStarted
+                               , SJ.IsRunning
+                               , SJ.IsKilled
+                               , SJ.IsFailure
+                               , SJ.IsFinished ]
+
+
+instance Arbitrary (SJ.ID 'SJ.Safe k) where
+  arbitrary = do
+    _id_type <- arbitrary
+    _id_number <- arbitrary
+    _id_time <- arbitrary
+    _id_token <- arbitrary
+    pure $ SJ.PrivateID { .. }
+
+instance Arbitrary a => Arbitrary (SJ.JobStatus 'SJ.Safe a) where
+  arbitrary = do
+    _job_id <- arbitrary
+    _job_log <- arbitrary
+    _job_status <- arbitrary
+    _job_error <- arbitrary
+    pure $ SJ.JobStatus { .. }
+deriving instance Eq a => Eq (SJ.JobStatus 'SJ.Safe a)
+
+
+-- Notifications
+instance Arbitrary CET.CEMessage where
+  arbitrary = oneof [
+    -- | JobStatus to/from json doesn't work
+    -- CET.UpdateJobProgress <$> arbitrary  -
+      CET.UpdateTreeFirstLevel <$> arbitrary
+     ]
+deriving instance Eq CET.CEMessage
+
+instance Arbitrary DET.Topic where
+  arbitrary = oneof [
+    -- | JobStatus to/from json doesn't work
+    -- DET.UpdateJobProgress <$> arbitrary
+      DET.UpdateTree <$> arbitrary
+      ]
+
+instance Arbitrary DET.Message where
+  arbitrary = oneof [
+    -- | JobStatus to/from json doesn't work
+    -- DET.MJobProgress <$> arbitrary
+      pure DET.MEmpty
+      ]
+
+instance Arbitrary DET.WSRequest where
+  arbitrary = oneof [ DET.WSSubscribe <$> arbitrary
+                    , DET.WSUnsubscribe <$> arbitrary
+                    , DET.WSAuthorize <$> arbitrary
+                    , pure DET.WSDeauthorize ]