git.iko.soy/project-m36
on 0ff751e help sign in
project-m36/test/Server/WebSocket.hs
113 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 checkFS = False}
37 testDatabaseName = "test"
38 -- start normal server
39 _ <- forkIO (launchServer config (Just addressMVar) >> pure ())
40 serverAddress <- takeMVar addressMVar
41 let wsServerHost = "127.0.0.1"
42 wsServerPort = 8889
43 Just (dbHost, dbPort, _) = decodeEndPointAddress serverAddress
44 -- start websocket server proxy -- runServer doesn't support returning an arbitrary socket
45 _ <- forkIO (WS.runServer wsServerHost wsServerPort (websocketProxyServer (read dbPort) dbHost))
46 --wait for socket to be listening
47 waitForListenSocket 5 (fromIntegral wsServerPort)
48 pure (fromIntegral wsServerPort, testDatabaseName)
50data TestException = WaitForSocketListenException
51 deriving (Show, Typeable)
53instance Exception TestException
55waitForListenSocket :: Int -> PortNumber -> IO ()
56waitForListenSocket secondsToTry port =
57 if secondsToTry <= 0 then
58 throw WaitForSocketListenException
59 else do
60 hostaddr <- inet_addr "127.0.0.1"
61 sock <- socket AF_INET Stream defaultProtocol
62 let handler :: IOException -> IO ()
63 handler _ = do
64 threadDelay 1000000
65 waitForListenSocket (secondsToTry - 1) port
66 catch (connect sock (SockAddrInet port hostaddr)) handler
68main :: IO ()
69main = do
70 (port, dbname) <- launchTestServer
71 tcounts <- runTestTT (testList port dbname)
72 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
74testList :: PortNumber -> DatabaseName -> Test
75testList port dbName = TestList $ map (\f -> f port dbName) [testBasicConnection,
76 testTutorialD]
78basicConnection :: PortNumber -> WS.ClientApp () -> IO ()
79basicConnection port = WS.runClient "127.0.0.1" (fromIntegral port) "/"
81basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO ()
82basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do
83 WS.sendTextData conn ("connectdb:" `append` pack dbname)
84 block conn)
86testBasicConnection :: PortNumber -> DatabaseName -> Test
87testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn ("test close"::Text))
89testTutorialD :: PortNumber -> DatabaseName -> Test
90testTutorialD port dbname = TestCase $ basicConnectionWithDatabase port dbname testtutd
91 where
92 discardPromptInfo conn = do
93 response <- WS.receiveData conn :: IO BS.ByteString
94 let decoded = decode response :: Maybe (M.Map Text (M.Map Text Text))
95 case decoded of
96 Just _ -> pure ()
97 Nothing -> assertFailure ("failed to decode prompt info: " ++ show response)
99 testtutd conn = do
100 discardPromptInfo conn
101 WS.sendTextData conn ("executetutd/json:" `append` ":showexpr true")
102 discardPromptInfo conn
103 discardPromptInfo conn
105 --receive relation response
106 response <- WS.receiveData conn :: IO BS.ByteString
107 let decoded = decode response :: Maybe (M.Map Text (M.Map Text Relation))
108 case decoded of
109 Nothing -> assertFailure "failed to decode"
110 Just decoded' -> do
111 assertEqual "round-trip true relation" ((decoded' M.! "displayrelation") M.! "json") relationTrue
112 WS.sendClose conn ("test close" :: Text)