{-# 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 m a = FormInput { forall (m :: * -> *) a.
FormInput m a
-> HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) }
instance Monad m => Functor (FormInput m) where
    fmap :: forall a b. (a -> b) -> FormInput m a -> FormInput m b
fmap a -> b
a (FormInput HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
f) = forall (m :: * -> *) a.
(HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a))
-> FormInput m a
FormInput forall a b. (a -> b) -> a -> b
$ \HandlerSite m
c [Text]
d Env
e FileEnv
e' -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
a)) forall a b. (a -> b) -> a -> b
$ HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
f HandlerSite m
c [Text]
d Env
e FileEnv
e'
instance Monad m => Control.Applicative.Applicative (FormInput m) where
    pure :: forall a. a -> FormInput m a
pure = forall (m :: * -> *) a.
(HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a))
-> FormInput m a
FormInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
    (FormInput HandlerSite m
-> [Text] -> Env -> FileEnv -> m (Either DText (a -> b))
f) <*> :: forall a b. FormInput m (a -> b) -> FormInput m a -> FormInput m b
<*> (FormInput HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
x) = forall (m :: * -> *) a.
(HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a))
-> FormInput m a
FormInput forall a b. (a -> b) -> a -> b
$ \HandlerSite m
c [Text]
d Env
e FileEnv
e' -> do
        Either DText (a -> b)
res1 <- HandlerSite m
-> [Text] -> Env -> FileEnv -> m (Either DText (a -> b))
f HandlerSite m
c [Text]
d Env
e FileEnv
e'
        Either DText a
res2 <- HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
x HandlerSite m
c [Text]
d Env
e FileEnv
e'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case (Either DText (a -> b)
res1, Either DText a
res2) of
            (Left DText
a, Left DText
b) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ DText
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. DText
b
            (Left DText
a, Either DText a
_) -> forall a b. a -> Either a b
Left DText
a
            (Either DText (a -> b)
_, Left DText
b) -> forall a b. a -> Either a b
Left DText
b
            (Right a -> b
a, Right a
b) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ a -> b
a 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 -- ^ name of the field
     -> FormInput m a
ireq :: forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m a
field Text
name = forall (m :: * -> *) a.
(HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a))
-> FormInput m a
FormInput forall a b. (a -> b) -> a -> b
$ \HandlerSite m
m [Text]
l Env
env FileEnv
fenv -> do
      let filteredEnv :: [Text]
filteredEnv = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Env
env
          filteredFEnv :: [FileInfo]
filteredFEnv = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name FileEnv
fenv
      Either (SomeMessage (HandlerSite m)) (Maybe a)
emx <- forall (m :: * -> *) a.
Field m a
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fieldParse Field m a
field [Text]
filteredEnv [FileInfo]
filteredFEnv
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either (SomeMessage (HandlerSite m)) (Maybe a)
emx of
          Left (SomeMessage msg
e) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (:) forall a b. (a -> b) -> a -> b
$ forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage HandlerSite m
m [Text]
l msg
e
          Right Maybe a
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (:) forall a b. (a -> b) -> a -> b
$ forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage HandlerSite m
m [Text]
l forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInputNotFound Text
name
          Right (Just a
a) -> forall a b. b -> Either a b
Right a
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 :: forall (m :: * -> *) a.
Monad m =>
Field m a -> Text -> FormInput m (Maybe a)
iopt Field m a
field Text
name = forall (m :: * -> *) a.
(HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a))
-> FormInput m a
FormInput forall a b. (a -> b) -> a -> b
$ \HandlerSite m
m [Text]
l Env
env FileEnv
fenv -> do
      let filteredEnv :: [Text]
filteredEnv = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Env
env
          filteredFEnv :: [FileInfo]
filteredFEnv = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name FileEnv
fenv
      Either (SomeMessage (HandlerSite m)) (Maybe a)
emx <- forall (m :: * -> *) a.
Field m a
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fieldParse Field m a
field [Text]
filteredEnv [FileInfo]
filteredFEnv
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either (SomeMessage (HandlerSite m)) (Maybe a)
emx of
        Left (SomeMessage msg
e) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (:) forall a b. (a -> b) -> a -> b
$ forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage HandlerSite m
m [Text]
l msg
e
        Right Maybe a
x -> forall a b. b -> Either a b
Right Maybe a
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 :: forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputGet = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (Either [Text] a)
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 :: forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputGetResult = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. [Text] -> FormResult a
FormFailure forall a. a -> FormResult a
FormSuccess) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (Either [Text] a)
runInputGetHelper

runInputGetHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
runInputGetHelper :: forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (Either [Text] a)
runInputGetHelper (FormInput HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
f) = do
    Env
env <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. [(Text, a)] -> Map Text [a]
toMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodRequest -> [(Text, Text)]
reqGetParams) forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
    HandlerSite m
m <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    [Text]
l <- forall (m :: * -> *). MonadHandler m => m [Text]
languages
    Either DText a
emx <- HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
f HandlerSite m
m [Text]
l Env
env forall k a. Map k a
Map.empty
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ [])) forall a b. b -> Either a b
Right Either DText a
emx

toMap :: [(Text, a)] -> Map.Map Text [a]
toMap :: forall a. [(Text, a)] -> Map Text [a]
toMap = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Text
x, a
y) -> forall k a. k -> a -> Map k a
Map.singleton Text
x [a
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 :: forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (Either [Text] a)
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 :: forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. [Text] -> FormResult a
FormFailure forall a. a -> FormResult a
FormSuccess) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (Either [Text] a)
runInputPostHelper

runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
runInputPostHelper :: forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (Either [Text] a)
runInputPostHelper (FormInput HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
f) = do
    (Env
env, FileEnv
fenv) <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. [(Text, a)] -> Map Text [a]
toMap forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. [(Text, a)] -> Map Text [a]
toMap) forall (m :: * -> *).
MonadHandler m =>
m ([(Text, Text)], [(Text, FileInfo)])
runRequestBody
    HandlerSite m
m <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    [Text]
l <- forall (m :: * -> *). MonadHandler m => m [Text]
languages
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ [])) forall a b. b -> Either a b
Right) forall a b. (a -> b) -> a -> b
$ HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a)
f HandlerSite m
m [Text]
l Env
env FileEnv
fenv