diff --git a/TODO b/TODO deleted file mode 100644 index 6a6c07d0..00000000 --- a/TODO +++ /dev/null @@ -1 +0,0 @@ -Cleanup Parameter stuff. Own module? Interface with formlets? diff --git a/Yesod.hs b/Yesod.hs index 85335165..c95392d5 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -20,6 +20,7 @@ module Yesod , module Yesod.Definitions , module Yesod.Handler , module Yesod.Resource + , module Yesod.Form , module Data.Object.Html , module Yesod.Template , module Web.Mime @@ -38,6 +39,7 @@ import Data.Object.Html import Yesod.Request #endif +import Yesod.Form import Yesod.Yesod import Yesod.Definitions import Yesod.Handler diff --git a/Yesod/Form.hs b/Yesod/Form.hs new file mode 100644 index 00000000..1b842d59 --- /dev/null +++ b/Yesod/Form.hs @@ -0,0 +1,97 @@ +-- | Parse forms (and query strings). +module Yesod.Form + ( Form (..) + , runFormGeneric + , runFormPost + , runFormGet + , input + , applyForm + -- * Specific checks + , required + , notEmpty + , checkDay + , checkBool + ) where + +import Yesod.Request +import Yesod.Handler +import Control.Applicative +import Data.Time (Day) +import Data.Convertible.Text +import Data.Attempt +import Data.Maybe (fromMaybe) + +noParamNameError :: String +noParamNameError = "No param name (miscalling of Yesod.Form library)" + +data Form x = Form ( + (ParamName -> [ParamValue]) + -> Either [(ParamName, FormError)] (Maybe ParamName, x) + ) + +instance Functor Form where + fmap f (Form x) = Form $ \l -> case x l of + Left errors -> Left errors + Right (pn, x') -> Right (pn, f x') +instance Applicative Form where + pure x = Form $ \_ -> Right (Nothing, x) + (Form f') <*> (Form x') = Form $ \l -> case (f' l, x' l) of + (Right (_, f), Right (_, x)) -> Right $ (Nothing, f x) + (Left e1, Left e2) -> Left $ e1 ++ e2 + (Left e, _) -> Left e + (_, Left e) -> Left e + +type FormError = String + +runFormGeneric :: (ParamName -> [ParamValue]) -> Form x -> Handler y 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 f = do + rr <- getRawRequest + runFormGeneric (postParams rr) f + +-- | Run a form against GET parameters. +runFormGet :: Form x -> Handler y x +runFormGet f = do + rr <- getRawRequest + runFormGeneric (getParams rr) f + +input :: ParamName -> Form [ParamValue] +input pn = Form $ \l -> Right $ (Just pn, l pn) + +applyForm :: (x -> Either FormError y) -> Form x -> Form y +applyForm f (Form x') = + Form $ \l -> + case x' l of + Left e -> Left e + Right (pn, x) -> + case f x of + Left e -> Left [(fromMaybe noParamNameError pn, e)] + Right y -> Right (pn, y) + +required :: Form [ParamValue] -> Form ParamValue +required = applyForm $ \pvs -> case pvs of + [x] -> Right x + [] -> Left "No value for required field" + _ -> Left "Multiple values for required field" + +notEmpty :: Form ParamValue -> Form ParamValue +notEmpty = applyForm $ \pv -> + if null pv + then Left "Value required" + else Right pv + +checkDay :: Form ParamValue -> Form Day +checkDay = applyForm $ attempt (const (Left "Invalid day")) Right . ca + +checkBool :: Form [ParamValue] -> Form Bool +checkBool = applyForm $ \pv -> Right $ case pv of + [] -> False + [""] -> False + ["false"] -> False + _ -> True diff --git a/yesod.cabal b/yesod.cabal index 83765d6e..7a67088a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -57,6 +57,7 @@ library Yesod.Request Yesod.Response Yesod.Definitions + Yesod.Form Yesod.Handler Yesod.Resource Yesod.Yesod