diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 672c5160..49cad8df 100644 --- a/Yesod/Form.hs +++ b/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) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 55df6bb7..42de2fe5 100644 --- a/Yesod/Handler.hs +++ b/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. diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 888e59f8..a43e5e2e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/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 diff --git a/Yesod/Template.hs b/Yesod/Template.hs index 45302ff6..83050395 100644 --- a/Yesod/Template.hs +++ b/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 diff --git a/examples/fact.lhs b/examples/fact.lhs index 8918a25a..aa2012e4 100644 --- a/examples/fact.lhs +++ b/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 diff --git a/examples/pretty-yaml.hs b/examples/pretty-yaml.hs index 1f20a054..155b9506 100644 --- a/examples/pretty-yaml.hs +++ b/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)