Browse files

Add getResponseCode utility

  • Loading branch information...
1 parent 28c6fcc commit 0976733f958975fc080690a441e918ea0561e943 @hsenag hsenag committed May 11, 2012
Showing with 10 additions and 5 deletions.
  1. +10 −1 Network/HTTP.hs
  2. +0 −4 test/httpTests.hs
View
11 Network/HTTP.hs
@@ -63,7 +63,8 @@ module Network.HTTP
, postRequest -- :: String -> Request_String
, postRequestWithBody -- :: String -> String -> String -> Request_String
- , getResponseBody -- :: Requesty ty -> ty
+ , getResponseBody -- :: Result (Request ty) -> IO ty
+ , getResponseCode -- :: Result (Request ty) -> IO ResponseCode
) where
-----------------------------------------------------------------
@@ -201,6 +202,14 @@ getResponseBody :: Result (Response ty) -> IO ty
getResponseBody (Left err) = fail (show err)
getResponseBody (Right r) = return (rspBody r)
+-- | @getResponseBody response@ takes the response of a HTTP requesting action and
+-- tries to extricate the status code of the 'Response' @response@. If the request action
+-- returned an error, an IO exception is raised.
+getResponseCode :: Result (Response ty) -> IO ResponseCode
+getResponseCode (Left err) = fail (show err)
+getResponseCode (Right r) = return (rspCode r)
+
+
--
-- * TODO
-- - request pipelining
View
4 test/httpTests.hs
@@ -491,10 +491,6 @@ altProcessRequest req = do
("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)."
_ -> return $ Httpd.mkResponse 500 [] "Unknown request"
-getResponseCode :: Result (Response a) -> IO ResponseCode
-getResponseCode (Left err) = fail (show err)
-getResponseCode (Right r) = return (rspCode r)
-
maybeTestGroup True name xs = testGroup name xs
maybeTestGroup False name _ = testGroup name []

0 comments on commit 0976733

Please sign in to comment.