Allow catching of form errors

Yesod/Form.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PackageImports #-}
 -- | Parse forms (and query strings).
 module Yesod.Form
     ( Form (..)
@@ -11,15 +13,21 @@ module Yesod.Form
     , notEmpty
     , checkDay
     , checkBool
+    , checkInteger
+      -- * Utility
+    , catchFormError
     ) where
 
 import Yesod.Request
+import Yesod.Response (ErrorResponse)
 import Yesod.Handler
 import Control.Applicative
 import Data.Time (Day)
 import Data.Convertible.Text
 import Data.Attempt
 import Data.Maybe (fromMaybe)
+import "transformers" Control.Monad.Trans (MonadIO)
+import qualified Safe.Failure
 
 noParamNameError :: String
 noParamNameError = "No param name (miscalling of Yesod.Form library)"
@@ -43,21 +51,24 @@ instance Applicative Form where
 
 type FormError = String
 
-runFormGeneric :: (ParamName -> [ParamValue]) -> Form x -> Handler y x
+runFormGeneric :: MonadFailure ErrorResponse m
+               => (ParamName -> [ParamValue]) -> Form x -> m x
 runFormGeneric params (Form f) =
     case f params of
         Left es -> invalidArgs es
         Right (_, x) -> return x
 
 -- | Run a form against POST parameters.
-runFormPost :: Form x -> Handler y x
+runFormPost :: (RequestReader m, MonadFailure ErrorResponse m, MonadIO m)
+            => Form x -> m x
 runFormPost f = do
     rr <- getRequest
     pp <- postParams rr
     runFormGeneric pp f
 
 -- | Run a form against GET parameters.
-runFormGet :: Form x -> Handler y x
+runFormGet :: (RequestReader m, MonadFailure ErrorResponse m)
+           => Form x -> m x
 runFormGet f = do
     rr <- getRequest
     runFormGeneric (getParams rr) f
@@ -96,3 +107,17 @@ checkBool = applyForm $ \pv -> Right $ case pv of
                                         [""] -> False
                                         ["false"] -> False
                                         _ -> True
+
+checkInteger :: Form ParamValue -> Form Integer
+checkInteger = applyForm $ \pv ->
+    case Safe.Failure.read pv of
+        Nothing -> Left "Invalid integer"
+        Just i -> Right i
+
+-- | Instead of calling 'failure' with an 'InvalidArgs', return the error
+-- messages.
+catchFormError :: Form x -> Form (Either [(ParamName, FormError)] x)
+catchFormError (Form x) = Form $ \l ->
+    case x l of
+        Left e -> Right (Nothing, Left e)
+        Right (_, v) -> Right (Nothing, Right v)

Yesod/Handler.hs

@@ -69,7 +69,7 @@ instance Applicative (Handler yesod) where
     pure = return
     (<*>) = ap
 instance Monad (Handler yesod) where
-    fail = failureString -- We want to catch all exceptions anyway
+    fail = failure . InternalError -- We want to catch all exceptions anyway
     return x = Handler $ \_ -> return ([], HCContent x)
     (Handler handler) >>= f = Handler $ \rr -> do
         (headers, c) <- handler rr
@@ -81,8 +81,8 @@ instance Monad (Handler yesod) where
         return (headers ++ headers', c')
 instance MonadIO (Handler yesod) where
     liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')
-instance Exception e => Failure e (Handler yesod) where
-    failure e = Handler $ \_ -> return ([], HCError $ InternalError $ show e)
+instance Failure ErrorResponse (Handler yesod) where
+    failure e = Handler $ \_ -> return ([], HCError e)
 instance RequestReader (Handler yesod) where
     getRequest = Handler $ \(HandlerData rr _)
                         -> return ([], HCContent rr)
@@ -134,9 +134,6 @@ safeEh er = do
 specialResponse :: SpecialResponse -> Handler yesod a
 specialResponse er = Handler $ \_ -> return ([], HCSpecial er)
 
-errorResponse :: ErrorResponse -> Handler yesod a
-errorResponse er = Handler $ \_ -> return ([], HCError er)
-
 -- | Redirect to the given URL.
 redirect :: RedirectType -> String -> Handler yesod a
 redirect rt = specialResponse . Redirect rt
@@ -145,14 +142,14 @@ sendFile :: ContentType -> FilePath -> Handler yesod a
 sendFile ct = specialResponse . SendFile ct
 
 -- | Return a 404 not found page. Also denotes no handler available.
-notFound :: Handler yesod a
-notFound = errorResponse NotFound
+notFound :: Failure ErrorResponse m => m a
+notFound = failure NotFound
 
-permissionDenied :: Handler yesod a
-permissionDenied = errorResponse PermissionDenied
+permissionDenied :: Failure ErrorResponse m => m a
+permissionDenied = failure PermissionDenied
 
-invalidArgs :: [(ParamName, String)] -> Handler yesod a
-invalidArgs = errorResponse . InvalidArgs
+invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a
+invalidArgs = failure . InvalidArgs
 
 ------- Headers
 -- | Set the cookie on the client.

Yesod/Helpers/Auth.hs

@@ -165,7 +165,7 @@ rpxnowLogin = do
                         (('#':rest):_) -> rest
                         (s:_) -> s
                 (d:_) -> d
-    ident <- Rpxnow.authenticate apiKey token
+    ident <- liftIO $ Rpxnow.authenticate apiKey token
     onRpxnowLogin ident
     header authCookieName $ Rpxnow.identifier ident
     header authDisplayName $ getDisplayName ident

Yesod/Template.hs

@@ -54,7 +54,7 @@ templateHtml tn f = do
     tg <- getTemplateGroup'
     y <- getYesod
     t <- case getStringTemplate tn tg of
-            Nothing -> failure $ NoSuchTemplate tn
+            Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn
             Just x -> return x
     rr <- getRequest
     return $ RepHtml $ ioTextToContent
@@ -81,7 +81,7 @@ templateHtmlJson tn ho f = do
     y <- getYesod
     rr <- getRequest
     t <- case getStringTemplate tn tg of
-            Nothing -> failure $ NoSuchTemplate tn
+            Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn
             Just x -> return x
     return $ RepHtmlJson
             ( ioTextToContent

examples/fact.lhs

@@ -89,16 +89,12 @@ one piece of data.
 
 > factRedirect :: Handler y ()
 > factRedirect = do
->     rr <- getRequest
->     let i = case getParams rr "num" of -- FIXME
->               [] -> "1"
->               (x:_) -> x
->     _ <- redirect RedirectPermanent $ "../" ++ i ++ "/"
-
-The following line would be unnecesary if we had a type signature on
-factRedirect.
-
->     return ()
+>     res <- runFormPost $ catchFormError 
+>                        $ checkInteger
+>                        $ required
+>                        $ input "num"
+>     let i = either (const "1") show res
+>     redirect RedirectPermanent $ "../" ++ i ++ "/"
 
 You could replace this main to use any WAI handler you want. For production,
 you could use CGI, FastCGI or a more powerful server. Just check out Hackage

examples/pretty-yaml.hs

@@ -27,7 +27,7 @@ showYamlH = do
     fi <- case lookup "yaml" files of
             Nothing -> invalidArgs [("yaml", "Missing input")]
             Just x -> return x
-    to <- decode $ B.concat $ L.toChunks $ fileContent fi
+    to <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi
     let ho' = fmap Text to
     templateHtmlJson "pretty-yaml" ho' $ \ho ->
         return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject)