yesod-form 1.1.4.1 → 1.2.0
raw patch · 7 files changed
+83/−42 lines, 7 filesdep +aesondep ~shakespeare-js
Dependencies added: aeson
Dependency ranges changed: shakespeare-js
Files
- Yesod/Form/Fields.hs +34/−6
- Yesod/Form/Functions.hs +13/−9
- Yesod/Form/Input.hs +16/−13
- Yesod/Form/Jquery.hs +10/−7
- Yesod/Form/Nic.hs +5/−4
- Yesod/Form/Types.hs +2/−1
- yesod-form.cabal +3/−2
Yesod/Form/Fields.hs view
@@ -27,6 +27,7 @@ , Textarea (..) , boolField , checkBoxField+ , fileField -- * File 'AForm's , fileAFormReq , fileAFormOpt@@ -104,6 +105,7 @@ $newline never <input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}"> |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . showI)@@ -120,6 +122,7 @@ $newline never <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}"> |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . show) @@ -130,6 +133,7 @@ $newline never <input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}"> |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . show) @@ -140,6 +144,7 @@ $newline never <input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}"> |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . show . roundFullSeconds)@@ -156,6 +161,7 @@ $# FIXME: There was a class="html" attribute, for what purpose? <textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val} |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . renderHtml) @@ -184,6 +190,7 @@ $newline never <textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val} |]+ , fieldEnctype = UrlEncoded } hiddenField :: (PathPiece p, RenderMessage master FormMessage)@@ -194,6 +201,7 @@ $newline never <input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}"> |]+ , fieldEnctype = UrlEncoded } textField :: RenderMessage master FormMessage => Field sub master Text@@ -204,6 +212,7 @@ $newline never <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}"> |]+ , fieldEnctype = UrlEncoded } passwordField :: RenderMessage master FormMessage => Field sub master Text@@ -213,6 +222,7 @@ $newline never <input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}"> |]+ , fieldEnctype = UrlEncoded } readMay :: Read a => String -> Maybe a@@ -286,6 +296,7 @@ $newline never <input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}"> |]+ , fieldEnctype = UrlEncoded } type AutoFocus = Bool@@ -307,6 +318,7 @@ #{theId} -webkit-appearance: textfield |]+ , fieldEnctype = UrlEncoded } urlField :: RenderMessage master FormMessage => Field sub master Text@@ -320,6 +332,7 @@ $newline never <input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}> |]+ , fieldEnctype = UrlEncoded } selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a@@ -347,10 +360,10 @@ => GHandler sub master (OptionList a) -> Field sub master [a] multiSelectField ioptlist =- Field parse view+ Field parse view UrlEncoded where- parse [] = return $ Right Nothing- parse optlist = do+ parse [] _ = return $ Right Nothing+ parse optlist _ = do mapopt <- olReadExternal <$> ioptlist case mapM mapopt optlist of Nothing -> return $ Left "Error parsing values"@@ -395,7 +408,7 @@ boolField :: RenderMessage master FormMessage => Field sub master Bool boolField = Field- { fieldParse = return . boolParser+ { fieldParse = \e _ -> return $ boolParser e , fieldView = \theId name attrs val isReq -> [whamlet| $newline never $if not isReq@@ -409,6 +422,7 @@ <input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked> <label for=#{theId}-no>_{MsgBoolNo} |]+ , fieldEnctype = UrlEncoded } where boolParser [] = Right Nothing@@ -430,11 +444,12 @@ -- checkBoxField :: RenderMessage m FormMessage => Field s m Bool checkBoxField = Field- { fieldParse = return . checkBoxParser+ { fieldParse = \e _ -> return $ checkBoxParser e , fieldView = \theId name attrs val _ -> [whamlet| $newline never <input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked> |]+ , fieldEnctype = UrlEncoded } where@@ -499,7 +514,7 @@ -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ()) -> GHandler sub master (OptionList a) -> Field sub master a selectFieldHelper outside onOpt inside opts' = Field- { fieldParse = \x -> do+ { fieldParse = \x _ -> do opts <- opts' return $ selectParser opts x , fieldView = \theId name attrs val isReq -> do@@ -513,6 +528,7 @@ (optionExternalValue opt) ((render opts val) == optionExternalValue opt) (optionDisplay opt)+ , fieldEnctype = UrlEncoded } where render _ (Left _) = ""@@ -524,6 +540,18 @@ x -> case olReadExternal opts x of Nothing -> Left $ SomeMessage $ MsgInvalidEntry x Just y -> Right $ Just y++fileField :: RenderMessage master FormMessage => Field sub master FileInfo+fileField = Field+ { fieldParse = \_ files -> return $+ case files of+ [] -> Right Nothing+ file:_ -> Right $ Just file+ , fieldView = \id' name attrs _ isReq -> toWidget [hamlet|+ <input id=#{id'} name=#{name} *{attrs} type=file :isReq:required>+ |]+ , fieldEnctype = Multipart+ } fileAFormReq :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master FileInfo fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
Yesod/Form/Functions.hs view
@@ -65,6 +65,7 @@ import qualified Data.Text.Encoding as TE import Control.Applicative ((<$>)) import Control.Arrow (first)+import Yesod.Request (FileInfo) -- | Get a unique identifier. newFormIdent :: MForm sub master Text@@ -119,6 +120,7 @@ -> MForm sub master (FormResult b, FieldView sub master) mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do+ tell fieldEnctype mp <- askParams name <- maybe newFormIdent return fsName theId <- lift $ maybe newIdent return fsId@@ -128,8 +130,10 @@ case mp of Nothing -> return (FormMissing, maybe (Left "") Right mdef) Just p -> do+ mfs <- askFiles let mvals = fromMaybe [] $ Map.lookup name p- emx <- lift $ fieldParse mvals+ files = fromMaybe [] $ mfs >>= Map.lookup name+ emx <- lift $ fieldParse mvals files return $ case emx of Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals)) Right mx ->@@ -371,8 +375,8 @@ -> Field sub master a -> Field sub master b checkMMap f inv field = field- { fieldParse = \ts -> do- e1 <- fieldParse field ts+ { fieldParse = \ts fs -> do+ e1 <- fieldParse field ts fs case e1 of Left msg -> return $ Left msg Right Nothing -> return $ Right Nothing@@ -393,8 +397,8 @@ -- | Allows you to overwrite the error message on parse error. customErrorMessage :: SomeMessage master -> Field sub master a -> Field sub master a-customErrorMessage msg field = field { fieldParse = \ts -> fmap (either-(const $ Left msg) Right) $ fieldParse field ts }+customErrorMessage msg field = field { fieldParse = \ts fs -> fmap (either+(const $ Left msg) Right) $ fieldParse field ts fs } -- | Generate a 'FieldSettings' from the given label. fieldSettingsLabel :: RenderMessage master msg => msg -> FieldSettings master@@ -414,7 +418,7 @@ -- 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+ -> [Text] -> [FileInfo] -> 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/Input.hs view
@@ -17,16 +17,17 @@ import Yesod.Message (RenderMessage (..), SomeMessage (..)) import qualified Data.Map as Map import Data.Maybe (fromMaybe)+import Control.Arrow ((***)) type DText = [Text] -> [Text]-newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GHandler sub master (Either DText a) }+newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> FileEnv -> GHandler sub master (Either DText a) } instance Functor (FormInput sub master) where- fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e+ fmap a (FormInput f) = FormInput $ \c d e e' -> fmap (either Left (Right . a)) $ f c d e e' instance Applicative (FormInput sub master) where- pure = FormInput . const . const . const . return . Right- (FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do- res1 <- f c d e- res2 <- x c d e+ pure = FormInput . const . const . const . const . return . Right+ (FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do+ res1 <- f c d e e'+ res2 <- x c d e e' return $ case (res1, res2) of (Left a, Left b) -> Left $ a . b (Left a, _) -> Left a@@ -34,18 +35,20 @@ (Right a, Right b) -> Right $ a b ireq :: (RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a-ireq field name = FormInput $ \m l env -> do+ireq field name = FormInput $ \m l env fenv -> do let filteredEnv = fromMaybe [] $ Map.lookup name env- emx <- fieldParse field $ filteredEnv+ filteredFEnv = fromMaybe [] $ Map.lookup name fenv+ emx <- fieldParse field filteredEnv filteredFEnv 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 iopt :: Field sub master a -> Text -> FormInput sub master (Maybe a)-iopt field name = FormInput $ \m l env -> do+iopt field name = FormInput $ \m l env fenv -> do let filteredEnv = fromMaybe [] $ Map.lookup name env- emx <- fieldParse field $ filteredEnv+ filteredFEnv = fromMaybe [] $ Map.lookup name fenv+ emx <- fieldParse field filteredEnv filteredFEnv return $ case emx of Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e Right x -> Right x@@ -55,7 +58,7 @@ env <- liftM (toMap . reqGetParams) getRequest m <- getYesod l <- languages- emx <- f m l env+ emx <- f m l env Map.empty case emx of Left errs -> invalidArgs $ errs [] Right x -> return x@@ -65,10 +68,10 @@ runInputPost :: FormInput sub master a -> GHandler sub master a runInputPost (FormInput f) = do- env <- liftM (toMap . fst) runRequestBody+ (env, fenv) <- liftM (toMap *** toMap) runRequestBody m <- getYesod l <- languages- emx <- f m l env+ emx <- f m l env fenv case emx of Left errs -> invalidArgs $ errs [] Right x -> return x
Yesod/Form/Jquery.hs view
@@ -20,10 +20,11 @@ import Data.Time (Day) import Data.Default import Text.Hamlet (shamlet)-import Text.Julius (julius)+import Text.Julius (julius, rawJS) import Data.Text (Text, pack, unpack) import Data.Monoid (mconcat) import Yesod.Core (RenderMessage)+import Data.Aeson (toJSON) -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. googleHostedJqueryUiCss :: Text -> Text@@ -73,23 +74,24 @@ addStylesheet' urlJqueryUiCss toWidget [julius| $(function(){- var i = document.getElementById("#{theId}");+ var i = document.getElementById("#{rawJS theId}"); if (i.type != "date") { $(i).datepicker({ dateFormat:'yy-mm-dd', changeMonth:#{jsBool $ jdsChangeMonth jds}, changeYear:#{jsBool $ jdsChangeYear jds},- numberOfMonths:#{mos $ jdsNumberOfMonths jds},- yearRange:"#{jdsYearRange jds}"+ numberOfMonths:#{rawJS $ mos $ jdsNumberOfMonths jds},+ yearRange:#{toJSON $ jdsYearRange jds} }); } }); |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . show)- jsBool True = "true" :: Text- jsBool False = "false" :: Text+ jsBool True = toJSON True+ jsBool False = toJSON False mos (Left i) = show i mos (Right (x, y)) = concat [ "["@@ -112,8 +114,9 @@ addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss toWidget [julius|-$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});+$(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:2})}); |]+ , fieldEnctype = UrlEncoded } addScript' :: (master -> Either (Route master) Text) -> GWidget sub master ()
Yesod/Form/Nic.hs view
@@ -16,7 +16,7 @@ import Yesod.Widget import Text.HTML.SanitizeXSS (sanitizeBalance) import Text.Hamlet (Html, shamlet)-import Text.Julius (julius)+import Text.Julius (julius, rawJS) #if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze (preEscapedToMarkup) import Text.Blaze.Html.Renderer.String (renderHtml)@@ -35,7 +35,7 @@ nicHtmlField :: YesodNic master => Field sub master Html nicHtmlField = Field- { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe+ { fieldParse = \e _ -> return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe $ e , fieldView = \theId name attrs val _isReq -> do toWidget [shamlet| $newline never@@ -46,11 +46,12 @@ toWidget $ case jsLoader master of BottomOfHeadBlocking -> [julius|-bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});+bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")}); |] _ -> [julius|-(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")})();+(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")})(); |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . renderHtml)
Yesod/Form/Types.hs view
@@ -133,8 +133,9 @@ -> GWidget sub master () data Field sub master a = Field- { fieldParse :: [Text] -> GHandler sub master (Either (SomeMessage master) (Maybe a))+ { fieldParse :: [Text] -> [FileInfo] -> GHandler sub master (Either (SomeMessage master) (Maybe a)) , fieldView :: FieldViewFunc sub master a+ , fieldEnctype :: Enctype } data FormMessage = MsgInvalidInteger Text
yesod-form.cabal view
@@ -1,5 +1,5 @@ name: yesod-form-version: 1.1.4.1+version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -19,7 +19,7 @@ , time >= 1.1.4 , hamlet >= 1.1 && < 1.2 , shakespeare-css >= 1.0 && < 1.1- , shakespeare-js >= 1.0 && < 1.1+ , shakespeare-js >= 1.0.2 && < 1.2 , persistent >= 1.0 && < 1.1 , template-haskell , transformers >= 0.2.2 && < 0.4@@ -36,6 +36,7 @@ , blaze-markup >= 0.5.1 && < 0.6 , attoparsec >= 0.10 && < 0.11 , crypto-api >= 0.8 && < 0.11+ , aeson exposed-modules: Yesod.Form Yesod.Form.Class