Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add Network.HTTP.headRequest helper

  • Loading branch information...
commit 38754f3a6e3eecd2e68e48f255a6ad2c8533ff83 1 parent a9e5fd1
@hsenag hsenag authored
Showing with 21 additions and 0 deletions.
  1. +9 −0 Network/HTTP.hs
  2. +12 −0 test/httpTests.hs
View
9 Network/HTTP.hs
@@ -59,6 +59,7 @@ module Network.HTTP
, module Network.TCP
, getRequest -- :: String -> Request_String
+ , headRequest -- :: String -> Request_String
, postRequest -- :: String -> Request_String
, postRequestWithBody -- :: String -> String -> String -> Request_String
@@ -150,6 +151,14 @@ getRequest urlString =
Nothing -> error ("getRequest: Not a valid URL - " ++ urlString)
Just u -> mkRequest GET u
+-- | @headRequest urlString@ is convenience constructor for basic HEAD 'Request's. If
+-- @urlString@ isn't a syntactically valid URL, the function raises an error.
+headRequest :: String -> Request_String
+headRequest urlString =
+ case parseURI urlString of
+ Nothing -> error ("headRequest: Not a valid URL - " ++ urlString)
+ Just u -> mkRequest HEAD u
+
-- | @postRequest urlString@ is convenience constructor for POST 'Request's. If
-- @urlString@ isn\'t a syntactically valid URL, the function raises an error.
postRequest :: String -> Request_String
View
12 test/httpTests.hs
@@ -36,6 +36,15 @@ basicGetRequest = do
body <- getResponseBody response
assertEqual "Receiving expected response" "It works." body
+basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion
+basicHeadRequest = do
+ response <- simpleHTTP (headRequest (?testUrl "/basic/head"))
+ code <- getResponseCode response
+ assertEqual "HTTP status code" (2, 0, 0) code
+ body <- getResponseBody response
+ -- the body should be empty, since this is a HEAD request
+ assertEqual "Receiving expected response" "" body
+
basicExample :: (?testUrl :: ServerAddress) => Assertion
basicExample = do
result <-
@@ -413,6 +422,8 @@ processRequest req = do
case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of
("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works."
("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)."
+ ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."
+ ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."
("POST", "/basic/post") ->
let typ = lookup "Content-Type" (Httpd.reqHeaders req)
len = lookup "Content-Length" (Httpd.reqHeaders req)
@@ -493,6 +504,7 @@ basicTests =
, testCase "Network.HTTP example code" basicExample
, testCase "Secure GET request" secureGetRequest
, testCase "Basic POST request" basicPostRequest
+ , testCase "Basic HEAD request" basicHeadRequest
, testCase "Basic Auth failure" basicAuthFailure
, testCase "Basic Auth success" basicAuthSuccess
]
Please sign in to comment.
Something went wrong with that request. Please try again.