1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.WebSockets.Server.Tests
( tests
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, killThread,
threadDelay)
import Control.Exception (SomeException, handle)
import Control.Monad (forM_, forever, replicateM)
import Data.IORef (newIORef, readIORef,
writeIORef)
--------------------------------------------------------------------------------
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
import System.Random (newStdGen)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assert, (@=?))
import Test.QuickCheck (Arbitrary, arbitrary)
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.Random (newQCGen)
--------------------------------------------------------------------------------
import Network.WebSockets
import Network.WebSockets.Tests.Util
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Network.WebSockets.Server.Tests"
[ testCase "simple server/client" testSimpleServerClient
, testCase "onPong" testOnPong
]
--------------------------------------------------------------------------------
testSimpleServerClient :: Assertion
testSimpleServerClient = withEchoServer 42940 $ do
texts <- map unArbitraryUtf8 <$> sample
texts' <- retry $ runClient "127.0.0.1" 42940 "/chat" $ client texts
texts @=? texts'
where
client :: [BL.ByteString] -> ClientApp [BL.ByteString]
client texts conn = do
forM_ texts (sendTextData conn)
texts' <- replicateM (length texts) (receiveData conn)
sendClose conn ("Bye" :: BL.ByteString)
return texts'
--------------------------------------------------------------------------------
testOnPong :: Assertion
testOnPong = withEchoServer 42941 $ do
gotPong <- newIORef False
let opts = defaultConnectionOptions
{ connectionOnPong = writeIORef gotPong True
}
rcv <- runClientWith "127.0.0.1" 42941 "/" opts [] client
assert rcv
assert =<< readIORef gotPong
where
client :: ClientApp Bool
client conn = do
sendPing conn ("What's a fish without an eye?" :: Text)
sendTextData conn ("A fsh!" :: Text)
msg <- receiveData conn
return $ "A fsh!" == (msg :: Text)
--------------------------------------------------------------------------------
sample :: Arbitrary a => IO [a]
sample = do
gen <- newQCGen
return $ (unGen arbitrary) gen 512
--------------------------------------------------------------------------------
waitSome :: IO ()
waitSome = threadDelay $ 200 * 1000
--------------------------------------------------------------------------------
-- HOLY SHIT WHAT SORT OF ATROCITY IS THIS?!?!?!
--
-- The problem is that sometimes, the server hasn't been brought down yet
-- before the next test, which will cause it not to be able to bind to the
-- same port again. In this case, we just retry.
--
-- The same is true for our client: possibly, the server is not up yet
-- before we run the client. We also want to retry in that case.
retry :: IO a -> IO a
retry action = (\(_ :: SomeException) -> waitSome >> action) `handle` action
--------------------------------------------------------------------------------
withEchoServer :: Int -> IO a -> IO a
withEchoServer port action = do
serverThread <- forkIO $ retry $ runServer "0.0.0.0" port server
waitSome
result <- action
waitSome
killThread serverThread
return result
where
server :: ServerApp
server pc = do
conn <- acceptRequest pc
forever $ do
msg <- receiveDataMessage conn
sendDataMessage conn msg
|
