[tests] add draft for websocket tests

parent c87f2791
Pipeline #6259 failed with stages
...@@ -1053,6 +1053,7 @@ test-suite garg-test-hspec ...@@ -1053,6 +1053,7 @@ test-suite garg-test-hspec
Test.API.Authentication Test.API.Authentication
Test.API.Errors Test.API.Errors
Test.API.GraphQL Test.API.GraphQL
Test.API.Notifications
Test.API.Private Test.API.Private
Test.API.Routes Test.API.Routes
Test.API.Setup Test.API.Setup
...@@ -1132,6 +1133,7 @@ test-suite garg-test-hspec ...@@ -1132,6 +1133,7 @@ test-suite garg-test-hspec
, wai , wai
, wai-extra , wai-extra
, warp , warp
, websockets
benchmark garg-bench benchmark garg-bench
main-is: Main.hs main-is: Main.hs
......
...@@ -178,6 +178,15 @@ instance FromJSON WSRequest where ...@@ -178,6 +178,15 @@ instance FromJSON WSRequest where
pure $ WSAuthorize token pure $ WSAuthorize token
"deauthorize" -> pure $ WSDeauthorize "deauthorize" -> pure $ WSDeauthorize
s -> prependFailure "parsing request type failed, " (typeMismatch "request" s) 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 = data Dispatcher =
Dispatcher { d_subscriptions :: SSet.Set Subscription Dispatcher { d_subscriptions :: SSet.Set Subscription
......
...@@ -142,6 +142,6 @@ getWSKey pc = do ...@@ -142,6 +142,6 @@ getWSKey pc = do
-- Sec-WebSocket-Key so we want to make that even more unique. -- Sec-WebSocket-Key so we want to make that even more unique.
uuid <- liftBase $ UUID.nextRandom uuid <- liftBase $ UUID.nextRandom
let key = key' <> "-" <> show uuid let key = key' <> "-" <> show uuid
-- liftBase $ putText $ show $ WS.requestHeaders reqHead liftBase $ putText $ "[getWSKey] request headers: " <> (show $ WS.requestHeaders reqHead)
pure key pure key
...@@ -6,6 +6,7 @@ import Test.Hspec ...@@ -6,6 +6,7 @@ import Test.Hspec
import qualified Test.API.Authentication as Auth import qualified Test.API.Authentication as Auth
import qualified Test.API.Errors as Errors import qualified Test.API.Errors as Errors
import qualified Test.API.GraphQL as GraphQL 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.Private as Private
import qualified Test.API.UpdateList as UpdateList import qualified Test.API.UpdateList as UpdateList
...@@ -16,3 +17,6 @@ tests = describe "API" $ do ...@@ -16,3 +17,6 @@ tests = describe "API" $ do
GraphQL.tests GraphQL.tests
Errors.tests Errors.tests
UpdateList.tests UpdateList.tests
-- | TODO This would work if I managed to get forking dispatcher &
-- exchange listeners properly
-- Notifications.tests
...@@ -4,6 +4,8 @@ ...@@ -4,6 +4,8 @@
module Test.API.Setup where module Test.API.Setup where
-- import Gargantext.Prelude (printDebug) -- import Gargantext.Prelude (printDebug)
import Control.Concurrent (forkIO, killThread)
import Control.Exception (bracket)
import Control.Lens import Control.Lens
import Control.Monad.Reader import Control.Monad.Reader
import Gargantext.API (makeApp) import Gargantext.API (makeApp)
...@@ -14,6 +16,7 @@ import Gargantext.API.Errors.Types ...@@ -14,6 +16,7 @@ import Gargantext.API.Errors.Types
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D
import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DT
import Gargantext.Core.NLP import Gargantext.Core.NLP
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
...@@ -96,6 +99,28 @@ withGargApp app action = do ...@@ -96,6 +99,28 @@ withGargApp app action = do
withTestDBAndPort :: (((TestEnv, Warp.Port), Application) -> IO ()) -> IO () withTestDBAndPort :: (((TestEnv, Warp.Port), Application) -> IO ()) -> IO ()
withTestDBAndPort action = withTestDBAndPort action =
withTestDB $ \testEnv -> do 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 app <- withLoggerHoisted Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080 env <- newTestEnv testEnv ioLogger 8080
makeApp env makeApp env
......
...@@ -41,12 +41,14 @@ stopCoreNLPServer :: ProcessHandle -> IO () ...@@ -41,12 +41,14 @@ stopCoreNLPServer :: ProcessHandle -> IO ()
stopCoreNLPServer = interruptProcessGroupOf stopCoreNLPServer = interruptProcessGroupOf
startNotifications :: IO (ThreadId, DT.Dispatcher)
startNotifications = do startNotifications = do
central_exchange <- forkIO CE.gServer central_exchange <- forkIO CE.gServer
dispatcher <- D.dispatcher dispatcher <- D.dispatcher
pure (central_exchange, dispatcher) pure (central_exchange, dispatcher)
stopNotifications :: (ThreadId, DT.Dispatcher) -> IO ()
stopNotifications (central_exchange, dispatcher) = do stopNotifications (central_exchange, dispatcher) = do
killThread central_exchange killThread central_exchange
killThread $ DT.d_ce_listener dispatcher killThread $ DT.d_ce_listener dispatcher
...@@ -65,6 +67,8 @@ stopNotifications (central_exchange, dispatcher) = do ...@@ -65,6 +67,8 @@ stopNotifications (central_exchange, dispatcher) = do
main :: IO () main :: IO ()
main = do main = do
hSetBuffering stdout NoBuffering hSetBuffering stdout NoBuffering
-- TODO Ideally remove start/stop notifications and use
-- Test/API/Setup to initialize this in env
bracket startNotifications stopNotifications $ \_ -> do bracket startNotifications stopNotifications $ \_ -> do
bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
API.tests API.tests
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment