Add Network.HTTP.headRequest helper

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

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
     ]