Commits

Luke Plant committed 0422a26

Added 'setStatus' for responses

  • Participants
  • Parent commits 9b8137e

Comments (0)

Files changed (2)

src/Web/Response.hs

                      utf8HtmlResponse,
                      emptyResponse,
                      formatResponse,
+                     setStatus,
                      buildResponse) where
 
 -- Mainly borrowed from Network.CGI.Protocol
     , status :: Int
     } deriving (Show, Eq)
 
+--
+-- * Creating responses
+--
+
 emptyResponse = Response { content = BS.empty
                          , headers = []
                          , status = 200 
 addContent :: ByteString -> Response -> Response
 addContent c resp = resp { content =  BS.append (content resp) c }
 
+setStatus :: Int -> Response -> Response
+setStatus s resp = resp { status = s }
+
+---
+--- * Shortcuts for common defaults
+---
+
 {-
 TODO
  - add utility functions for writing HTML
    convert HTML to the correct encoding.
 -}
 
-
--- Utility functions for typical defaults
-
 contentTypeName = HeaderName "Content-type"
 textContent charset = "text/plain; charset=" ++ charset
 htmlContent charset = "text/html; charset=" ++ charset

testsuite/tests/Tests/Web/Response.hs

 testFormatResponse = "Content-type: text/html; charset=UTF-8\r\n\
                      \Status: 200\r\n\
                      \\r\n\
-                     \<h1>Test</h1>" ~=? (formatResponse $
-                                          buildResponse utf8HtmlResponse [
-                                                             addContent "<h1>Test</h1>"
-                                                            ])
+                     \<h1>Test</h1>" ~=? 
+                     (formatResponse $ buildResponse utf8HtmlResponse [
+                                          addContent "<h1>Test</h1>"
+                                         ])
+
+testFormatResponse2 = "Content-type: text/html; charset=UTF-8\r\n\
+                      \Status: 404\r\n\
+                      \\r\n\
+                      \<h1>404 Not Found</h1>" ~=?
+                      (formatResponse $ buildResponse utf8HtmlResponse [
+                                           addContent "<h1>404 Not Found</h1>"
+                                          , setStatus 404
+                                          ])
 
 tests = test [
           testAddContent1
         , testAddContent2
         , testBuildResponse
         , testFormatResponse
+        , testFormatResponse2
         ]