Commits

Luke Plant committed 9631195

Added 'setHeader' and 'redirectResponse' and tests

Comments (0)

Files changed (2)

src/Web/Response.hs

-module Web.Response (Response,
-                     content,
-                     headers,
-                     addContent,
-                     textResponse,
-                     utf8TextResponse,
-                     htmlResponse,
-                     utf8HtmlResponse,
-                     emptyResponse,
-                     formatResponse,
-                     setStatus,
-                     buildResponse) where
+module Web.Response ( Response
+                    , content
+                    , headers
+                    , addContent
+                    , textResponse
+                    , utf8TextResponse
+                    , htmlResponse
+                    , utf8HtmlResponse
+                    , emptyResponse
+                    , redirectResponse
+                    , formatResponse
+                    , setStatus
+                    , setHeader
+                    , buildResponse
+                    , HeaderName(HeaderName)
+                    ) where
 
 import Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as BS
-import Data.List
+import Data.List (intersperse)
 import Network.CGI.Protocol (Headers, HeaderName(HeaderName))
 import Network.CGI (ContentType(ContentType), showContentType)
 import Web.GenUtils (apply)
 
 emptyResponse = Response { content = BS.empty
                          , headers = []
-                         , status = 200 
+                         , status = 200
                          }
 
 addContent :: ByteString -> Response -> Response
 setStatus :: Int -> Response -> Response
 setStatus s resp = resp { status = s }
 
+setHeader :: String -> String -> Response -> Response
+setHeader h val resp = let headername = HeaderName h
+                           removed = filter ((/= headername) . fst) (headers resp)
+                           updated = removed ++ [(headername, val)]
+                       in resp { headers = updated }
+
 ---
 --- * Shortcuts for common defaults
 ---
     unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- allHeaders resp]
                 ++ [BS.empty, content resp])
   where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n")
+
+
+-- | Create an HTTP 302 redirect
+redirectResponse location =
+    buildResponse [ setStatus 302
+                  , setHeader "Location" location
+                  ] emptyResponse

testsuite/tests/Tests/Web/Response.hs

 import Test.HUnit
 import Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as BS
+import Data.List (sort)
 
 testAddContent1 = "“Hello”" ~=? (content $ addContent "“Hello”" $ emptyResponse)
 
                                           , setStatus 404
                                           ] utf8HtmlResponse)
 
+testSetHeader1 = [(HeaderName "Header1", "value 1")] ~=?
+                 (headers $ setHeader "Header1" "value 1" emptyResponse)
+
+testSetHeader2 = [(HeaderName "Header1", "value 1.1"),
+                  (HeaderName "Header2", "value 2")] ~=?
+                 (sort $ headers $ buildResponse [ setHeader "Header1" "value 1"
+                                                 , setHeader "Header2" "value 2"
+                                                 , setHeader "Header1" "value 1.1"
+                                                 ] emptyResponse)
+
+-- Replacement should be case insensitive
+testSetHeader3 = [(HeaderName "Header1", "value 1.1")] ~=?
+                 (sort $ headers $ buildResponse [ setHeader "Header1" "value 1"
+                                                 , setHeader "header1" "value 1.1"
+                                                 ] emptyResponse)
+
+testRedirectResponse = "Location: /foo/bar/\r\n\
+                        \Status: 302\r\n\
+                        \\r\n" ~=?
+                        (formatResponse $ redirectResponse "/foo/bar/")
+
 tests = test [
           testAddContent1
         , testAddContent2
         , testBuildResponse
         , testFormatResponse
         , testFormatResponse2
+        , testSetHeader1
+        , testSetHeader2
+        , testSetHeader3
+        , testRedirectResponse
         ]