109 lines
4.5 KiB
Haskell
109 lines
4.5 KiB
Haskell
{-# LANGUAGE DeriveFunctor #-}
|
|
{-# 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
|
|
, iopt
|
|
) where
|
|
|
|
import Yesod.Form.Types
|
|
import Data.Text (Text)
|
|
import Control.Applicative (Applicative (..))
|
|
import Yesod.Core
|
|
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 compose this using its @Applicative@ instance.
|
|
newtype FormInput site a = FormInput { unFormInput :: Env -> FileEnv -> HandlerFor site (Either DText a) }
|
|
deriving Functor
|
|
instance Control.Applicative.Applicative (FormInput site) where
|
|
pure x = FormInput $ \_env _filenv -> pure $ Right x
|
|
(FormInput f) <*> (FormInput x) = FormInput $ \env fileEnv -> do
|
|
res1 <- f env fileEnv
|
|
res2 <- x env fileEnv
|
|
return $ case (res1, res2) of
|
|
(Left a, Left b) -> Left $ a . b
|
|
(Left a, _) -> Left a
|
|
(_, 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 :: RenderMessage site FormMessage
|
|
=> Field site a
|
|
-> Text -- ^ name of the field
|
|
-> FormInput site a
|
|
ireq field name = FormInput $ \env fenv -> do
|
|
let filteredEnv = fromMaybe [] $ Map.lookup name env
|
|
filteredFEnv = fromMaybe [] $ Map.lookup name fenv
|
|
emx <- fieldParse field filteredEnv filteredFEnv
|
|
m <- getYesod
|
|
l <- reqLangs <$> getRequest
|
|
return $ case emx of
|
|
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
|
|
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 :: Field site a -> Text -> FormInput site (Maybe a)
|
|
iopt field name = FormInput $ \env fenv -> do
|
|
let filteredEnv = fromMaybe [] $ Map.lookup name env
|
|
filteredFEnv = fromMaybe [] $ Map.lookup name fenv
|
|
emx <- fieldParse field filteredEnv filteredFEnv
|
|
case emx of
|
|
Left (SomeMessage e) -> do
|
|
site <- getYesod
|
|
l <- reqLangs <$> getRequest
|
|
pure $ Left $ (:) $ renderMessage site l e
|
|
Right x -> pure $ Right x
|
|
|
|
-- | Run a @FormInput@ on the GET parameters (i.e., query string). If parsing
|
|
-- fails, calls 'invalidArgs'.
|
|
runInputGet :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env a
|
|
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 :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (FormResult a)
|
|
runInputGetResult = fmap (either FormFailure FormSuccess) . runInputGetHelper
|
|
|
|
runInputGetHelper :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (Either [Text] a)
|
|
runInputGetHelper (FormInput f) = do
|
|
env <- liftM (toMap . reqGetParams) getRequest
|
|
emx <- liftHandler $ f env Map.empty
|
|
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 :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env a
|
|
runInputPost = either invalidArgs return <=< runInputPostHelper
|
|
|
|
-- | Run a @FormInput@ on the POST parameters (i.e., request body). Does /not/
|
|
-- throw exceptions on failure.
|
|
runInputPostResult :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (FormResult a)
|
|
runInputPostResult = fmap (either FormFailure FormSuccess) . runInputPostHelper
|
|
|
|
runInputPostHelper :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (Either [Text] a)
|
|
runInputPostHelper (FormInput f) = liftHandler $ do
|
|
(env, fenv) <- liftM (toMap *** toMap) runRequestBody
|
|
fmap (either (Left . ($ [])) Right) $ f env fenv
|