Yesod.Form.Input cleanup/documentation

This commit is contained in:
Michael Snoyman 2014-10-21 09:08:51 +03:00
parent 5a426529db
commit 8a6b4f4523
2 changed files with 36 additions and 17 deletions

View File

@ -1,8 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
-- | Provides for getting input from either GET or POST params without
-- generating HTML forms. For more information, see:
-- <http://www.yesodweb.com/book/forms#forms_kinds_of_forms>.
module Yesod.Form.Input
( FormInput (..)
, runInputGet
, runInputGetResult
, runInputPost
, runInputPostResult
, ireq
@ -13,12 +17,15 @@ import Yesod.Form.Types
import Data.Text (Text)
import Control.Applicative (Applicative (..))
import Yesod.Core
import Control.Monad (liftM)
import Control.Monad (liftM, (<=<))
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Control.Arrow ((***))
type DText = [Text] -> [Text]
-- | Type for a form which parses a value of type @a@ with the base monad @m@
-- (usually your @Handler@). Can can compose this using its @Applicative@ instance.
newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) }
instance Monad m => Functor (FormInput m) where
fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e'
@ -33,8 +40,12 @@ instance Monad m => Applicative (FormInput m) where
(_, Left b) -> Left b
(Right a, Right b) -> Right $ a b
-- | Promote a @Field@ into a @FormInput@, requiring that the value be present
-- and valid.
ireq :: (Monad m, RenderMessage (HandlerSite m) FormMessage)
=> Field m a -> Text -> FormInput m a
=> Field m a
-> Text -- ^ name of the field
-> FormInput m a
ireq field name = FormInput $ \m l env fenv -> do
let filteredEnv = fromMaybe [] $ Map.lookup name env
filteredFEnv = fromMaybe [] $ Map.lookup name fenv
@ -44,6 +55,8 @@ ireq field name = FormInput $ \m l env fenv -> do
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
Right (Just a) -> Right a
-- | Promote a @Field@ into a @FormInput@, with its presence being optional. If
-- the value is present but does not parse correctly, the form will still fail.
iopt :: Monad m => Field m a -> Text -> FormInput m (Maybe a)
iopt field name = FormInput $ \m l env fenv -> do
let filteredEnv = fromMaybe [] $ Map.lookup name env
@ -53,32 +66,38 @@ iopt field name = FormInput $ \m l env fenv -> do
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
Right x -> Right x
-- | Run a @FormInput@ on the GET parameters (i.e., query string). If parsing
-- fails, calls 'invalidArgs'.
runInputGet :: MonadHandler m => FormInput m a -> m a
runInputGet (FormInput f) = do
runInputGet = either invalidArgs return <=< runInputGetHelper
-- | Run a @FormInput@ on the GET parameters (i.e., query string). Does /not/
-- throw exceptions on failure.
--
-- Since 1.4.1
runInputGetResult :: MonadHandler m => FormInput m a -> m (FormResult a)
runInputGetResult = fmap (either FormFailure FormSuccess) . runInputGetHelper
runInputGetHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
runInputGetHelper (FormInput f) = do
env <- liftM (toMap . reqGetParams) getRequest
m <- getYesod
l <- languages
emx <- f m l env Map.empty
case emx of
Left errs -> invalidArgs $ errs []
Right x -> return x
return $ either (Left . ($ [])) Right emx
toMap :: [(Text, a)] -> Map.Map Text [a]
toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
-- | Run a @FormInput@ on the POST parameters (i.e., request body). If parsing
-- fails, calls 'invalidArgs'.
runInputPost :: MonadHandler m => FormInput m a -> m a
runInputPost fi = do
emx <- runInputPostHelper fi
case emx of
Left errs -> invalidArgs errs
Right x -> return x
runInputPost = either invalidArgs return <=< runInputPostHelper
-- | Run a @FormInput@ on the POST parameters (i.e., request body). Does /not/
-- throw exceptions on failure.
runInputPostResult :: MonadHandler m => FormInput m a -> m (FormResult a)
runInputPostResult fi = do
emx <- runInputPostHelper fi
case emx of
Left errs -> return $ FormFailure errs
Right x -> return $ FormSuccess x
runInputPostResult = fmap (either FormFailure FormSuccess) . runInputPostHelper
runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
runInputPostHelper (FormInput f) = do

View File

@ -1,5 +1,5 @@
name: yesod-form
version: 1.4.0.2
version: 1.4.1
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>