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