1. Luke Plant
  2. haskellblog

Commits

Luke Plant  committed 816cfc8

Fixed 'addContent' to actually append, and added a utility 'buildResponse' function

  • Participants
  • Parent commits 4af1762
  • Branches default

Comments (0)

Files changed (3)

File src/Blog/Views.hs

View file
 import qualified Data.ByteString.Lazy.Char8 as BS
 
 mainIndex :: Request -> IO (Maybe Response)
-mainIndex req = do
-  let r1 = utf8HtmlResponse
-  let r2 = addContent (BS.pack "Hello, world") r1
-  return $ Just r2
+mainIndex req = let resp = buildResponse utf8HtmlResponse [
+                            addContent (BS.pack "Hello, world")
+                           ]
+                in return $ Just resp

File src/Web/Response.hs

View file
-module Web.Response (Response, content, headers, addContent, textResponse, htmlResponse, utf8HtmlResponse, emptyResponse) where
+module Web.Response (Response,
+                     content,
+                     headers,
+                     addContent,
+                     textResponse,
+                     htmlResponse,
+                     utf8HtmlResponse,
+                     emptyResponse,
+                     buildResponse) where
 
 -- Mainly borrowed from Network.CGI.Protocol
 
 data Response = Response {
       content :: ByteString
     , headers :: Headers
-    }
+    } deriving (Show, Eq)
 
 emptyResponse = Response { content = BS.empty, headers = [] }
 
 addContent :: ByteString -> Response -> Response
-addContent c resp = resp { content = c }
+addContent c resp = resp { content =  BS.append (content resp) c }
 
 {-
 TODO
 -}
 
 utf8HtmlResponse = htmlResponse "utf-8"
+
+-- | Build a Response from an initial Response and a list of
+-- Response transformation functions
+buildResponse :: Response -> [Response -> Response] -> Response
+buildResponse rinit fs = foldl (flip ($)) rinit fs

File testsuite/tests/Tests/Web/Response.hs

View file
 
 testAddContent1 = "Hello" ~=? (BS.unpack $ content $ addContent (BS.pack "Hello") $ emptyResponse)
 
+testAddContent2 = "Hello world" ~=? (BS.unpack $ content $ addContent (BS.pack " world") $ addContent (BS.pack "Hello") $ emptyResponse)
+
+testBuildResponse = "hello world" ~=? (BS.unpack $ content $
+                                         buildResponse utf8HtmlResponse [
+                                                            addContent (BS.pack "hello"),
+                                                            addContent (BS.pack " world")
+                                                           ])
+
 tests = test [
-         testAddContent1
+          testAddContent1
+        , testAddContent2
+        , testBuildResponse
         ]