Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
strip out \r with httpd-shed
  • Loading branch information
hsenag committed May 1, 2012
1 parent f06b3ea commit c769f2f
Show file tree
Hide file tree
Showing 2 changed files with 9 additions and 7 deletions.
6 changes: 5 additions & 1 deletion test/Httpd.hs
Expand Up @@ -7,6 +7,7 @@ module Httpd
where where


import Control.Applicative import Control.Applicative
import Control.Arrow ( (***) )
import Control.Monad import Control.Monad
import Control.Monad.Trans ( lift ) import Control.Monad.Trans ( lift )
import Data.ByteString as B ( empty, concat ) import Data.ByteString as B ( empty, concat )
Expand Down Expand Up @@ -59,12 +60,15 @@ shed port handler =
where where
responseToShed (Response status hdrs body) = responseToShed (Response status hdrs body) =
Shed.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 = requestFromShed request =
Request Request
{ {
reqMethod = Shed.reqMethod request, reqMethod = Shed.reqMethod request,
reqURI = Shed.reqURI request, reqURI = Shed.reqURI request,
reqHeaders = Shed.reqHeaders request, reqHeaders = map (id *** chomp) $ Shed.reqHeaders request,
reqBody = Shed.reqBody request reqBody = Shed.reqBody request
} }


Expand Down
10 changes: 4 additions & 6 deletions test/httpTests.hs
Expand Up @@ -59,7 +59,7 @@ basicPostRequest = do
assertEqual "HTTP status code" (2, 0, 0) code assertEqual "HTTP status code" (2, 0, 0) code
body <- getResponseBody response body <- getResponseBody response
assertEqual "Receiving expected response" assertEqual "Receiving expected response"
(show (Just "text/plain\r", Just "4\r", sendBody)) (show (Just "text/plain", Just "4", sendBody))
body body


basicAuthFailure :: Assertion basicAuthFailure :: Assertion
Expand Down Expand Up @@ -400,7 +400,7 @@ processRequest req = do


("GET", "/auth/basic") -> ("GET", "/auth/basic") ->
case lookup "Authorization" (Httpd.reqHeaders req) of 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) x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x)


("GET", "/auth/digest") -> ("GET", "/auth/digest") ->
Expand Down Expand Up @@ -430,8 +430,7 @@ processRequest req = do
return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] "" return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] ""
("GET", "/browser/one-cookie/2") -> ("GET", "/browser/one-cookie/2") ->
case lookup "Cookie" (Httpd.reqHeaders req) of case lookup "Cookie" (Httpd.reqHeaders req) of
-- TODO: is it correct to expect the \r at the end? Just "hello=world" -> return $ Httpd.mkResponse 200 [] ""
Just "hello=world\r" -> return $ Httpd.mkResponse 200 [] ""
Just s -> return $ Httpd.mkResponse 500 [] s Just s -> return $ Httpd.mkResponse 500 [] s
Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)
("GET", "/browser/two-cookies/1") -> ("GET", "/browser/two-cookies/1") ->
Expand All @@ -441,9 +440,8 @@ processRequest req = do
"" ""
("GET", "/browser/two-cookies/2") -> ("GET", "/browser/two-cookies/2") ->
case lookup "Cookie" (Httpd.reqHeaders req) of 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 -- 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 Just s -> return $ Httpd.mkResponse 500 [] s
Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)
("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->
Expand Down

0 comments on commit c769f2f

Please sign in to comment.