Yesod.Form.Input

Yesod/Form.hs

@@ -1,19 +1,14 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
 -- | Parse forms (and query strings).
 module Yesod.Form
     ( module Yesod.Form.Types
     , module Yesod.Form.Functions
     , module Yesod.Form.Fields
     , module Yesod.Form.Class
+    , module Yesod.Form.Input
     ) where
 
 import Yesod.Form.Types
 import Yesod.Form.Functions
 import Yesod.Form.Fields
 import Yesod.Form.Class
+import Yesod.Form.Input

Yesod/Form/Input.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.Input
+    ( FormInput (..)
+    , runInputGet
+    , runInputPost
+    , ireq
+    , iopt
+    ) where
+
+import Yesod.Form.Types
+import Data.Text (Text, append)
+import Control.Applicative (Applicative (..))
+import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest)
+import Yesod.Request (reqGetParams)
+import Data.Maybe (fromMaybe)
+import Control.Monad (liftM)
+
+type DText = [Text] -> [Text]
+newtype FormInput a = FormInput { unFormInput :: Env -> Either DText a }
+instance Functor FormInput where
+    fmap a (FormInput f) = FormInput $ \e -> either Left (Right . a) $ f e
+instance Applicative FormInput where
+    pure = FormInput . const . Right
+    (FormInput f) <*> (FormInput x) = FormInput $ \e ->
+        case (f e, x e) of
+            (Left a, Left b) -> Left $ a . b
+            (Left a, _) -> Left a
+            (_, Left b) -> Left b
+            (Right a, Right b) -> Right $ a b
+
+ireq :: Field xml a -> Text -> FormInput a
+ireq field name = FormInput $ \env ->
+    case lookup name env of
+        Nothing -> Left $ (:) $ append "Input not found: " name -- TRANS
+        Just x -> either (Left . (:)) Right $ fieldParse field x
+
+iopt :: Field xml a -> Text -> FormInput (Maybe a)
+iopt field name = FormInput $ \env ->
+    case fromMaybe "" $ lookup name env of
+        "" -> Right Nothing
+        x -> either (Left . (:)) (Right . Just) $ fieldParse field x
+
+runInputGet :: Monad monad => FormInput a -> GGHandler sub master monad a
+runInputGet (FormInput f) = do
+    env <- liftM reqGetParams getRequest
+    case f env of
+        Left errs -> invalidArgs $ errs []
+        Right x -> return x
+
+runInputPost :: FormInput a -> GHandler sub master a
+runInputPost (FormInput f) = do
+    env <- liftM fst runRequestBody
+    case f env of
+        Left errs -> invalidArgs $ errs []
+        Right x -> return x

Yesod/Form/Types.hs

@@ -66,7 +66,7 @@ instance Show Ints where
     show (IntSingle i) = show i
     show (IntCons i is) = show i ++ ('-' : show is)
 
-type Env = [(Text, Text)]
+type Env = [(Text, Text)] -- FIXME use a Map
 type FileEnv = [(Text, FileInfo)]
 
 type Form m a = RWST (Maybe (Env, FileEnv)) Enctype Ints m a

yesod-form.cabal

@@ -34,6 +34,7 @@ library
                      Yesod.Form.Class
                      Yesod.Form.Types
                      Yesod.Form.Functions
+                     Yesod.Form.Input
                      Yesod.Form.Fields
                      Yesod.Form.Jquery
                      Yesod.Form.Nic