From e44483669618c13d47895154905d4025e0635e9f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Domen=20Ko=C5=BEar?= <domen@dev.si>
Date: Thu, 21 Dec 2023 17:19:56 +0000
Subject: [PATCH] Client: raise RequestRejected on 400, attach response body,
 add test

---
 src/Network/WebSockets/Http.hs                |  2 +-
 src/Network/WebSockets/Hybi13.hs              |  2 ++
 .../Network/WebSockets/Server/Tests.hs        | 23 +++++++++++++++++++
 3 files changed, 26 insertions(+), 1 deletion(-)

diff --git a/src/Network/WebSockets/Http.hs b/src/Network/WebSockets/Http.hs
index 62622bc..2194f4e 100644
--- a/src/Network/WebSockets/Http.hs
+++ b/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
diff --git a/src/Network/WebSockets/Hybi13.hs b/src/Network/WebSockets/Hybi13.hs
index 344ff8b..43b0df9 100644
--- a/src/Network/WebSockets/Hybi13.hs
+++ b/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."
 
diff --git a/tests/haskell/Network/WebSockets/Server/Tests.hs b/tests/haskell/Network/WebSockets/Server/Tests.hs
index b124ce1..86bc147 100644
--- a/tests/haskell/Network/WebSockets/Server/Tests.hs
+++ b/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