git.iko.soy/project-m36
on d64cdeb help sign in
project-m36/test/Server/WebSocket.hs
106 lines 4.3 kB history raw
1-- test the websocket server
2import Test.HUnit
3import qualified Network.WebSockets as WS
4import ProjectM36.Server.WebSocket
5import ProjectM36.Server.Config
6import ProjectM36.Server
7import ProjectM36.Client
8import ProjectM36.Base
10import Network.Socket
11import Control.Exception
12import Control.Concurrent
13import System.Exit
14import Data.Typeable
15import Data.Text hiding (map)
16import Data.Aeson
17import qualified Data.Map as M
18import qualified Data.ByteString.Lazy as BS
19import ProjectM36.Relation
20import Network.Transport.TCP (decodeEndPointAddress)
22--start the websocket server
23-- run some tutoriald against it
25launchTestServer :: IO (PortNumber, DatabaseName)
26launchTestServer = do
27 addressMVar <- newEmptyMVar
28 let config = defaultServerConfig { databaseName = testDatabaseName,
29 bindPort = 0 }
30 testDatabaseName = "test"
31 -- start normal server
32 _ <- forkIO (launchServer config (Just addressMVar) >> pure ())
33 serverAddress <- takeMVar addressMVar
34 let wsServerHost = "127.0.0.1"
35 wsServerPort = 8889
36 Just (dbHost, dbPort, _) = decodeEndPointAddress serverAddress
37 -- start websocket server proxy -- runServer doesn't support returning an arbitrary socket
38 _ <- forkIO (WS.runServer wsServerHost wsServerPort (websocketProxyServer (read dbPort) dbHost))
39 --wait for socket to be listening
40 waitForListenSocket 5 (fromIntegral wsServerPort)
41 pure (fromIntegral wsServerPort, testDatabaseName)
43data TestException = WaitForSocketListenException
44 deriving (Show, Typeable)
46instance Exception TestException
48waitForListenSocket :: Int -> PortNumber -> IO ()
49waitForListenSocket secondsToTry port =
50 if secondsToTry <= 0 then
51 throw WaitForSocketListenException
52 else do
53 hostaddr <- inet_addr "127.0.0.1"
54 sock <- socket AF_INET Stream defaultProtocol
55 let handler :: IOException -> IO ()
56 handler _ = do
57 threadDelay 1000000
58 waitForListenSocket (secondsToTry - 1) port
59 catch (connect sock (SockAddrInet port hostaddr)) handler
61main :: IO ()
62main = do
63 (port, dbname) <- launchTestServer
64 tcounts <- runTestTT (testList port dbname)
65 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
67testList :: PortNumber -> DatabaseName -> Test
68testList port dbName = TestList $ map (\f -> f port dbName) [testBasicConnection,
69 testTutorialD]
71basicConnection :: PortNumber -> WS.ClientApp () -> IO ()
72basicConnection port = WS.runClient "127.0.0.1" (fromIntegral port) "/"
74basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO ()
75basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do
76 WS.sendTextData conn ("connectdb:" `append` pack dbname)
77 block conn)
79testBasicConnection :: PortNumber -> DatabaseName -> Test
80testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn ("test close"::Text))
82testTutorialD :: PortNumber -> DatabaseName -> Test
83testTutorialD port dbname = TestCase $ basicConnectionWithDatabase port dbname testtutd
84 where
85 discardPromptInfo conn = do
86 response <- WS.receiveData conn :: IO BS.ByteString
87 let decoded = decode response :: Maybe (M.Map Text (M.Map Text Text))
88 case decoded of
89 Just _ -> pure ()
90 Nothing -> assertFailure ("failed to decode prompt info: " ++ show response)
92 testtutd conn = do
93 discardPromptInfo conn
94 WS.sendTextData conn ("executetutd/json:" `append` ":showexpr true")
95 discardPromptInfo conn
96 discardPromptInfo conn
98 --receive relation response
99 response <- WS.receiveData conn :: IO BS.ByteString
100 let decoded = decode response :: Maybe (M.Map Text (M.Map Text Relation))
101 case decoded of
102 Nothing -> assertFailure "failed to decode"
103 Just decoded' -> do
104 assertEqual "round-trip true relation" ((decoded' M.! "displayrelation") M.! "json") relationTrue
105 WS.sendClose conn ("test close" :: Text)