content: --------------------------------------------------------------------------------
  -- | The server part of the tests
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE PatternGuards     #-}
  module Main
      ( main
      ) where
  
  
  --------------------------------------------------------------------------------
  import           Control.Exception          (catch)
  import           Control.Monad              (forM_, forever, void)
  import           Control.Monad.Trans        (liftIO)
  import           Data.ByteString            (ByteString)
  import           Data.ByteString.Lazy.Char8 ()
  import           Data.Text                  (Text)
  import qualified Data.Text.Lazy             as TL
  import qualified Network.WebSockets         as WS
  
  
  --------------------------------------------------------------------------------
  echoText :: WS.Connection -> IO ()
  echoText conn = forever $ do
      msg <- WS.receiveData conn
      liftIO $ putStrLn $ show (msg :: TL.Text)
      WS.sendTextData conn msg
  
  
  --------------------------------------------------------------------------------
  closeMe :: WS.Connection -> IO ()
  closeMe conn = do
      msg <- WS.receiveData conn
      case (msg :: TL.Text) of
          "Close me!" -> do
              WS.sendClose conn ("Closing" :: ByteString)
              void $ WS.receiveDataMessage conn
              error "Expecting receiveDataMessage to throw CloseRequest exception"
          _           -> error "closeme: unexpected input"
  
  
  --------------------------------------------------------------------------------
  ping :: WS.Connection -> IO ()
  ping conn = do
      forM_ ["Hai", "Come again?", "Right!"] $ \msg -> do
          WS.send conn $ WS.ControlMessage $ WS.Ping msg
          rsp <- WS.receive conn
          case rsp of
              WS.ControlMessage (WS.Pong msg')
                  | msg' == msg -> return ()
                  | otherwise   -> error "wrong message from client"
              _ -> error "ping: client closed socket too soon"
  
      WS.sendTextData conn ("OK" :: Text)
  
  
  --------------------------------------------------------------------------------
  echo :: WS.Connection -> IO ()
  echo conn = forever $ WS.receive conn >>= WS.send conn
  
  
  --------------------------------------------------------------------------------
  tests :: [(ByteString, WS.Connection -> IO ())]
  tests =
      [ ("/echo-text",   echoText)
      , ("/close-me",    closeMe)
      , ("/ping",        ping)
      , ("/echo",        echo)
      , ("/subprotocol", echoText)
      ]
  
  
  --------------------------------------------------------------------------------
  -- | Application
  application :: WS.ServerApp
  application pc = do
      let name = WS.requestPath rq
      -- When a client succesfully connects, lookup the requested test and
      -- run it
      conn <- case name of
          "/subprotocol" -> WS.acceptRequestWith pc $ WS.defaultAcceptRequest
              {WS.acceptSubprotocol =  Just "abc"}
          _ -> WS.acceptRequest pc
      -- version'' <- WS.getVersion
      liftIO $ putStrLn $ "==================================="
      liftIO $ putStrLn $ "Requested client version: " ++ show version'
      -- liftIO $ putStrLn $ "Selected version: " ++ version''
      liftIO $ putStrLn $ "Requested subprotocols: " ++ show (WS.getRequestSubprotocols rq)
      liftIO $ putStrLn $ "Starting test " ++ show name
      let Just test = lookup name tests in test conn `catch` handleClose
      liftIO $ putStrLn $ "Test " ++ show name ++ " finished"
    where
      rq       = WS.pendingRequest pc
      version' = lookup "Sec-WebSocket-Version" (WS.requestHeaders rq)
      handleClose (WS.CloseRequest i msg) =
          putStrLn $ "Recevied close request " ++ 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.runServerWith "0.0.0.0" 8000 options application
    where
      options = WS.defaultConnectionOptions
  