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
|
--------------------------------------------------------------------------------
-- | The server part of the tests
{-# LANGUAGE OverloadedStrings #-}
module Main
( main
) where
{-
## once
virtualenv pyt
source pyt/bin/activate
### pip install --upgrade setuptools ### possibly
pip install autobahntestsuite
## each time
source pyt/bin/activate
mkdir -p test && cd test
wstest -m fuzzingclient
websockets-autobahn
-}
--------------------------------------------------------------------------------
import Control.Exception (catch)
import Data.ByteString.Lazy.Char8 ()
import Data.String (fromString)
import Data.Version (showVersion)
--------------------------------------------------------------------------------
import qualified Network.WebSockets as WS
import qualified Paths_websockets
--------------------------------------------------------------------------------
echoDataMessage :: WS.Connection -> IO ()
echoDataMessage conn = go 0
where
go :: Int -> IO ()
go x = do
msg <- WS.receiveDataMessage conn
WS.sendDataMessage conn msg
go (x + 1)
--------------------------------------------------------------------------------
infoHeaders :: WS.Headers
infoHeaders =
[ ( "Server"
, fromString $ "websockets/" ++ showVersion Paths_websockets.version
)
]
--------------------------------------------------------------------------------
-- | Application
application :: WS.ServerApp
application pc = do
conn <- WS.acceptRequestWith pc WS.defaultAcceptRequest
{ WS.acceptHeaders = infoHeaders
}
echoDataMessage conn `catch` handleClose
where
handleClose (WS.CloseRequest i "") =
putStrLn $ "Clean close (" ++ show i ++ ")"
handleClose (WS.CloseRequest i msg) =
putStrLn $ "Clean close (" ++ show i ++ "): " ++ show msg
handleClose WS.ConnectionClosed =
putStrLn "Unexpected connection closed exception"
handleClose (WS.ParseException e) =
putStrLn $ "Recevied parse exception: " ++ show e
handleClose (WS.UnicodeException e) =
putStrLn $ "Recevied unicode exception: " ++ show e
--------------------------------------------------------------------------------
-- | Accepts clients, spawns a single handler for each one.
main :: IO ()
main = WS.runServerWithOptions options application
where
options = WS.defaultServerOptions
{ WS.serverHost = "0.0.0.0"
, WS.serverPort = 9001
, WS.serverConnectionOptions = WS.defaultConnectionOptions
{ WS.connectionCompressionOptions =
WS.PermessageDeflateCompression WS.defaultPermessageDeflate
, WS.connectionStrictUnicode = True
}
}
|
