[tests] add draft for websocket tests

gargantext.cabal

@@ -1053,6 +1053,7 @@ test-suite garg-test-hspec
       Test.API.Authentication
       Test.API.Errors
       Test.API.GraphQL
+      Test.API.Notifications
       Test.API.Private
       Test.API.Routes
       Test.API.Setup
@@ -1132,6 +1133,7 @@ test-suite garg-test-hspec
     , wai
     , wai-extra
     , warp
+    , websockets
 
 benchmark garg-bench
   main-is:       Main.hs

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

@@ -178,6 +178,15 @@ instance FromJSON WSRequest where
          pure $ WSAuthorize token
       "deauthorize" -> pure $ WSDeauthorize
       s -> prependFailure "parsing request type failed, " (typeMismatch "request" s)
+-- | For tests mainly
+instance ToJSON WSRequest where
+  toJSON (WSSubscribe topic) = Aeson.object [ "request" .= ( "subscribe":: Text )
+                                            , "topic" .= topic ]
+  toJSON (WSUnsubscribe topic) = Aeson.object [ "request" .= ( "unsubscribe" :: Text )
+                                              , "topic" .= topic ]
+  toJSON (WSAuthorize token) = Aeson.object [ "request" .= ( "authorize" :: Text )
+                                            , "token" .= token ]
+  toJSON WSDeauthorize = Aeson.object [ "request" .= ( "deauthorize" :: Text ) ]
     
 data Dispatcher =
  Dispatcher { d_subscriptions :: SSet.Set Subscription

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

@@ -142,6 +142,6 @@ getWSKey pc = do
   -- Sec-WebSocket-Key so we want to make that even more unique.
   uuid <- liftBase $ UUID.nextRandom
   let key = key' <> "-" <> show uuid
-  -- liftBase $ putText $ show $ WS.requestHeaders reqHead
+  liftBase $ putText $ "[getWSKey] request headers: " <> (show $ WS.requestHeaders reqHead)
 
   pure key

test/Test/API.hs

@@ -6,6 +6,7 @@ import Test.Hspec
 import qualified Test.API.Authentication as Auth
 import qualified Test.API.Errors as Errors
 import qualified Test.API.GraphQL as GraphQL
+import qualified Test.API.Notifications as Notifications
 import qualified Test.API.Private as Private
 import qualified Test.API.UpdateList as UpdateList
 
@@ -16,3 +17,6 @@ tests = describe "API" $ do
   GraphQL.tests
   Errors.tests
   UpdateList.tests
+  -- | TODO This would work if I managed to get forking dispatcher &
+  --   exchange listeners properly
+  -- Notifications.tests

test/Test/API/Setup.hs

@@ -4,6 +4,8 @@
 module Test.API.Setup where
 
 -- import Gargantext.Prelude (printDebug)
+import Control.Concurrent (forkIO, killThread)
+import Control.Exception (bracket)
 import Control.Lens
 import Control.Monad.Reader
 import Gargantext.API (makeApp)
@@ -14,6 +16,7 @@ import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
 import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D
+import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DT
 import Gargantext.Core.NLP
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Types.Individu
@@ -96,6 +99,28 @@ withGargApp app action = do
 withTestDBAndPort :: (((TestEnv, Warp.Port), Application) -> IO ()) -> IO ()
 withTestDBAndPort action =
   withTestDB $ \testEnv -> do
+    -- TODO Despite being cautious here only to start/kill dispatcher
+    -- & exchange, I still get nanomsg bind errors, which means these
+    -- are spawned before previous ones are killed. I guess one could
+    -- randomize ports for nanomsg...
+    
+    -- let setup = do
+    --       withLoggerHoisted Mock $ \ioLogger -> do
+    --         env <- newTestEnv testEnv ioLogger 8080
+    --         !central_exchange <- forkIO CE.gServer
+    --         !dispatcher <- D.dispatcher
+    --         let env' = env { _env_central_exchange = central_exchange
+    --                        , _env_dispatcher = dispatcher }
+    --         app <- makeApp env'
+    --         pure (app, env')
+    -- let teardown (_app, env) = do
+    --       killThread (DT.d_ce_listener $ _env_dispatcher env)
+    --       killThread (_env_central_exchange env)
+
+    -- bracket setup teardown $ \(app, _env) -> do
+    --   withGargApp app $ \port ->
+    --     action ((testEnv, port), app)
+    
     app <- withLoggerHoisted Mock $ \ioLogger -> do
              env <- newTestEnv testEnv ioLogger 8080
              makeApp env

test/drivers/hspec/Main.hs

@@ -41,12 +41,14 @@ stopCoreNLPServer :: ProcessHandle -> IO ()
 stopCoreNLPServer = interruptProcessGroupOf
 
 
+startNotifications :: IO (ThreadId, DT.Dispatcher)
 startNotifications = do
   central_exchange <- forkIO CE.gServer
   dispatcher <- D.dispatcher
 
   pure (central_exchange, dispatcher)
 
+stopNotifications :: (ThreadId, DT.Dispatcher) -> IO ()
 stopNotifications (central_exchange, dispatcher) = do
   killThread central_exchange
   killThread $ DT.d_ce_listener dispatcher
@@ -65,6 +67,8 @@ stopNotifications (central_exchange, dispatcher) = do
 main :: IO ()
 main = do
   hSetBuffering stdout NoBuffering
+  -- TODO Ideally remove start/stop notifications and use
+  -- Test/API/Setup to initialize this in env
   bracket startNotifications stopNotifications $ \_ -> do
     bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
       API.tests