yesod-form-1.6.5/Yesod/0000755000000000000000000000000013456026413013064 5ustar0000000000000000yesod-form-1.6.5/Yesod/Form/0000755000000000000000000000000013501441754013767 5ustar0000000000000000yesod-form-1.6.5/Yesod/Form/I18n/0000755000000000000000000000000013456026413014506 5ustar0000000000000000yesod-form-1.6.5/test/0000755000000000000000000000000013456026413012760 5ustar0000000000000000yesod-form-1.6.5/Yesod/Form.hs0000644000000000000000000000050113456026413014317 0ustar0000000000000000-- | Parse forms (and query strings). module Yesod.Form ( module Yesod.Form.Types , module Yesod.Form.Functions , module Yesod.Form.Fields , module Yesod.Form.Input ) where import Yesod.Form.Types import Yesod.Form.Functions import Yesod.Form.Fields hiding (FormMessage (..)) import Yesod.Form.Input yesod-form-1.6.5/Yesod/Form/Types.hs0000644000000000000000000001700213456026413015427 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.Form.Types ( -- * Helpers Enctype (..) , FormResult (..) , FormMessage (..) , Env , FileEnv , Ints (..) -- * Form , WForm , MForm , AForm (..) -- * Build forms , Field (..) , FieldSettings (..) , FieldView (..) , FieldViewFunc ) where import Control.Monad.Trans.RWS (RWST) import Control.Monad.Trans.Writer (WriterT) import Data.Text (Text) import Data.Monoid (Monoid (..)) import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue)) #define Html Markup #define ToHtml ToMarkup #define toHtml toMarkup import Control.Applicative ((<$>), Alternative (..), Applicative (..)) import Control.Monad (liftM) import Control.Monad.Trans.Class import Data.String (IsString (..)) import Yesod.Core import qualified Data.Map as Map import Data.Semigroup (Semigroup, (<>)) import Data.Traversable import Data.Foldable -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. -- -- The 'Applicative' instance will concatenate the failure messages in two -- 'FormResult's. -- The 'Alternative' instance will choose 'FormFailure' before 'FormSuccess', -- and 'FormMissing' last of all. data FormResult a = FormMissing | FormFailure [Text] | FormSuccess a deriving (Show, Eq) instance Functor FormResult where fmap _ FormMissing = FormMissing fmap _ (FormFailure errs) = FormFailure errs fmap f (FormSuccess a) = FormSuccess $ f a instance Control.Applicative.Applicative FormResult where pure = FormSuccess (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y (FormFailure x) <*> _ = FormFailure x _ <*> (FormFailure y) = FormFailure y _ <*> _ = FormMissing instance Data.Monoid.Monoid m => Monoid (FormResult m) where mempty = pure mempty mappend x y = mappend <$> x <*> y instance Semigroup m => Semigroup (FormResult m) where x <> y = (<>) Control.Applicative.<$> x <*> y -- | @since 1.4.5 instance Data.Foldable.Foldable FormResult where foldMap f r = case r of FormSuccess a -> f a FormFailure _errs -> mempty FormMissing -> mempty -- | @since 1.4.5 instance Data.Traversable.Traversable FormResult where traverse f r = case r of FormSuccess a -> fmap FormSuccess (f a) FormFailure errs -> pure (FormFailure errs) FormMissing -> pure FormMissing -- | @since 1.4.15 instance Alternative FormResult where empty = FormMissing FormFailure e <|> _ = FormFailure e _ <|> FormFailure e = FormFailure e FormSuccess s <|> FormSuccess _ = FormSuccess s FormMissing <|> result = result result <|> FormMissing = result -- | The encoding type required by a form. The 'ToHtml' instance produces values -- that can be inserted directly into HTML. data Enctype = UrlEncoded | Multipart deriving (Eq, Enum, Bounded) instance ToHtml Enctype where toHtml UrlEncoded = "application/x-www-form-urlencoded" toHtml Multipart = "multipart/form-data" instance ToValue Enctype where toValue UrlEncoded = "application/x-www-form-urlencoded" toValue Multipart = "multipart/form-data" instance Monoid Enctype where mempty = UrlEncoded #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif instance Semigroup Enctype where UrlEncoded <> UrlEncoded = UrlEncoded _ <> _ = Multipart data Ints = IntCons Int Ints | IntSingle Int instance Show Ints where show (IntSingle i) = show i show (IntCons i is) = show i ++ ('-' : show is) type Env = Map.Map Text [Text] type FileEnv = Map.Map Text [FileInfo] -- | 'MForm' variant stacking a 'WriterT'. The following code example using a -- monadic form 'MForm': -- -- > formToAForm $ do -- > (field1F, field1V) <- mreq textField MsgField1 Nothing -- > (field2F, field2V) <- mreq (checkWith field1F textField) MsgField2 Nothing -- > (field3F, field3V) <- mreq (checkWith field1F textField) MsgField3 Nothing -- > return -- > ( MyForm <$> field1F <*> field2F <*> field3F -- > , [field1V, field2V, field3V] -- > ) -- -- Could be rewritten as follows using 'WForm': -- -- > wFormToAForm $ do -- > field1F <- wreq textField MsgField1 Nothing -- > field2F <- wreq (checkWith field1F textField) MsgField2 Nothing -- > field3F <- wreq (checkWith field1F textField) MsgField3 Nothing -- > return $ MyForm <$> field1F <*> field2F <*> field3F -- -- @since 1.4.14 type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a type MForm m a = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m a newtype AForm m a = AForm { unAForm :: (HandlerSite m, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints, Enctype) } instance Monad m => Functor (AForm m) where fmap f (AForm a) = AForm $ \x y z -> liftM go $ a x y z where go (w, x, y, z) = (fmap f w, x, y, z) instance Monad m => Applicative (AForm m) where pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, id, ints, mempty) (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do (a, b, ints', c) <- f mr env ints (x, y, ints'', z) <- g mr env ints' return (a <*> x, b . y, ints'', c `mappend` z) instance (Monad m, Monoid a) => Monoid (AForm m a) where mempty = pure mempty mappend a b = mappend <$> a <*> b instance (Monad m, Semigroup a) => Semigroup (AForm m a) where a <> b = (<>) <$> a <*> b instance MonadTrans AForm where lift f = AForm $ \_ _ ints -> do x <- f return (FormSuccess x, id, ints, mempty) data FieldSettings master = FieldSettings { fsLabel :: SomeMessage master , fsTooltip :: Maybe (SomeMessage master) , fsId :: Maybe Text , fsName :: Maybe Text , fsAttrs :: [(Text, Text)] } instance IsString (FieldSettings a) where fromString s = FieldSettings (fromString s) Nothing Nothing Nothing [] data FieldView site = FieldView { fvLabel :: Html , fvTooltip :: Maybe Html , fvId :: Text , fvInput :: WidgetFor site () , fvErrors :: Maybe Html , fvRequired :: Bool } type FieldViewFunc m a = Text -- ^ ID -> Text -- ^ Name -> [(Text, Text)] -- ^ Attributes -> Either Text a -- ^ Either (invalid text) or (legitimate result) -> Bool -- ^ Required? -> WidgetFor (HandlerSite m) () data Field m a = Field { fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)) , fieldView :: FieldViewFunc m a , fieldEnctype :: Enctype } data FormMessage = MsgInvalidInteger Text | MsgInvalidNumber Text | MsgInvalidEntry Text | MsgInvalidUrl Text | MsgInvalidEmail Text | MsgInvalidTimeFormat | MsgInvalidHour Text | MsgInvalidMinute Text | MsgInvalidSecond Text | MsgInvalidDay | MsgCsrfWarning | MsgValueRequired | MsgInputNotFound Text | MsgSelectNone | MsgInvalidBool Text | MsgBoolYes | MsgBoolNo | MsgDelete deriving (Show, Eq, Read) yesod-form-1.6.5/Yesod/Form/Functions.hs0000644000000000000000000005634513456026413016310 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Yesod.Form.Functions ( -- * Running in MForm monad newFormIdent , askParams , askFiles -- * Applicative/Monadic conversion , formToAForm , aFormToForm , mFormToWForm , wFormToAForm , wFormToMForm -- * Fields to Forms , wreq , wopt , mreq , mopt , areq , aopt -- * Run a form , runFormPost , runFormPostNoToken , runFormGet -- * Generate a blank form , generateFormPost , generateFormGet' , generateFormGet -- * More than one form on a handler , identifyForm -- * Rendering , FormRender , renderTable , renderDivs , renderDivsNoLabels , renderBootstrap , renderBootstrap2 -- * Validation , check , checkBool , checkM , checkMMap , customErrorMessage -- * Utilities , fieldSettingsLabel , parseHelper , parseHelperGen , convertField , addClass , removeClass ) where import Yesod.Form.Types import Data.Text (Text, pack) import qualified Data.Text as T import Control.Arrow (second) import Control.Monad.Trans.Class import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST) import Control.Monad.Trans.Writer (runWriterT, writer) import Control.Monad (liftM, join) import Data.Byteable (constEqBytes) import Text.Blaze (Markup, toMarkup) #define Html Markup #define toHtml toMarkup import Yesod.Core import Network.Wai (requestMethod) import Data.Monoid (mempty, (<>)) import Data.Maybe (listToMaybe, fromMaybe) import qualified Data.Map as Map import qualified Data.Text.Encoding as TE import Control.Arrow (first) -- | Get a unique identifier. newFormIdent :: Monad m => MForm m Text newFormIdent = do i <- get let i' = incrInts i put i' return $ pack $ 'f' : show i' where incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntCons i is) = (i + 1) `IntCons` is formToAForm :: (HandlerSite m ~ site, Monad m) => MForm m (FormResult a, [FieldView site]) -> AForm m a formToAForm form = AForm $ \(site, langs) env ints -> do ((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints return (a, (++) xmls, ints', enc) aFormToForm :: (Monad m, HandlerSite m ~ site) => AForm m a -> MForm m (FormResult a, [FieldView site] -> [FieldView site]) aFormToForm (AForm aform) = do ints <- get (env, site, langs) <- ask (a, xml, ints', enc) <- lift $ aform (site, langs) env ints put ints' tell enc return (a, xml) askParams :: Monad m => MForm m (Maybe Env) askParams = do (x, _, _) <- ask return $ liftM fst x askFiles :: Monad m => MForm m (Maybe FileEnv) askFiles = do (x, _, _) <- ask return $ liftM snd x -- | Converts a form field into monadic form 'WForm'. This field requires a -- value and will return 'FormFailure' if left empty. -- -- @since 1.4.14 wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -- ^ form field -> FieldSettings site -- ^ settings for this field -> Maybe a -- ^ optional default value -> WForm m (FormResult a) wreq f fs = mFormToWForm . mreq f fs -- | Converts a form field into monadic form 'WForm'. This field is optional, -- i.e. if filled in, it returns 'Just a', if left empty, it returns -- 'Nothing'. Arguments are the same as for 'wreq' (apart from type of default -- value). -- -- @since 1.4.14 wopt :: (MonadHandler m, HandlerSite m ~ site) => Field m a -- ^ form field -> FieldSettings site -- ^ settings for this field -> Maybe (Maybe a) -- ^ optional default value -> WForm m (FormResult (Maybe a)) wopt f fs = mFormToWForm . mopt f fs -- | Converts a monadic form 'WForm' into an applicative form 'AForm'. -- -- @since 1.4.14 wFormToAForm :: MonadHandler m => WForm m (FormResult a) -- ^ input form -> AForm m a -- ^ output form wFormToAForm = formToAForm . wFormToMForm -- | Converts a monadic form 'WForm' into another monadic form 'MForm'. -- -- @since 1.4.14 wFormToMForm :: (MonadHandler m, HandlerSite m ~ site) => WForm m a -- ^ input form -> MForm m (a, [FieldView site]) -- ^ output form wFormToMForm = mapRWST (fmap group . runWriterT) where group ((a, ints, enctype), views) = ((a, views), ints, enctype) -- | Converts a monadic form 'MForm' into another monadic form 'WForm'. -- -- @since 1.4.14 mFormToWForm :: (MonadHandler m, HandlerSite m ~ site) => MForm m (a, FieldView site) -- ^ input form -> WForm m a -- ^ output form mFormToWForm = mapRWST $ \f -> do ((a, view), ints, enctype) <- lift f writer ((a, ints, enctype), [view]) -- | Converts a form field into monadic form. This field requires a value -- and will return 'FormFailure' if left empty. mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -- ^ form field -> FieldSettings site -- ^ settings for this field -> Maybe a -- ^ optional default value -> MForm m (FormResult a, FieldView site) mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True -- | Converts a form field into monadic form. This field is optional, i.e. -- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'. -- Arguments are the same as for 'mreq' (apart from type of default value). mopt :: (site ~ HandlerSite m, MonadHandler m) => Field m a -> FieldSettings site -> Maybe (Maybe a) -> MForm m (FormResult (Maybe a), FieldView site) mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False mhelper :: (site ~ HandlerSite m, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> (site -> [Text] -> FormResult b) -- ^ on missing -> (a -> FormResult b) -- ^ on success -> Bool -- ^ is it required? -> MForm m (FormResult b, FieldView site) mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do tell fieldEnctype mp <- askParams name <- maybe newFormIdent return fsName theId <- lift $ maybe newIdent return fsId (_, site, langs) <- ask let mr2 = renderMessage site langs (res, val) <- case mp of Nothing -> return (FormMissing, maybe (Left "") Right mdef) Just p -> do mfs <- askFiles let mvals = fromMaybe [] $ Map.lookup name p files = fromMaybe [] $ mfs >>= Map.lookup name emx <- lift $ fieldParse mvals files return $ case emx of Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals)) Right mx -> case mx of Nothing -> (onMissing site langs, Left "") Just x -> (onFound x, Right x) return (res, FieldView { fvLabel = toHtml $ mr2 fsLabel , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip , fvId = theId , fvInput = fieldView theId name fsAttrs val isReq , fvErrors = case res of FormFailure [e] -> Just $ toHtml e _ -> Nothing , fvRequired = isReq }) -- | Applicative equivalent of 'mreq'. areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> AForm m a areq a b = formToAForm . liftM (second return) . mreq a b -- | Applicative equivalent of 'mopt'. aopt :: MonadHandler m => Field m a -> FieldSettings (HandlerSite m) -> Maybe (Maybe a) -> AForm m (Maybe a) aopt a b = formToAForm . liftM (second return) . mopt a b runFormGeneric :: Monad m => MForm m a -> HandlerSite m -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype) runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0) -- | This function is used to both initially render a form and to later extract -- results from it. Note that, due to CSRF protection and a few other issues, -- forms submitted via GET and POST are slightly different. As such, be sure to -- call the relevant function based on how the form will be submitted, /not/ -- the current request method. -- -- For example, a common case is displaying a form on a GET request and having -- the form submit to a POST page. In such a case, both the GET and POST -- handlers should use 'runFormPost'. runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m) => (Html -> MForm m (FormResult a, xml)) -> m ((FormResult a, xml), Enctype) runFormPost form = do env <- postEnv postHelper form env postHelper :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => (Html -> MForm m (FormResult a, xml)) -> Maybe (Env, FileEnv) -> m ((FormResult a, xml), Enctype) postHelper form env = do req <- getRequest let tokenKey = defaultCsrfParamName let token = case reqToken req of Nothing -> Data.Monoid.mempty Just n -> [shamlet||] m <- getYesod langs <- languages ((res, xml), enctype) <- runFormGeneric (form token) m langs env let res' = case (res, env) of (_, Nothing) -> FormMissing (FormSuccess{}, Just (params, _)) | not (Map.lookup tokenKey params === reqToken req) -> FormFailure [renderMessage m langs MsgCsrfWarning] _ -> res -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks. where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2 Nothing === Nothing = True _ === _ = False return ((res', xml), enctype) -- | Similar to 'runFormPost', except it always ignores the currently available -- environment. This is necessary in cases like a wizard UI, where a single -- page will both receive and incoming form and produce a new, blank form. For -- general usage, you can stick with @runFormPost@. generateFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m) => (Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype) generateFormPost form = first snd `liftM` postHelper form Nothing postEnv :: MonadHandler m => m (Maybe (Env, FileEnv)) postEnv = do req <- getRequest if requestMethod (reqWaiRequest req) == "GET" then return Nothing else do (p, f) <- runRequestBody let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f) runFormPostNoToken :: MonadHandler m => (Html -> MForm m a) -> m (a, Enctype) runFormPostNoToken form = do langs <- languages m <- getYesod env <- postEnv runFormGeneric (form mempty) m langs env runFormGet :: MonadHandler m => (Html -> MForm m a) -> m (a, Enctype) runFormGet form = do gets <- liftM reqGetParams getRequest let env = case lookup getKey gets of Nothing -> Nothing Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty) getHelper form env {- FIXME: generateFormGet' "Will be renamed to generateFormGet in next version of Yesod" -} -- | -- -- Since 1.3.11 generateFormGet' :: MonadHandler m => (Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype) generateFormGet' form = first snd `liftM` getHelper form Nothing {-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-} generateFormGet :: MonadHandler m => (Html -> MForm m a) -> m (a, Enctype) generateFormGet form = getHelper form Nothing getKey :: Text getKey = "_hasdata" getHelper :: MonadHandler m => (Html -> MForm m a) -> Maybe (Env, FileEnv) -> m (a, Enctype) getHelper form env = do let fragment = [shamlet||] langs <- languages m <- getYesod runFormGeneric (form fragment) m langs env -- | Creates a hidden field on the form that identifies it. This -- identification is then used to distinguish between /missing/ -- and /wrong/ form data when a single handler contains more than -- one form. -- -- For instance, if you have the following code on your handler: -- -- > ((fooRes, fooWidget), fooEnctype) <- runFormPost fooForm -- > ((barRes, barWidget), barEnctype) <- runFormPost barForm -- -- Then replace it with -- -- > ((fooRes, fooWidget), fooEnctype) <- runFormPost $ identifyForm "foo" fooForm -- > ((barRes, barWidget), barEnctype) <- runFormPost $ identifyForm "bar" barForm -- -- Note that it's your responsibility to ensure that the -- identification strings are unique (using the same one twice on a -- single handler will not generate any errors). This allows you -- to create a variable number of forms and still have them work -- even if their number or order change between the HTML -- generation and the form submission. identifyForm :: Monad m => Text -- ^ Form identification string. -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())) -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())) identifyForm identVal form = \fragment -> do -- Create hidden . let fragment' = [shamlet| #{fragment} |] -- Check if we got its value back. mp <- askParams let missing = (mp >>= Map.lookup identifyFormKey) /= Just ["identify-" <> identVal] -- Run the form proper (with our hidden ). If the -- data is missing, then do not provide any params to the -- form, which will turn its result into FormMissing. Also, -- doing this avoids having lots of fields with red errors. let eraseParams | missing = local (\(_, h, l) -> (Nothing, h, l)) | otherwise = id ( res', w) <- eraseParams (form fragment') -- Empty forms now properly return FormMissing. [#1072](https://github.com/yesodweb/yesod/issues/1072) let res = if missing then FormMissing else res' return ( res, w) identifyFormKey :: Text identifyFormKey = "_formid" type FormRender m a = AForm m a -> Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()) renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a -- | Render a form into a series of tr tags. Note that, in order to allow -- you to add extra rows to the table, this function does /not/ wrap up -- the resulting HTML in a table tag; you must do that yourself. renderTable aform fragment = do (res, views') <- aFormToForm aform let views = views' [] let widget = [whamlet| $newline never $if null views \#{fragment} $forall (isFirst, view) <- addIsFirst views $if isFirst \#{fragment}