git.iko.soy/project-m36
on 3add28e help sign in
project-m36/test/Server/WebSocket.hs
114 lines 4.6 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 hostaddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just (show port))
62 sock <- socket AF_INET Stream defaultProtocol
63 let handler :: IOException -> IO ()
64 handler _ = do
65 threadDelay 1000000
66 waitForListenSocket (secondsToTry - 1) port
67 catch (connect sock (addrAddress hostaddr)) handler
69main :: IO ()
70main = do
71 (port, dbname) <- launchTestServer
72 tcounts <- runTestTT (testList port dbname)
73 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
75testList :: PortNumber -> DatabaseName -> Test
76testList port dbName = TestList $ map (\f -> f port dbName) [testBasicConnection,
77 testTutorialD]
79basicConnection :: PortNumber -> WS.ClientApp () -> IO ()
80basicConnection port = WS.runClient "127.0.0.1" (fromIntegral port) "/"
82basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO ()
83basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do
84 WS.sendTextData conn ("connectdb:" `append` pack dbname)
85 block conn)
87testBasicConnection :: PortNumber -> DatabaseName -> Test
88testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn ("test close"::Text))
90testTutorialD :: PortNumber -> DatabaseName -> Test
91testTutorialD port dbname = TestCase $ basicConnectionWithDatabase port dbname testtutd
92 where
93 discardPromptInfo conn = do
94 response <- WS.receiveData conn :: IO BS.ByteString
95 let decoded = decode response :: Maybe (M.Map Text (M.Map Text Text))
96 case decoded of
97 Just _ -> pure ()
98 Nothing -> assertFailure ("failed to decode prompt info: " ++ show response)
100 testtutd conn = do
101 discardPromptInfo conn
102 WS.sendTextData conn ("executetutd/json:" `append` ":showexpr true")
103 discardPromptInfo conn
104 discardPromptInfo conn
106 --receive relation response
107 response <- WS.receiveData conn :: IO BS.ByteString
108 let decoded = decode response :: Maybe (M.Map Text (M.Map Text Relation))
109 case decoded of
110 Nothing -> assertFailure "failed to decode"
111 Just decoded' -> do
112 assertEqual "round-trip true relation" ((decoded' M.! "displayrelation") M.! "json") relationTrue
113 WS.sendClose conn ("test close" :: Text)