From 2a958c1a8f0a7479287376630f03c6c6884f3178 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 21 Sep 2009 01:00:04 +0300
Subject: [PATCH] Better error handling for invalid arguments

---
 TODO                       |  1 -
 Web/Restful/Application.hs |  5 +++++
 Web/Restful/Request.hs     | 15 +++++++--------
 Web/Restful/Response.hs    |  4 +++-
 4 files changed, 15 insertions(+), 10 deletions(-)

diff --git a/TODO b/TODO
index 052dfd91..e69de29b 100644
--- a/TODO
+++ b/TODO
@@ -1 +0,0 @@
-Better error handling for invalid arguments (currently 500 error)
diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs
index 3c61f556..017824f2 100644
--- a/Web/Restful/Application.hs
+++ b/Web/Restful/Application.hs
@@ -71,6 +71,11 @@ class ResourceName a b => RestfulApp a b | a -> b where
         HasRepsW $ toObject $ "Redirect to: " ++ url
     errorHandler _ _ (InternalError e) =
         HasRepsW $ toObject $ "Internal server error: " ++ e
+    errorHandler _ _ (InvalidArgs ia) =
+        HasRepsW $ toObject $
+            [ ("errorMsg", toObject "Invalid arguments")
+            , ("messages", toObject ia)
+            ]
 
 -- | Given a sample resource name (purely for typing reasons), generating
 -- a Hack application.
diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs
index 789de3ec..30a13770 100644
--- a/Web/Restful/Request.hs
+++ b/Web/Restful/Request.hs
@@ -109,7 +109,7 @@ tryReadParams:: Parameter a
 tryReadParams name params =
     case readParams params of
         Left s -> do
-            tell [name ++ ": " ++ s]
+            tell [(name, s)]
             return $
               error $
                 "Trying to evaluate nonpresent parameter " ++
@@ -185,16 +185,15 @@ requestPath = do
                 q' -> q'
     return $! Hack.pathInfo env ++ q
 
-type RequestParser a = WriterT [ParamError] (Reader RawRequest) a
-instance Applicative (WriterT [ParamError] (Reader RawRequest)) where
+type RequestParser a = WriterT [(ParamName, ParamError)] (Reader RawRequest) a
+instance Applicative (WriterT [(ParamName, ParamError)] (Reader RawRequest)) where
     pure = return
-    f <*> a = do
-        f' <- f
-        a' <- a
-        return $! f' a'
+    (<*>) = ap
 
 -- | Parse a request into either the desired 'Request' or a list of errors.
-runRequestParser :: RequestParser a -> RawRequest -> Either [ParamError] a
+runRequestParser :: RequestParser a
+                 -> RawRequest
+                 -> Either [(ParamName, ParamError)] a
 runRequestParser p req =
     let (val, errors) = (runReader (runWriterT p)) req
      in case errors of
diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs
index b5d1c1fb..4fbdfa3f 100644
--- a/Web/Restful/Response.hs
+++ b/Web/Restful/Response.hs
@@ -73,11 +73,13 @@ data ErrorResult =
     Redirect String
     | NotFound
     | InternalError String
+    | InvalidArgs [(String, String)]
 
 getStatus :: ErrorResult -> Int
 getStatus (Redirect _) = 303
 getStatus NotFound = 404
 getStatus (InternalError _) = 500
+getStatus (InvalidArgs _) = 400
 
 getHeaders :: ErrorResult -> [Header]
 getHeaders (Redirect s) = [Header "Location" s]
@@ -228,5 +230,5 @@ getRequest = ResponseT $ \rr -> return (helper rr, []) where
            -> Either ErrorResult r
     helper rr =
         case runRequestParser parseRequest rr of
-            Left errors -> Left $ InternalError $ unlines errors -- FIXME better error output
+            Left errors -> Left $ InvalidArgs errors -- FIXME better error output
             Right r -> Right r