server.hs

--------------------------------------------------------------------------------
-- | 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
            }
        }