56 lines
1.8 KiB
Haskell
56 lines
1.8 KiB
Haskell
{-# 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
|