Client: raise RequestRejected on 400, attach response body, add test

src/Network/WebSockets/Http.hs

@@ -100,7 +100,7 @@ data HandshakeException
     | MalformedResponse ResponseHead String
     -- | The request was well-formed, but the library user rejected it.
     -- (e.g. "unknown path")
-    | RequestRejected Request String
+    | RequestRejected RequestHead ResponseHead
     -- | for example "EOF came too early" (which is actually a parse error)
     -- or for your own errors. (like "unknown path"?)
     | OtherHandshakeException String

src/Network/WebSockets/Hybi13.hs

@@ -78,6 +78,8 @@ finishResponse request response = do
     -- - Switching Protocols
     --
     -- But we don't check it for now
+    when (responseCode response == 400) $ Left $
+        RequestRejected request response 
     when (responseCode response /= 101) $ Left $
         MalformedResponse response "Wrong response status or message."
 

tests/haskell/Network/WebSockets/Server/Tests.hs

@@ -40,6 +40,7 @@ tests = testGroup "Network.WebSockets.Server.Tests"
     , testCase "bulk server/client"   testBulkServerClient
     , testCase "onPong"               testOnPong
     , testCase "ipv6 server"          testIpv6Server
+    , testCase "reject request"       testRejectRequest 
     ]
 
 
@@ -81,7 +82,29 @@ testServerClient host sendMessages = withEchoServer host 42940 "Bye" $ do
         expectCloseException conn "Bye"
         return texts'
 
+--------------------------------------------------------------------------------
+testRejectRequest :: Assertion
+testRejectRequest = withRejectingServer
+  where
+    client :: ClientApp ()
+    client _ = error "Client should not be able to connect"
 
+    server :: ServerApp
+    server pendingConnection = rejectRequest pendingConnection "Bye"
+
+    withRejectingServer :: IO ()
+    withRejectingServer = do
+        serverThread <- async $ runServer "127.0.0.1" 42940 server
+        waitSome
+        () <- runClient "127.0.0.1" 42940 "/chat" client `catch` handler
+        waitSome
+        cancel serverThread
+        return ()
+
+    handler :: HandshakeException -> IO ()
+    handler (RequestRejected _ response) = do
+        responseCode response @=? 400
+    handler exc  = error $ "Unexpected exception " ++ show exc
 
 --------------------------------------------------------------------------------
 testOnPong :: Assertion