git.iko.soy/project-m36
on master help sign in
add websocket server test
commitd3922183d9ba3becac2545246b822ab371d0b419 authorAgentM <agentm@themactionfaction.com> dateFri 5 Aug 2016, 17:19 (10 years ago) parent4706bbb
2 files changed+104−1
compare with master
unifiedsplit
project-m36.cabal+16−1 test/Server/WebSocket.hs+88
project-m36.cabal+16−1
@@ -609,7 +609,7 @@ Test-Suite test-scripts
609609Executable project-m36-websocket-server
610610 Default-Language: Haskell2010
611611 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, unix, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template, websockets, aeson, uuid-aeson, optparse-applicative
612− Main-Is: ProjectM36/Server/WebSocket.hs
612+ Main-Is: ProjectM36/Server/WebSocket/Main.hs
613613 GHC-Options: -Wall
614614 CPP-Options: -DPROJECTM36_VERSION="v0.1"
615615 Default-Extensions: OverloadedStrings
@@ -620,3 +620,18 @@ Executable project-m36-websocket-server
620620 C-sources: ProjectM36/DirectoryFsync.c
621621 Build-Depends: unix
622622
623+Test-Suite test-websocket-server
624+ Default-Language: Haskell2010
625+ type: exitcode-stdio-1.0
626+ main-is: test/Server/WebSocket.hs
627+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson
628+ Other-Modules: ProjectM36.Atom, ProjectM36.AtomFunction, ProjectM36.AtomType, ProjectM36.Attribute, ProjectM36.AttributeNames, ProjectM36.Base, ProjectM36.ConcreteTypeRep, ProjectM36.DataConstructorDef, ProjectM36.DataTypes.Primitive, ProjectM36.Error, ProjectM36.Key, ProjectM36.MiscUtils, ProjectM36.Relation, ProjectM36.RelationalExpression, ProjectM36.StaticOptimizer, ProjectM36.Tuple, ProjectM36.TupleSet, ProjectM36.TypeConstructor, ProjectM36.TypeConstructorDef, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types
629+ Default-Extensions: OverloadedStrings
630+ GHC-Options: -Wall
631+ CPP-Options: -DPROJECTM36_VERSION="v0.1"
632+ if os(windows)
633+ Build-Depends: Win32 >= 2.3 && < 2.4
634+ Other-Modules: ProjectM36.Win32Handle
635+ else
636+ C-sources: ProjectM36/DirectoryFsync.c
637+ Build-Depends: unix
test/Server/WebSocket.hsnew file+88
@@ -0,0 +1,88 @@
1+-- test the websocket server
2+
3+import Test.HUnit
4+import qualified Network.WebSockets as WS
5+import ProjectM36.Server.WebSocket
6+import ProjectM36.Server.Config
7+import ProjectM36.Server
8+import ProjectM36.Client
9+import Network.Socket
10+import Control.Exception
11+import Control.Concurrent
12+import System.Exit
13+import Data.Typeable
14+import Data.Text hiding (map)
15+import Data.Aeson
16+import ProjectM36.Base
17+import qualified Data.Map as M
18+import qualified Data.ByteString.Lazy as BS
19+import ProjectM36.Relation
20+
21+--start the websocket server
22+-- run some tutoriald against it
23+
24+launchTestServer :: IO (PortNumber, DatabaseName)
25+launchTestServer = do
26+ portMVar <- newEmptyMVar
27+ let config = defaultServerConfig { databaseName = testDatabaseName }
28+ testDatabaseName = "test"
29+ -- start normal server
30+ _ <- forkIO (launchServer config (Just portMVar) >> pure ())
31+ serverPort <- takeMVar portMVar
32+ let serverHost = "127.0.0.1"
33+ let testPort = 8889
34+ -- start websocket server proxy -- runServer doesn't support returning an arbitrary socket
35+ _ <- forkIO (WS.runServer serverHost testPort (websocketProxyServer serverPort serverHost))
36+ --wait for socket to be listening
37+ waitForListenSocket 5 (fromIntegral testPort)
38+ pure (fromIntegral testPort, testDatabaseName)
39+
40+data TestException = WaitForSocketListenException
41+ deriving (Show, Typeable)
42+
43+instance Exception TestException
44+
45+waitForListenSocket :: Int -> PortNumber -> IO ()
46+waitForListenSocket secondsToTry port = do
47+ if secondsToTry <= 0 then
48+ throw WaitForSocketListenException
49+ else do
50+ hostaddr <- inet_addr "127.0.0.1"
51+ sock <- socket AF_INET Stream defaultProtocol
52+ let handler :: IOException -> IO ()
53+ handler = \_ -> do
54+ threadDelay 1000000
55+ waitForListenSocket (secondsToTry - 1) port
56+ catch (connect sock (SockAddrInet port hostaddr)) handler
57+
58+main :: IO ()
59+main = do
60+ (port, dbname) <- launchTestServer
61+ tcounts <- runTestTT (testList port dbname)
62+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
63+
64+testList :: PortNumber -> DatabaseName -> Test
65+testList port dbName = TestList $ map (\f -> f port dbName) [testBasicConnection,
66+ testTutorialD]
67+
68+basicConnection :: PortNumber -> WS.ClientApp () -> IO ()
69+basicConnection port block = WS.runClient "127.0.0.1" (fromIntegral port) "/" block
70+
71+basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO ()
72+basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do
73+ WS.sendTextData conn ("connectdb:" `append` (pack dbname))
74+ block conn)
75+
76+testBasicConnection :: PortNumber -> DatabaseName -> Test
77+testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn ("test close"::Text))
78+
79+testTutorialD :: PortNumber -> DatabaseName -> Test
80+testTutorialD port dbname = TestCase $ basicConnectionWithDatabase port dbname testtutd
81+ where
82+ testtutd = \conn -> do
83+ WS.sendTextData conn ("executetutd:" `append` ":showexpr true")
84+ response <- WS.receiveData conn :: IO BS.ByteString
85+ let decoded = decode response :: Maybe (M.Map Text Relation)
86+ case decoded of
87+ Just val -> assertEqual "round-trip true relation" (M.lookup "displayrelation" val) (Just relationTrue) >> WS.sendClose conn ("test close"::Text)
88+ Nothing -> assertFailure "failed to decode relation"