yesod-form 1.0.0.4 → 1.1.0
raw patch · 10 files changed
+300/−92 lines, 10 filesdep +HUnitdep +attoparsecdep +crypto-apidep ~basedep ~blaze-htmldep ~data-default
Dependencies added: HUnit, attoparsec, crypto-api, hspec, yesod-form
Dependency ranges changed: base, blaze-html, data-default, hamlet, persistent, text, time, wai, yesod-core, yesod-persistent
Files
- Yesod/Form/Fields.hs +103/−46
- Yesod/Form/Functions.hs +54/−12
- Yesod/Form/I18n/Japanese.hs +26/−0
- Yesod/Form/I18n/Norwegian.hs +26/−0
- Yesod/Form/Jquery.hs +16/−13
- Yesod/Form/MassInput.hs +7/−1
- Yesod/Form/Nic.hs +1/−0
- Yesod/Form/Types.hs +1/−0
- test/main.hs +41/−0
- yesod-form.cabal +25/−20
Yesod/Form/Fields.hs view
@@ -47,6 +47,7 @@ import Yesod.Form.Types import Yesod.Form.I18n.English+import Yesod.Form.Functions (parseHelper) import Yesod.Handler (getMessageRender) import Yesod.Widget (toWidget, whamlet, GWidget) import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))@@ -67,7 +68,7 @@ import Database.Persist.Store (Entity (..)) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless)-import Data.Maybe (listToMaybe)+import Data.Maybe (listToMaybe, fromMaybe) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString)@@ -92,25 +93,23 @@ import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery) import Control.Arrow ((&&&)) -import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<|>)) +import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly)+ defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage -blank :: (Monad m, RenderMessage master FormMessage)- => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))-blank _ [] = return $ Right Nothing-blank _ ("":_) = return $ Right Nothing-blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i intField = Field- { fieldParse = blank $ \s ->+ { fieldParse = parseHelper $ \s -> case Data.Text.Read.signed Data.Text.Read.decimal s of Right (a, "") -> Right a _ -> Left $ MsgInvalidInteger s , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}"> |] }@@ -120,12 +119,13 @@ doubleField :: RenderMessage master FormMessage => Field sub master Double doubleField = Field- { fieldParse = blank $ \s ->+ { fieldParse = parseHelper $ \s -> case Data.Text.Read.double s of Right (a, "") -> Right a _ -> Left $ MsgInvalidNumber s , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}"> |] }@@ -133,8 +133,9 @@ dayField :: RenderMessage master FormMessage => Field sub master Day dayField = Field- { fieldParse = blank $ parseDate . unpack+ { fieldParse = parseHelper $ parseDate . unpack , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}"> |] }@@ -142,8 +143,9 @@ timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField = Field- { fieldParse = blank $ parseTime . unpack+ { fieldParse = parseHelper parseTime , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}"> |] }@@ -156,8 +158,9 @@ htmlField :: RenderMessage master FormMessage => Field sub master Html htmlField = Field- { fieldParse = blank $ Right . preEscapedText . sanitizeBalance+ { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+$newline never $# FIXME: There was a class="html" attribute, for what purpose? <textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val} |]@@ -167,7 +170,7 @@ -- | A newtype wrapper around a 'Text' that converts newlines to HTML -- br-tags. newtype Textarea = Textarea { unTextarea :: Text }- deriving (Show, Read, Eq, PersistField)+ deriving (Show, Read, Eq, PersistField, Ord) instance ToHtml Textarea where toHtml = unsafeByteString@@ -184,8 +187,9 @@ textareaField :: RenderMessage master FormMessage => Field sub master Textarea textareaField = Field- { fieldParse = blank $ Right . Textarea+ { fieldParse = parseHelper $ Right . Textarea , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+$newline never <textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val} |] }@@ -193,25 +197,28 @@ hiddenField :: (PathPiece p, RenderMessage master FormMessage) => Field sub master p hiddenField = Field- { fieldParse = blank $ maybe (Left MsgValueRequired) Right . fromPathPiece+ { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+$newline never <input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}"> |] } textField :: RenderMessage master FormMessage => Field sub master Text textField = Field- { fieldParse = blank $ Right+ { fieldParse = parseHelper $ Right , fieldView = \theId name attrs val isReq -> [whamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}"> |] } passwordField :: RenderMessage master FormMessage => Field sub master Text passwordField = Field- { fieldParse = blank $ Right+ { fieldParse = parseHelper $ Right , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}"> |] }@@ -230,37 +237,61 @@ replace :: Eq a => a -> a -> [a] -> [a] replace x y = map (\z -> if z == x then y else z) -parseTime :: String -> Either FormMessage TimeOfDay-parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =- parseTimeHelper (h1, h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =- let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12- in parseTimeHelper (h1', h2', m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =- parseTimeHelper (h1, h2, m1, m2, s1, s2)-parseTime _ = Left MsgInvalidTimeFormat+parseTime :: Text -> Either FormMessage TimeOfDay+parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser -parseTimeHelper :: (Char, Char, Char, Char, Char, Char)- -> Either FormMessage TimeOfDay-parseTimeHelper (h1, h2, m1, m2, s1, s2)- | h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]- | m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]- | s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]- | otherwise = Right $ TimeOfDay h m s+timeParser :: Parser TimeOfDay+timeParser = do+ skipSpace+ h <- hour+ _ <- char ':'+ m <- minsec MsgInvalidMinute+ hasSec <- (char ':' >> return True) <|> return False+ s <- if hasSec then minsec MsgInvalidSecond else return 0+ skipSpace+ isPM <-+ (string "am" >> return (Just False)) <|>+ (string "AM" >> return (Just False)) <|>+ (string "pm" >> return (Just True)) <|>+ (string "PM" >> return (Just True)) <|>+ return Nothing+ h' <-+ case isPM of+ Nothing -> return h+ Just x+ | h <= 0 || h > 12 -> fail $ show $ MsgInvalidHour $ pack $ show h+ | h == 12 -> return $ if x then 12 else 0+ | otherwise -> return $ h + (if x then 12 else 0)+ skipSpace+ endOfInput+ return $ TimeOfDay h' m s where- h = read [h1, h2] -- FIXME isn't this a really bad idea?- m = read [m1, m2]- s = fromInteger $ read [s1, s2]+ hour = do+ x <- digit+ y <- (return <$> digit) <|> return []+ let xy = x : y+ let i = read xy+ if i < 0 || i >= 24+ then fail $ show $ MsgInvalidHour $ pack xy+ else return i+ minsec :: Num a => (Text -> FormMessage) -> Parser a+ minsec msg = do+ x <- digit+ y <- digit <|> fail (show $ msg $ pack [x])+ let xy = [x, y]+ let i = read xy+ if i < 0 || i >= 60+ then fail $ show $ msg $ pack xy+ else return $ fromIntegral (i :: Int) emailField :: RenderMessage master FormMessage => Field sub master Text emailField = Field- { fieldParse = blank $+ { fieldParse = parseHelper $ \s -> if Email.isValid (unpack s) then Right s else Left $ MsgInvalidEmail s , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}"> |] }@@ -268,14 +299,18 @@ type AutoFocus = Bool searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text searchField autoFocus = Field- { fieldParse = blank Right+ { fieldParse = parseHelper Right , fieldView = \theId name attrs val isReq -> do [whamlet|\+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}"> |] when autoFocus $ do -- we want this javascript to be placed immediately after the field- [whamlet|<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}|]+ [whamlet|+$newline never+<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}+|] toWidget [cassius| #{theId} -webkit-appearance: textfield@@ -284,12 +319,13 @@ urlField :: RenderMessage master FormMessage => Field sub master Text urlField = Field- { fieldParse = blank $ \s ->+ { fieldParse = parseHelper $ \s -> case parseURI $ unpack s of Nothing -> Left $ MsgInvalidUrl s Just _ -> Right s , fieldView = \theId name attrs val isReq -> [whamlet|+$newline never <input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}> |] }@@ -299,9 +335,18 @@ selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a selectField = selectFieldHelper- (\theId name inside -> [whamlet|<select ##{theId} name=#{name}>^{inside}|]) -- outside- (\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt- (\_theId _name attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected *{attrs}>#{text}|]) -- inside+ (\theId name inside -> [whamlet|+$newline never+<select ##{theId} name=#{name}>^{inside}+|]) -- outside+ (\_theId _name isSel -> [whamlet|+$newline never+<option value=none :isSel:selected>_{MsgSelectNone}+|]) -- onOpt+ (\_theId _name attrs value isSel text -> [whamlet|+$newline never+<option value=#{value} :isSel:selected *{attrs}>#{text}+|]) -- inside multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a] multiSelectFieldList = multiSelectField . optionsPairs@@ -323,6 +368,7 @@ opts <- fmap olOptions $ lift ioptlist let selOpts = map (id &&& (optselected val)) opts [whamlet|+$newline never <select ##{theId} name=#{name} :isReq:required multiple *{attrs}> $forall (opt, optsel) <- selOpts <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}@@ -336,13 +382,18 @@ radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a radioField = selectFieldHelper- (\theId _name inside -> [whamlet|<div ##{theId}>^{inside}|])+ (\theId _name inside -> [whamlet|+$newline never+<div ##{theId}>^{inside}+|]) (\theId name isSel -> [whamlet|+$newline never <div> <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked> <label for=#{theId}-none>_{MsgSelectNone} |]) (\theId name attrs value isSel text -> [whamlet|+$newline never <div> <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}> <label for=#{theId}-#{value}>#{text}@@ -352,6 +403,7 @@ boolField = Field { fieldParse = return . boolParser , fieldView = \theId name attrs val isReq -> [whamlet|+$newline never $if not isReq <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked> <label for=#{theId}-none>_{MsgSelectNone}@@ -370,6 +422,7 @@ "" -> Right Nothing "none" -> Right Nothing "yes" -> Right $ Just True+ "on" -> Right $ Just True "no" -> Right $ Just False t -> Left $ SomeMessage $ MsgInvalidBool t showVal = either (\_ -> False)@@ -385,6 +438,7 @@ checkBoxField = Field { fieldParse = return . checkBoxParser , fieldView = \theId name attrs val _ -> [whamlet|+$newline never <input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked> |] }@@ -393,6 +447,7 @@ checkBoxParser [] = Right $ Just False checkBoxParser (x:_) = case x of "yes" -> Right $ Just True+ "on" -> Right $ Just True _ -> Right $ Just False showVal = either (\_ -> False)@@ -499,6 +554,7 @@ , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvId = id' , fvInput = [whamlet|+$newline never <input type=file name=#{name} ##{id'} *{fsAttrs fs}> |] , fvErrors = errs@@ -527,6 +583,7 @@ , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvId = id' , fvInput = [whamlet|+$newline never <input type=file name=#{name} ##{id'} *{fsAttrs fs}> |] , fvErrors = errs
Yesod/Form/Functions.hs view
@@ -27,6 +27,7 @@ , FormRender , renderTable , renderDivs+ , renderDivsNoLabels , renderBootstrap -- * Validation , check@@ -36,6 +37,7 @@ -- * Utilities , fieldSettingsLabel , aformM+ , parseHelper ) where import Yesod.Form.Types@@ -44,6 +46,7 @@ import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST) import Control.Monad.Trans.Class (lift) import Control.Monad (liftM, join)+import Crypto.Classes (constTimeEq) #if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze (Markup, toMarkup) #define Html Markup@@ -54,14 +57,14 @@ import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod) import Yesod.Core (RenderMessage, SomeMessage (..)) import Yesod.Widget (GWidget, whamlet)-import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages, FileInfo (..))+import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages) import Network.Wai (requestMethod) import Text.Hamlet (shamlet) import Data.Monoid (mempty) import Data.Maybe (listToMaybe, fromMaybe) import Yesod.Message (RenderMessage (..)) import qualified Data.Map as Map-import qualified Data.ByteString.Lazy as L+import qualified Data.Text.Encoding as TE import Control.Applicative ((<$>)) import Control.Arrow (first) @@ -187,16 +190,22 @@ let token = case reqToken req of Nothing -> mempty- Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]+ Just n -> [shamlet|+$newline never+<input type=hidden name=#{tokenKey} value=#{n}>+|] m <- getYesod langs <- languages ((res, xml), enctype) <- runFormGeneric (form token) m langs env let res' = case (res, env) of (FormSuccess{}, Just (params, _))- | Map.lookup tokenKey params /= fmap return (reqToken req) ->+ | not (Map.lookup tokenKey params === reqToken req) -> FormFailure [renderMessage m langs MsgCsrfWarning] _ -> res+ where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constTimeEq` TE.encodeUtf8 t2+ Nothing === Nothing = True -- ^ It's important to use constTimeEq+ _ === _ = False -- in order to avoid timing attacks. return ((res', xml), enctype) -- | Similar to 'runFormPost', except it always ignore the currently available@@ -217,9 +226,7 @@ else do (p, f) <- runRequestBody let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p- return $ Just (p', Map.fromList $ filter (notEmpty . snd) f)- where- notEmpty = not . L.null . fileContent+ return $ Just (p', Map.fromList f) runFormPostNoToken :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) runFormPostNoToken form = do@@ -245,7 +252,10 @@ getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype) getHelper form env = do- let fragment = [shamlet|<input type=hidden name=#{getKey}>|]+ let fragment = [shamlet|+$newline never+<input type=hidden name=#{getKey}>+|] langs <- languages m <- getYesod runFormGeneric (form fragment) m langs env@@ -255,12 +265,13 @@ -> Html -> MForm sub master (FormResult a, GWidget sub master ()) -renderTable, renderDivs :: FormRender sub master a+renderTable, renderDivs, renderDivsNoLabels :: FormRender sub master a renderTable aform fragment = do (res, views') <- aFormToForm aform let views = views' [] -- FIXME non-valid HTML let widget = [whamlet|+$newline never \#{fragment} $forall view <- views <tr :fvRequired view:.required :not $ fvRequired view:.optional>@@ -274,14 +285,23 @@ |] return (res, widget) -renderDivs aform fragment = do+-- | render a field inside a div+renderDivs = renderDivsMaybeLabels True++-- | render a field inside a div, not displaying any label+renderDivsNoLabels = renderDivsMaybeLabels False++renderDivsMaybeLabels :: Bool -> FormRender sub master a+renderDivsMaybeLabels withLabels aform fragment = do (res, views') <- aFormToForm aform let views = views' [] let widget = [whamlet|+$newline never \#{fragment} $forall view <- views <div :fvRequired view:.required :not $ fvRequired view:.optional>- <label for=#{fvId view}>#{fvLabel view}+ $if withLabels+ <label for=#{fvId view}>#{fvLabel view} $maybe tt <- fvTooltip view <div .tooltip>#{tt} ^{fvInput view}@@ -312,6 +332,7 @@ has (Just _) = True has Nothing = False let widget = [whamlet|+$newline never \#{fragment} $forall view <- views <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>@@ -338,13 +359,21 @@ => (a -> GHandler sub master (Either msg a)) -> Field sub master a -> Field sub master a-checkM f field = field+checkM f = checkM' f id++checkM' :: RenderMessage master msg+ => (a -> GHandler sub master (Either msg b))+ -> (b -> a)+ -> Field sub master a+ -> Field sub master b+checkM' f inv field = field { fieldParse = \ts -> do e1 <- fieldParse field ts case e1 of Left msg -> return $ Left msg Right Nothing -> return $ Right Nothing Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a+ , fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req } -- | Allows you to overwrite the error message on parse error.@@ -361,3 +390,16 @@ aformM action = AForm $ \_ _ ints -> do value <- action return (FormSuccess value, id, ints, mempty)++-- | A helper function for creating custom fields.+--+-- This is intended to help with the common case where a single input value is+-- required, such as when parsing a text field.+--+-- Since 1.1+parseHelper :: (Monad m, RenderMessage master FormMessage)+ => (Text -> Either FormMessage a)+ -> [Text] -> m (Either (SomeMessage master) (Maybe a))+parseHelper _ [] = return $ Right Nothing+parseHelper _ ("":_) = return $ Right Nothing+parseHelper f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x
+ Yesod/Form/I18n/Japanese.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Form.I18n.Japanese where++import Yesod.Form.Types (FormMessage (..))+import Data.Monoid (mappend)+import Data.Text (Text)++japaneseFormMessage :: FormMessage -> Text+japaneseFormMessage (MsgInvalidInteger t) = "無効な整数です: " `mappend` t+japaneseFormMessage (MsgInvalidNumber t) = "無効な数値です: " `mappend` t+japaneseFormMessage (MsgInvalidEntry t) = "無効な入力です: " `mappend` t+japaneseFormMessage MsgInvalidTimeFormat = "無効な時刻です。HH:MM[:SS]フォーマットで入力してください"+japaneseFormMessage MsgInvalidDay = "無効な日付です。YYYY-MM-DDフォーマットで入力してください"+japaneseFormMessage (MsgInvalidUrl t) = "無効なURLです: " `mappend` t+japaneseFormMessage (MsgInvalidEmail t) = "無効なメールアドレスです: " `mappend` t+japaneseFormMessage (MsgInvalidHour t) = "無効な時間です: " `mappend` t+japaneseFormMessage (MsgInvalidMinute t) = "無効な分です: " `mappend` t+japaneseFormMessage (MsgInvalidSecond t) = "無効な秒です: " `mappend` t+japaneseFormMessage MsgCsrfWarning = "CSRF攻撃を防ぐため、フォームの入力を確認してください"+japaneseFormMessage MsgValueRequired = "値は必須です"+japaneseFormMessage (MsgInputNotFound t) = "入力が見つかりません: " `mappend` t+japaneseFormMessage MsgSelectNone = "<なし>"+japaneseFormMessage (MsgInvalidBool t) = "無効なbool値です: " `mappend` t+japaneseFormMessage MsgBoolYes = "はい"+japaneseFormMessage MsgBoolNo = "いいえ"+japaneseFormMessage MsgDelete = "削除しますか?"
+ Yesod/Form/I18n/Norwegian.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Form.I18n.Norwegian where++import Yesod.Form.Types (FormMessage (..))+import Data.Monoid (mappend)+import Data.Text (Text)++norwegianBokmålFormMessage :: FormMessage -> Text+norwegianBokmålFormMessage (MsgInvalidInteger t) = "Ugyldig antall: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidNumber t) = "Ugyldig nummer: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidEntry t) = "Ugyldig oppføring: " `mappend` t+norwegianBokmålFormMessage MsgInvalidTimeFormat = "Ugyldig klokkeslett, må være i formatet HH:MM[:SS]"+norwegianBokmålFormMessage MsgInvalidDay = "Ugyldig dato, må være i formatet ÅÅÅÅ-MM-DD"+norwegianBokmålFormMessage (MsgInvalidUrl t) = "Ugyldig URL: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidEmail t) = "Ugyldig e-postadresse: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidHour t) = "Ugyldig time: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidMinute t) = "Ugyldig minutt: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidSecond t) = "Ugyldig sekund: " `mappend` t+norwegianBokmålFormMessage MsgValueRequired = "Feltet er obligatoriskt"+norwegianBokmålFormMessage (MsgInputNotFound t) = "Feltet ble ikke funnet: " `mappend` t+norwegianBokmålFormMessage MsgSelectNone = "<Ingenting>"+norwegianBokmålFormMessage (MsgInvalidBool t) = "Ugyldig boolsk: " `mappend` t+norwegianBokmålFormMessage MsgBoolYes = "Ja"+norwegianBokmålFormMessage MsgBoolNo = "Nei"+norwegianBokmålFormMessage MsgDelete = "Slett?"+norwegianBokmålFormMessage MsgCsrfWarning = "Som beskyttelse mot «cross-site request forgery»-angrep, vennligst bekreft innsendt skjema."
Yesod/Form/Jquery.hs view
@@ -23,7 +23,7 @@ import Text.Julius (julius) import Data.Text (Text, pack, unpack) import Data.Monoid (mconcat)-import Yesod.Core (RenderMessage, SomeMessage (..))+import Yesod.Core (RenderMessage) -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. googleHostedJqueryUiCss :: Text -> Text@@ -34,9 +34,15 @@ ] class YesodJquery a where- -- | The jQuery 1.4 Javascript file.+ -- | The jQuery Javascript file. Note that in upgrades to this library, the+ -- version of jQuery referenced, or where it is downloaded from, may be+ -- changed without warning. If you are relying on a specific version of+ -- jQuery, you should give an explicit URL instead of relying on the+ -- default value.+ --+ -- Currently, the default value is jQuery 1.7 from Google\'s CDN. urlJqueryJs :: a -> Either (Route a) Text- urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js"+ urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js" -- | The jQuery UI 1.8 Javascript file. urlJqueryUiJs :: a -> Either (Route a) Text@@ -50,20 +56,16 @@ urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -blank :: (RenderMessage master FormMessage, Monad m) => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))-blank _ [] = return $ Right Nothing-blank _ ("":_) = return $ Right Nothing-blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x- jqueryDayField :: (RenderMessage master FormMessage, YesodJquery master) => JqueryDaySettings -> Field sub master Day jqueryDayField jds = Field- { fieldParse = blank $ maybe+ { fieldParse = parseHelper $ maybe (Left MsgInvalidDay) Right . readMay . unpack , fieldView = \theId name attrs val isReq -> do toWidget [shamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}"> |] addScript' urlJqueryJs@@ -71,9 +73,9 @@ addStylesheet' urlJqueryUiCss toWidget [julius| $(function(){- var i = $("##{theId}");- if (i.attr("type") != "date") {- i.datepicker({+ var i = document.getElementById("#{theId}");+ if (i.type != "date") {+ $(i).datepicker({ dateFormat:'yy-mm-dd', changeMonth:#{jsBool $ jdsChangeMonth jds}, changeYear:#{jsBool $ jdsChangeYear jds},@@ -100,9 +102,10 @@ jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master) => Route master -> Field sub master Text jqueryAutocompleteField src = Field- { fieldParse = blank $ Right+ { fieldParse = parseHelper $ Right , fieldView = \theId name attrs val isReq -> do toWidget [shamlet|+$newline never <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete> |] addScript' urlJqueryJs
Yesod/Form/MassInput.hs view
@@ -80,6 +80,7 @@ , fvTooltip = Nothing , fvId = theId , fvInput = [whamlet|+$newline never ^{fixXml views} <p> $forall xml <- xmls@@ -100,7 +101,10 @@ deleteName <- newFormIdent (menv, _, _) <- ask res <- case menv >>= Map.lookup deleteName . fst of- Just ("yes":_) -> return $ Left [whamlet|<input type=hidden name=#{deleteName} value=yes>|]+ Just ("yes":_) -> return $ Left [whamlet|+$newline never+<input type=hidden name=#{deleteName} value=yes>+|] _ -> do (_, xml2) <- aFormToForm $ areq boolField FieldSettings { fsLabel = SomeMessage MsgDelete@@ -127,6 +131,7 @@ :: [[FieldView sub master]] -> GWidget sub master () massDivs viewss = [whamlet|+$newline never $forall views <- viewss <fieldset> $forall view <- views@@ -140,6 +145,7 @@ |] massTable viewss = [whamlet|+$newline never $forall views <- viewss <fieldset> <table>
Yesod/Form/Nic.hs view
@@ -38,6 +38,7 @@ { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe , fieldView = \theId name attrs val _isReq -> do toWidget [shamlet|+$newline never <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val} |] addScript' urlNicEdit
Yesod/Form/Types.hs view
@@ -151,3 +151,4 @@ | MsgBoolYes | MsgBoolNo | MsgDelete+ deriving (Show, Eq, Read)
+ test/main.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.HUnit+import Test.Hspec.Monadic+import Test.Hspec.HUnit ()+import Data.Time (TimeOfDay (TimeOfDay))+import Data.Text (pack)++import Yesod.Form.Fields (parseTime)+import Yesod.Form.Types++main :: IO ()+main = hspec $+ describe "parseTime" $ mapM_ (\(s, e) -> it s $ parseTime (pack s) @?= e)+ [ ("01:00:00", Right $ TimeOfDay 1 0 0)+ , ("1:00", Right $ TimeOfDay 1 0 0)+ , ("1:00 AM", Right $ TimeOfDay 1 0 0)+ , ("1:00 am", Right $ TimeOfDay 1 0 0)+ , ("1:00AM", Right $ TimeOfDay 1 0 0)+ , ("1:00am", Right $ TimeOfDay 1 0 0)+ , ("01:00:00am", Right $ TimeOfDay 1 0 0)+ , ("01:00:00 am", Right $ TimeOfDay 1 0 0)+ , ("01:00:00AM", Right $ TimeOfDay 1 0 0)+ , ("01:00:00 AM", Right $ TimeOfDay 1 0 0)+ , ("1:00:01", Right $ TimeOfDay 1 0 1)+ , ("1:00:02 AM", Right $ TimeOfDay 1 0 2)+ , ("1:00:04 am", Right $ TimeOfDay 1 0 4)+ , ("1:00:05 am", Right $ read "01:00:05")+ , ("1:00:64 am", Left $ MsgInvalidSecond "64")+ , ("1:00:4 am", Left $ MsgInvalidSecond "4")+ , ("0:00", Right $ TimeOfDay 0 0 0)+ , ("12:00am", Right $ TimeOfDay 0 0 0)+ , ("12:59:59am", Right $ TimeOfDay 0 59 59)+ , ("12:59:60am", Left $ MsgInvalidSecond "60")+ , ("12:60:59am", Left $ MsgInvalidMinute "60")+ , ("12:00pm", Right $ TimeOfDay 12 0 0)+ , ("12:59:59pm", Right $ TimeOfDay 12 59 59)+ , ("12:59:60pm", Left $ MsgInvalidSecond "60")+ , ("12:60:59pm", Left $ MsgInvalidMinute "60")+ , ("12:7pm", Left $ MsgInvalidMinute "7")+ , ("23:47", Right $ TimeOfDay 23 47 0)+ ]
yesod-form.cabal view
@@ -1,5 +1,5 @@ name: yesod-form-version: 1.0.0.4+version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -7,43 +7,35 @@ synopsis: Form handling support for Yesod Web Framework category: Web, Yesod stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ description: Form handling support for Yesod Web Framework -flag blaze_html_0_5- description: use blaze-html 0.5 and blaze-markup 0.5- default: True- library build-depends: base >= 4 && < 5- , yesod-core >= 1.0 && < 1.1- , yesod-persistent >= 1.0 && < 1.1+ , yesod-core >= 1.1 && < 1.2+ , yesod-persistent >= 1.1 && < 1.2 , time >= 1.1.4- , hamlet >= 1.0 && < 1.1+ , hamlet >= 1.1 && < 1.2 , shakespeare-css >= 1.0 && < 1.1 , shakespeare-js >= 1.0 && < 1.1- , persistent >= 0.9 && < 0.10+ , persistent >= 1.0 && < 1.1 , template-haskell , transformers >= 0.2.2 && < 0.4- , data-default >= 0.3 && < 0.5+ , data-default , xss-sanitize >= 0.3.0.1 && < 0.4 , blaze-builder >= 0.2.1.4 && < 0.4 , network >= 2.2 && < 2.4 , email-validate >= 0.2.6 && < 0.3 , bytestring >= 0.9.1.4 , text >= 0.9 && < 1.0- , wai >= 1.2 && < 1.3+ , wai >= 1.3 && < 1.4 , containers >= 0.2-- if flag(blaze_html_0_5)- build-depends:- blaze-html >= 0.5 && < 0.6- , blaze-markup >= 0.5.1 && < 0.6- else- build-depends:- blaze-html >= 0.4 && < 0.5+ , blaze-html >= 0.5 && < 0.6+ , blaze-markup >= 0.5.1 && < 0.6+ , attoparsec >= 0.10 && < 0.11+ , crypto-api >= 0.8 && < 0.11 exposed-modules: Yesod.Form Yesod.Form.Class@@ -59,8 +51,21 @@ Yesod.Form.I18n.Swedish Yesod.Form.I18n.German Yesod.Form.I18n.French+ Yesod.Form.I18n.Norwegian+ Yesod.Form.I18n.Japanese -- FIXME Yesod.Helpers.Crud ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ build-depends: base+ , yesod-form+ , time+ , hspec+ , HUnit+ , text source-repository head type: git