62 lines
2.3 KiB
Haskell
62 lines
2.3 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, getYesod)
|
|
import Yesod.Request (reqGetParams, languages)
|
|
import Data.Maybe (fromMaybe)
|
|
import Control.Monad (liftM)
|
|
import Yesod.Widget (GWidget)
|
|
import Yesod.Message (RenderMessage (..))
|
|
|
|
type DText = [Text] -> [Text]
|
|
newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> Either DText a }
|
|
instance Functor (FormInput master) where
|
|
fmap a (FormInput f) = FormInput $ \c d e -> either Left (Right . a) $ f c d e
|
|
instance Applicative (FormInput master) where
|
|
pure = FormInput . const . const . const . Right
|
|
(FormInput f) <*> (FormInput x) = FormInput $ \c d e ->
|
|
case (f c d e, x c d 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 :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
|
|
ireq field name = FormInput $ \m l env ->
|
|
case lookup name env of
|
|
Nothing -> Left $ (:) $ append "Input not found: " name -- TRANS
|
|
Just x -> either (Left . (:) . renderMessage m l) Right $ fieldParse field x
|
|
|
|
iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)
|
|
iopt field name = FormInput $ \m l env ->
|
|
case fromMaybe "" $ lookup name env of
|
|
"" -> Right Nothing
|
|
x -> either (Left . (:) . renderMessage m l) (Right . Just) $ fieldParse field x
|
|
|
|
runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a
|
|
runInputGet (FormInput f) = do
|
|
env <- liftM reqGetParams getRequest
|
|
m <- getYesod
|
|
l <- languages
|
|
case f m l env of
|
|
Left errs -> invalidArgs $ errs []
|
|
Right x -> return x
|
|
|
|
runInputPost :: FormInput master a -> GHandler sub master a
|
|
runInputPost (FormInput f) = do
|
|
env <- liftM fst runRequestBody
|
|
m <- getYesod
|
|
l <- languages
|
|
case f m l env of
|
|
Left errs -> invalidArgs $ errs []
|
|
Right x -> return x
|