Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

strip out \r with httpd-shed

  • Loading branch information...
commit c769f2f0eb785669f9b173a6048ad08fdeb4e4ca 1 parent f06b3ea
@hsenag hsenag authored
Showing with 9 additions and 7 deletions.
  1. +5 −1 test/Httpd.hs
  2. +4 −6 test/httpTests.hs
View
6 test/Httpd.hs
@@ -7,6 +7,7 @@ module Httpd
where
import Control.Applicative
+import Control.Arrow ( (***) )
import Control.Monad
import Control.Monad.Trans ( lift )
import Data.ByteString as B ( empty, concat )
@@ -59,12 +60,15 @@ shed port handler =
where
responseToShed (Response status hdrs body) =
Shed.Response status hdrs body
+ chomp = reverse . strip '\r' . reverse
+ strip c (c':str) | c == c' = str
+ strip c str = str
requestFromShed request =
Request
{
reqMethod = Shed.reqMethod request,
reqURI = Shed.reqURI request,
- reqHeaders = Shed.reqHeaders request,
+ reqHeaders = map (id *** chomp) $ Shed.reqHeaders request,
reqBody = Shed.reqBody request
}
View
10 test/httpTests.hs
@@ -59,7 +59,7 @@ basicPostRequest = do
assertEqual "HTTP status code" (2, 0, 0) code
body <- getResponseBody response
assertEqual "Receiving expected response"
- (show (Just "text/plain\r", Just "4\r", sendBody))
+ (show (Just "text/plain", Just "4", sendBody))
body
basicAuthFailure :: Assertion
@@ -400,7 +400,7 @@ processRequest req = do
("GET", "/auth/basic") ->
case lookup "Authorization" (Httpd.reqHeaders req) of
- Just "Basic dGVzdDpwYXNzd29yZA==\r" -> return $ Httpd.mkResponse 200 [] "Here's the secret"
+ Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret"
x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x)
("GET", "/auth/digest") ->
@@ -430,8 +430,7 @@ processRequest req = do
return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] ""
("GET", "/browser/one-cookie/2") ->
case lookup "Cookie" (Httpd.reqHeaders req) of
- -- TODO: is it correct to expect the \r at the end?
- Just "hello=world\r" -> return $ Httpd.mkResponse 200 [] ""
+ Just "hello=world" -> return $ Httpd.mkResponse 200 [] ""
Just s -> return $ Httpd.mkResponse 500 [] s
Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)
("GET", "/browser/two-cookies/1") ->
@@ -441,9 +440,8 @@ processRequest req = do
""
("GET", "/browser/two-cookies/2") ->
case lookup "Cookie" (Httpd.reqHeaders req) of
- -- TODO: is it correct to expect the \r at the end?
-- TODO generalise the cookie parsing to allow for whitespace/ordering variations
- Just "goodbye=cruelworld; hello=world\r" -> return $ Httpd.mkResponse 200 [] ""
+ Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] ""
Just s -> return $ Httpd.mkResponse 500 [] s
Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)
("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->
Please sign in to comment.
Something went wrong with that request. Please try again.