Commits

Luke Plant  committed 703e26d

Implemented the remainder of basic framework glue, and rewrote 'Hello world' function using new framework

  • Participants
  • Parent commits 559e347

Comments (0)

Files changed (7)

File src/Blog/Views.hs

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings -}
 module Blog.Views where
 
 import Web.Request
 import Web.Response
+import Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as BS
+import Web.Utils
+import Text.XHtml
+
+mainIndexPage = body << h1 << "Hello, from Luke's web framework"
 
 mainIndex :: Request -> IO (Maybe Response)
 mainIndex req = let resp = buildResponse utf8HtmlResponse [
-                            addContent (BS.pack "Hello, world")
+                            addContent $ BS.pack $ renderHtml mainIndexPage
                            ]
                 in return $ Just resp

File src/BlogCgi.hs

--- "Hello, world" in CGI
+import Blog.Views
+import Web.Framework
 
-import Network.CGI
-import Text.XHtml
-
-page :: Html
-page = body << h1 << "Hello, blogosphere!"
-
-cgiMain :: CGI CGIResult
-cgiMain = output $ renderHtml page
-
+views = [ 
+          mainIndex 
+        ]
 
 main :: IO ()
-main = runCGI $ handleErrors cgiMain
+main = dispatchCGI views defaultDispatchOptions

File src/Web/Framework.hs

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
+module Web.Framework (
+                      dispatchCGI
+                     , dispatchRequest
+                     , default404
+                     , DispatchOptions(..)
+                     , defaultDispatchOptions
+                     )
+
+where
+
+import Web.Response
+import Web.Request
+import Web.Utils
+import System.IO (stdout, hClose)
+import qualified Data.ByteString.Lazy.Char8 as BS
+
+data DispatchOptions = DispatchOptions {
+      response404 :: Response
+}
+
+type View = Request -> IO (Maybe Response)
+
+default404 = buildResponse utf8HtmlResponse [
+              setStatus 404,
+              addContent "<h1>404 Not Found</h1>\n<p>Sorry, the page you requested could not be found.</p>"
+             ]
+
+defaultDispatchOptions = DispatchOptions { response404 = default404 }
+
+dispatchRequest :: Request -> [View] -> IO (Maybe Response)
+dispatchRequest req [] = return Nothing
+dispatchRequest req (v:vs) = do
+  resp <- v req
+  case resp of
+    Nothing -> dispatchRequest req vs
+    x -> return x
+
+-- | Handle a CGI request using a list of possible views
+-- If a view returns 'Nothing' the next will be tried,
+-- and a 404 issued if all return nothing
+dispatchCGI :: [Request -> IO (Maybe Response)] -- list of views that will be tried in order
+            -> DispatchOptions                  -- options to use in dispatching
+            -> IO ()
+dispatchCGI views opts = do
+  req <- buildCGIRequest
+  resp' <- dispatchRequest req views
+  let resp  = case resp' of
+              Nothing -> response404 opts
+              Just x -> x
+  BS.hPut stdout (formatResponse resp)
+  hClose stdout

File src/Web/Request.hs

-module Web.Request (Request, requestMethod, pathInfo, environment, mkRequest)
+module Web.Request (
+                    Request
+                    -- * Components of Request
+                   , requestMethod, pathInfo, environment
+                    -- * Constructors for Request
+                   , mkRequest, buildCGIRequest
+                   )
 
 where
 
 import Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.Maybe
-
+import System.Environment (getEnvironment)
+import System.IO (stdin)
 
 data Request = Request {
       environment :: Map.Map String String
+    , requestBody :: ByteString
     } deriving (Show, Read, Eq, Ord)
 
-mkRequest :: [(String, String)] -> String -> Request
-mkRequest env stdin = let envMap = Map.fromList env
-                      in Request { 
-                               environment = envMap
-                             }
+-- | Create a Request object
+mkRequest :: [(String, String)] -- association list of environment variables
+          -> ByteString -- lazy ByteString containing request body
+          -> Request
+mkRequest env body = let envMap = Map.fromList env
+                     in Request { 
+                              environment = envMap
+                            , requestBody = body
+                            }
 
 requestMethod :: Request -> String
 requestMethod request = fromJust $ Map.lookup "REQUEST_METHOD" $ environment request
 pathInfo request = fromJust $ Map.lookup "PATH_INFO" $ environment request
 
 
+-- | Creates a Request object according to the CGI protocol
+buildCGIRequest :: IO Request
+buildCGIRequest = do
+  env <- getEnvironment
+  body <- BS.hGetContents stdin
+  return $ mkRequest env body

File testsuite/tests/Main.hs

 import qualified Tests.Blog.DBUtils as DBUtils
 import qualified Tests.Web.Request as Request
 import qualified Tests.Web.Response as Response
+import qualified Tests.Web.Framework as Framework
 import Test.HUnit
 
 main = runTestTT (test [
                     DBUtils.tests
                   , Request.tests
                   , Response.tests
+                  , Framework.tests
                   ])

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

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
+module Tests.Web.Framework
+
+where
+
+import Test.HUnit
+import Web.Framework
+import Web.Request
+import Web.Response
+import Data.Maybe (isNothing)
+
+req1 = mkRequest [("REQUEST_METHOD","GET")] ""
+resp1 = buildResponse utf8HtmlResponse [ addContent "resp1" ]
+resp2 = buildResponse utf8HtmlResponse [ addContent "resp2" ]
+
+alwaysFailView = const (return Nothing)
+alwaysSucceedView1 = const (return $ Just resp1)
+alwaysSucceedView2 = const (return $ Just resp2)
+
+testDispatchRequest1 = (do
+                         resp <- dispatchRequest req1 []
+                         return $ isNothing resp)
+                       ~? "With no views, nothing is dispatched"
+
+testDispatchRequest2 = (do
+                         resp <- dispatchRequest req1 [alwaysFailView]
+                         return $ isNothing resp)
+                       ~? "Should get Nothing if all view return Nothing"
+
+testDispatchRequest3 = (do
+                         resp <- dispatchRequest req1 [alwaysFailView,
+                                                       alwaysSucceedView1,
+                                                       alwaysSucceedView2]
+                         return $ (resp == (Just resp1) && resp /= (Just resp2)))
+                       ~? "Dispatch should return first that succeeds"
+
+tests = test [
+         testDispatchRequest1
+        , testDispatchRequest2
+        , testDispatchRequest3
+        ]

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

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
 module Tests.Web.Request
 
 where
 
 import Web.Request
 import Test.HUnit
+import Web.Utils
 
 testMethod = "GET" ~=? requestMethod (mkRequest [("REQUEST_METHOD","GET")] "")
 testPath = "/foo/bar" ~=? pathInfo (mkRequest [("PATH_INFO", "/foo/bar")] "")