From c75c72d9cb21d12042afe2fe9cce33896bf26f45 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 18 Sep 2009 09:36:47 +0300
Subject: [PATCH] Response wrapping and error handling done properly

---
 Web/Restful/Application.hs | 48 ++++++++++++++++++--------------------
 Web/Restful/Request.hs     |  4 ++++
 Web/Restful/Response.hs    | 32 ++++++++++++-------------
 3 files changed, 42 insertions(+), 42 deletions(-)

diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs
index 529910ba..0ac40106 100644
--- a/Web/Restful/Application.hs
+++ b/Web/Restful/Application.hs
@@ -23,8 +23,8 @@ module Web.Restful.Application
     ) where
 
 import Web.Encodings
-import Data.ByteString.Class
 import qualified Data.ByteString.Lazy as B
+import Data.Object
 
 import qualified Hack
 import Hack.Middleware.CleanPath
@@ -59,15 +59,19 @@ class ResourceName a b => RestfulApp a b | a -> b where
                 , methodOverride
                 ]
 
-    -- | How to generate 404 pages. FIXME make more user-friendly.
-    response404 :: a -> Hack.Env -> IO Hack.Response
-    response404 _ = default404
-
     -- | Wrappers for cleaning up responses. Especially intended for
     -- beautifying static HTML. FIXME more user friendly.
     responseWrapper :: a -> String -> B.ByteString -> IO B.ByteString
     responseWrapper _ _ = return
 
+    -- | Output error response pages.
+    errorHandler :: a -> RawRequest -> ErrorResult -> HasRepsW
+    errorHandler _ rr NotFound = HasRepsW $ toObject $ "Not found: " ++ show rr
+    errorHandler _ _ (Redirect url) =
+        HasRepsW $ toObject $ "Redirect to: " ++ url
+    errorHandler _ _ (InternalError e) =
+        HasRepsW $ toObject $ "Internal server error: " ++ e
+
 -- | Given a sample resource name (purely for typing reasons), generating
 -- a Hack application.
 toHackApp :: RestfulApp resourceName modelType
@@ -107,19 +111,20 @@ toHackApplication :: RestfulApp resourceName model
                   -> Hack.Application
 toHackApplication sampleRN hm env = do
     let (Right resource) = splitPath $ Hack.pathInfo env
-    case findResourceNames resource of
-      [] -> response404 sampleRN $ env
-      [(rn, urlParams')] -> do
-        let verb :: Verb
-            verb = toVerb $ Hack.requestMethod env
-            rr :: RawRequest
-            rr = envToRawRequest urlParams' env
-            handler :: Handler
-            handler = hm rn verb
-        let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
-            ctypes' = parseHttpAccept rawHttpAccept
-        runResponse (handler rr) ctypes'
-      x -> error $ "Invalid matches: " ++ show x
+    let (handler, urlParams') =
+          case findResourceNames resource of
+            [] -> (noHandler, [])
+            [(rn, urlParams'')] ->
+                let verb = toVerb $ Hack.requestMethod env
+                 in (hm rn verb, urlParams'')
+            x -> error $ "Invalid findResourceNames: " ++ show x
+    let rr = envToRawRequest urlParams' env
+    let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
+        ctypes' = parseHttpAccept rawHttpAccept
+    runResponse (errorHandler sampleRN rr)
+                (responseWrapper sampleRN)
+                ctypes'
+                (handler rr)
 
 envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
 envToRawRequest urlParams' env =
@@ -132,10 +137,3 @@ envToRawRequest urlParams' env =
         rawCookie = tryLookup "" "Cookie" $ Hack.http env
         cookies' = decodeCookies rawCookie :: [(String, String)]
      in RawRequest rawPieces urlParams' gets' posts cookies' files env
-
-default404 :: Hack.Env -> IO Hack.Response
-default404 env = return $
-    Hack.Response
-        404
-        [("Content-Type", "text/plain")]
-        $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env
diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs
index 4596458b..789de3ec 100644
--- a/Web/Restful/Request.hs
+++ b/Web/Restful/Request.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Request
@@ -210,6 +211,9 @@ data RawRequest = RawRequest
     , rawFiles :: [(ParamName, FileInfo)]
     , rawEnv :: Hack.Env
     }
+    deriving Show
+
+deriving instance Show FileInfo
 
 -- | All GET paramater values with the given name.
 getParams :: RawRequest -> ParamName -> [ParamValue]
diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs
index 19db94d4..98fc13d8 100644
--- a/Web/Restful/Response.hs
+++ b/Web/Restful/Response.hs
@@ -29,6 +29,8 @@ module Web.Restful.Response
     , header
     , GenResponse (..)
     , liftIO
+    , ErrorResult (..)
+    , HasRepsW (..)
     ) where
 
 import Data.ByteString.Class
@@ -61,47 +63,43 @@ data HasRepsW = forall a. HasReps a => HasRepsW a
 instance HasReps HasRepsW where
     reps (HasRepsW r) = reps r
 
--- | The result of a request. This does not include possible headers.
-data Result =
+data ErrorResult =
     Redirect String
     | NotFound
     | InternalError String
-    | Content HasRepsW
 
-instance HasReps Result where
-    reps (Redirect s) = [("text/plain", toLazyByteString s)]
-    reps NotFound = [("text/plain", toLazyByteString "not found")] -- FIXME use the real 404 page
-    reps (InternalError s) = [("text/plain", toLazyByteString s)]
-    reps (Content r) = reps r
-
-getStatus :: Result -> Int
+getStatus :: ErrorResult -> Int
 getStatus (Redirect _) = 303
 getStatus NotFound = 404
 getStatus (InternalError _) = 500
-getStatus (Content _) = 200
 
-getHeaders :: Result -> [Header]
+getHeaders :: ErrorResult -> [Header]
 getHeaders (Redirect s) = [Header "Location" s]
 getHeaders _ = []
 
-newtype ResponseT m a = ResponseT (m (Either Result a, [Header]))
+newtype ResponseT m a = ResponseT (m (Either ErrorResult a, [Header]))
 type ResponseIO = ResponseT IO
 type Response = ResponseIO HasRepsW
 
-runResponse :: Response -> [ContentType] -> IO Hack.Response
-runResponse (ResponseT inside) ctypesAll = do
+runResponse :: (ErrorResult -> HasRepsW)
+            -> (ContentType -> B.ByteString -> IO B.ByteString)
+            -> [ContentType]
+            -> Response
+            -> IO Hack.Response
+runResponse eh wrapper ctypesAll (ResponseT inside) = do
     (x, headers') <- inside
     let extraHeaders =
             case x of
                 Left r -> getHeaders r
                 Right _ -> []
     headers <- mapM toPair (headers' ++ extraHeaders)
-    let outReps = either reps reps x
+    let outReps = either (reps . eh) reps x
     let statusCode =
             case x of
                 Left r -> getStatus r
                 Right _ -> 200
-    (ctype, finalRep) <- chooseRep outReps ctypesAll
+    (ctype, selectedRep) <- chooseRep outReps ctypesAll
+    finalRep <- wrapper ctype selectedRep
     let headers'' = ("Content-Type", ctype) : headers
     return $! Hack.Response statusCode headers'' finalRep