Rudimentary form support

TODO

@@ -1 +0,0 @@
-Cleanup Parameter stuff. Own module? Interface with formlets?

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

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

yesod.cabal

@@ -57,6 +57,7 @@ library
                      Yesod.Request
                      Yesod.Response
                      Yesod.Definitions
+                     Yesod.Form
                      Yesod.Handler
                      Yesod.Resource
                      Yesod.Yesod