yesod-form 0.2.0.1 → 0.3.1
raw patch · 9 files changed
+545/−266 lines, 9 filesdep +containersdep +shakespeare-cssdep +shakespeare-jsdep −web-routes-quasidep ~data-defaultdep ~hamletdep ~persistent
Dependencies added: containers, shakespeare-css, shakespeare-js
Dependencies removed: web-routes-quasi
Dependency ranges changed: data-default, hamlet, persistent, xss-sanitize, yesod-core, yesod-persistent
Files
- Yesod/Form/Class.hs +25/−24
- Yesod/Form/Fields.hs +120/−91
- Yesod/Form/Functions.hs +135/−60
- Yesod/Form/Input.hs +38/−26
- Yesod/Form/Jquery.hs +26/−21
- Yesod/Form/MassInput.hs +158/−0
- Yesod/Form/Nic.hs +11/−14
- Yesod/Form/Types.hs +20/−22
- yesod-form.cabal +12/−8
Yesod/Form/Class.hs view
@@ -3,26 +3,27 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Form.Class- ( ToForm (..)- , ToField (..)+ ( {- FIXME ToForm (..)+ , -} ToField (..) ) where import Text.Hamlet-import Yesod.Widget (GGWidget) import Yesod.Form.Fields import Yesod.Form.Types import Yesod.Form.Functions (areq, aopt) import Data.Int (Int64) import Data.Time (Day, TimeOfDay) import Data.Text (Text)-import Yesod.Handler (GGHandler) import Yesod.Message (RenderMessage) -class ToForm a master monad where- toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a+{-+class ToForm a where+ toForm :: AForm sub master a+-} -class ToField a master monad where- toField :: RenderMessage master msg => FieldSettings msg -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a+class ToField a master where+ toField :: (RenderMessage master msg, RenderMessage master FormMessage)+ => FieldSettings msg -> Maybe a -> AForm sub master a {- FIXME instance ToFormField String y where@@ -31,44 +32,44 @@ toFormField = maybeStringField -} -instance (Monad m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where+instance ToField Text master where toField = areq textField-instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where+instance ToField (Maybe Text) master where toField = aopt textField -instance (Monad m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where+instance ToField Int master where toField = areq intField-instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where+instance ToField (Maybe Int) master where toField = aopt intField -instance (Monad m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where+instance ToField Int64 master where toField = areq intField-instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where+instance ToField (Maybe Int64) master where toField = aopt intField -instance (Monad m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where+instance ToField Double master where toField = areq doubleField-instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where+instance ToField (Maybe Double) master where toField = aopt doubleField -instance (Monad m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where+instance ToField Day master where toField = areq dayField-instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where+instance ToField (Maybe Day) master where toField = aopt dayField -instance (Monad m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where+instance ToField TimeOfDay master where toField = areq timeField-instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where+instance ToField (Maybe TimeOfDay) master where toField = aopt timeField -instance (Monad m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where+instance ToField Html master where toField = areq htmlField-instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where+instance ToField (Maybe Html) master where toField = aopt htmlField -instance (Monad m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where+instance ToField Textarea master where toField = areq textareaField-instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where+instance ToField (Maybe Textarea) master where toField = aopt textareaField {- FIXME
Yesod/Form/Fields.hs view
@@ -17,6 +17,7 @@ , emailField , searchField , selectField+ , multiSelectField , AutoFocus , urlField , doubleField@@ -29,10 +30,9 @@ import Yesod.Form.Types import Yesod.Widget-import Yesod.Message (RenderMessage)-import Yesod.Handler (GGHandler)-import Text.Hamlet hiding (renderHtml)-import Text.Blaze (ToHtml (..))+import Yesod.Message (RenderMessage, SomeMessage (..))+import Text.Hamlet+import Text.Blaze (ToHtml (..), preEscapedText, unsafeByteString) import Text.Cassius import Data.Time (Day, TimeOfDay(..)) import qualified Text.Email.Validate as Email@@ -40,6 +40,9 @@ import Database.Persist (PersistField) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless)+import Data.List (intersect, nub)+import Data.Either (rights)+import Data.Maybe (catMaybes) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString)@@ -51,7 +54,6 @@ import Data.Text (Text, unpack, pack) import qualified Data.Text.Read import Data.Monoid (mappend)-import Text.Hamlet.NonPoly (html) #if __GLASGOW_HASKELL__ >= 700 #define WHAMLET whamlet@@ -84,6 +86,7 @@ | MsgInvalidBool Text | MsgBoolYes | MsgBoolNo+ | MsgDelete defaultFormMessage :: FormMessage -> Text defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t@@ -103,74 +106,78 @@ defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t defaultFormMessage MsgBoolYes = "Yes" defaultFormMessage MsgBoolNo = "No"+defaultFormMessage MsgDelete = "Delete?" -blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)-blank _ Nothing = Right Nothing-blank _ (Just "") = Right Nothing-blank f (Just t) = either Left (Right . Just) $ f t+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 :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i+intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i intField = Field { fieldParse = blank $ \s -> case Data.Text.Read.signed Data.Text.Read.decimal s of Right (a, "") -> Right a _ -> Left $ MsgInvalidInteger s- , fieldRender = pack . showI+ , fieldView = \theId name val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">+<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}"> |] } where+ showVal = either id (pack . showI) showI x = show (fromIntegral x :: Integer) -doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double+doubleField :: RenderMessage master FormMessage => Field sub master Double doubleField = Field { fieldParse = blank $ \s -> case Data.Text.Read.double s of Right (a, "") -> Right a _ -> Left $ MsgInvalidNumber s- , fieldRender = pack . show+ , fieldView = \theId name val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}"> |] }+ where showVal = either id (pack . show) -dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day+dayField :: RenderMessage master FormMessage => Field sub master Day dayField = Field { fieldParse = blank $ parseDate . unpack- , fieldRender = pack . show , fieldView = \theId name val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}"> |] }+ where showVal = either id (pack . show) -timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay+timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField = Field { fieldParse = blank $ parseTime . unpack- , fieldRender = pack . show . roundFullSeconds , fieldView = \theId name val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}"> |] } where+ showVal = either id (pack . show . roundFullSeconds) roundFullSeconds tod = TimeOfDay (todHour tod) (todMin tod) fullSec where fullSec = fromInteger $ floor $ todSec tod -htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html+htmlField :: RenderMessage master FormMessage => Field sub master Html htmlField = Field- { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize- , fieldRender = pack . renderHtml+ { fieldParse = blank $ Right . preEscapedText . sanitizeBalance , fieldView = \theId name val _isReq -> addHamlet [HAMLET|\-<textarea id="#{theId}" name="#{name}" .html>#{val}+<textarea id="#{theId}" name="#{name}" .html>#{showVal val} |] }+ where showVal = either id (pack . renderHtml) -- | A newtype wrapper around a 'String' that converts newlines to HTML -- br-tags.@@ -190,43 +197,39 @@ writeHtmlEscapedChar '\n' = writeByteString "<br>" writeHtmlEscapedChar c = B.writeHtmlEscapedChar c -textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea+textareaField :: RenderMessage master FormMessage => Field sub master Textarea textareaField = Field- { fieldParse = blank $ Right . Textarea- , fieldRender = unTextarea+ { fieldParse = blank $ Right . Textarea , fieldView = \theId name val _isReq -> addHamlet [HAMLET|\-<textarea id="#{theId}" name="#{name}">#{val}+<textarea id="#{theId}" name="#{name}">#{either id unTextarea val} |] } -hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+hiddenField :: RenderMessage master FormMessage => Field sub master Text hiddenField = Field { fieldParse = blank $ Right- , fieldRender = id , fieldView = \theId name val _isReq -> addHamlet [HAMLET|\-<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">+<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}"> |] } -textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+textField :: RenderMessage master FormMessage => Field sub master Text textField = Field { fieldParse = blank $ Right- , fieldRender = id , fieldView = \theId name val isReq -> [WHAMLET|-<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{val}">+<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}"> |] } -passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+passwordField :: RenderMessage master FormMessage => Field sub master Text passwordField = Field { fieldParse = blank $ Right- , fieldRender = id , fieldView = \theId name val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}">+<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}"> |] } @@ -268,30 +271,28 @@ m = read [m1, m2] s = fromInteger $ read [s1, s2] -emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+emailField :: RenderMessage master FormMessage => Field sub master Text emailField = Field { fieldParse = blank $ \s -> if Email.isValid (unpack s) then Right s else Left $ MsgInvalidEmail s- , fieldRender = id , fieldView = \theId name val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">+<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}"> |] } type AutoFocus = Bool-searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text+searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text searchField autoFocus = Field { fieldParse = blank Right- , fieldRender = id , fieldView = \theId name val isReq -> do- addHtml [HAMLET|\-<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">+ [WHAMLET|\+<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}"> |] when autoFocus $ do- addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> + [WHAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> |] addCassius [CASSIUS| #{theId}@@ -299,26 +300,30 @@ |] } -urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+urlField :: RenderMessage master FormMessage => Field sub master Text urlField = Field { fieldParse = blank $ \s -> case parseURI $ unpack s of Nothing -> Left $ MsgInvalidUrl s Just _ -> Right s- , fieldRender = id- , fieldView = \theId name val isReq -> addHtml- [HAMLET|-<input ##{theId} name=#{name} type=url :isReq:required value=#{val}>+ , fieldView = \theId name val isReq ->+ [WHAMLET|+<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}> |] } -selectField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a+selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a selectField = selectFieldHelper (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])- (\_theId _name value isSel text -> addHtml [HTML|<option value=#{value} :isSel:selected>#{text}|])+ (\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) -radioField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a+multiSelectField :: (Show a, Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]+multiSelectField = multiSelectFieldHelper+ (\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])+ (\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])++radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a radioField = selectFieldHelper (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|]) (\theId name isSel -> [WHAMLET|@@ -332,61 +337,85 @@ <label for=#{theId}-#{value}>#{text} |]) -boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool+boolField :: RenderMessage master FormMessage => Field sub master Bool boolField = Field- { fieldParse = \s ->- case s of- Nothing -> Right Nothing- Just "" -> Right Nothing- Just "none" -> Right Nothing- Just "yes" -> Right $ Just True- Just "no" -> Right $ Just False- Just t -> Left $ MsgInvalidBool t- , fieldRender = \a -> if a then "yes" else "no"- , fieldView = \theId name val isReq -> [WHAMLET|-$if not isReq- <input id=#{theId}-none type=radio name=#{name} value=none :isNone val:checked>- <label for=#{theId}-none>_{MsgSelectNone}+ { fieldParse = return . boolParser+ , fieldView = \theId name val isReq -> [WHAMLET|+ $if not isReq+ <input id=#{theId}-none type=radio name=#{name} value=none checked>+ <label for=#{theId}-none>_{MsgSelectNone} -<input id=#{theId}-yes type=radio name=#{name} value=yes :(==) val "yes":checked>++<input id=#{theId}-yes type=radio name=#{name} value=yes :showVal id val:checked> <label for=#{theId}-yes>_{MsgBoolYes} -<input id=#{theId}-no type=radio name=#{name} value=no :(==) val "no":checked>+<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked> <label for=#{theId}-no>_{MsgBoolNo} |] } where- isNone val = not $ val `elem` ["yes", "no"]+ boolParser [] = Right Nothing+ boolParser (x:_) = case x of+ "" -> Right Nothing+ "none" -> Right Nothing+ "yes" -> Right $ Just True+ "no" -> Right $ Just False+ t -> Left $ SomeMessage $ MsgInvalidBool t+ showVal = either (\_ -> False) -selectFieldHelper :: (Eq a, Monad monad)- => (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())- -> (Text -> Text -> Bool -> GGWidget master monad ())- -> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())- -> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a+multiSelectFieldHelper :: (Show a, Eq a)+ => (Text -> Text -> GWidget sub master () -> GWidget sub master ())+ -> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())+ -> [(Text, a)] -> Field sub master [a]+multiSelectFieldHelper outside inside opts = Field+ { fieldParse = return . selectParser+ , fieldView = \theId name vals _ ->+ outside theId name $ do+ flip mapM_ pairs $ \pair -> inside+ theId+ name+ (pack $ show $ fst pair)+ ((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values+ (fst $ snd pair)+ }+ where+ pairs = zip [1 :: Int ..] opts -- FIXME use IntMap+ rpairs = zip (map snd opts) [1 :: Int ..]+ selectedVals vals = map snd $ filter (\y -> fst y `elem` vals) rpairs+ selectParser [] = Right Nothing+ selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing+ | otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs++selectFieldHelper+ :: (Eq a, RenderMessage master FormMessage)+ => (Text -> Text -> GWidget sub master () -> GWidget sub master ())+ -> (Text -> Text -> Bool -> GWidget sub master ())+ -> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())+ -> [(Text, a)] -> Field sub master a selectFieldHelper outside onOpt inside opts = Field- { fieldParse = \s ->- case s of- Nothing -> Right Nothing- Just "" -> Right Nothing- Just "none" -> Right Nothing- Just x ->- case Data.Text.Read.decimal x of- Right (a, "") ->- case lookup a pairs of- Nothing -> Left $ MsgInvalidEntry x- Just y -> Right $ Just $ snd y- _ -> Left $ MsgInvalidNumber x- , fieldRender = \a -> maybe "" (pack . show) $ lookup a rpairs+ { fieldParse = return . selectParser , fieldView = \theId name val isReq -> outside theId name $ do- unless isReq $ onOpt theId name $ not $ val `elem` map (pack . show . fst) pairs+ unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs flip mapM_ pairs $ \pair -> inside theId name (pack $ show $ fst pair)- (val == pack (show $ fst pair))+ ((render val) == pack (show $ fst pair)) (fst $ snd pair) } where pairs = zip [1 :: Int ..] opts -- FIXME use IntMap rpairs = zip (map snd opts) [1 :: Int ..]+ render (Left _) = ""+ render (Right a) = maybe "" (pack . show) $ lookup a rpairs+ selectParser [] = Right Nothing+ selectParser (s:_) = case s of+ "" -> Right Nothing+ "none" -> Right Nothing+ x -> case Data.Text.Read.decimal x of+ Right (a, "") ->+ case lookup a pairs of+ Nothing -> Left $ SomeMessage $ MsgInvalidEntry x+ Just y -> Right $ Just $ snd y+ _ -> Left $ SomeMessage $ MsgInvalidNumber x
Yesod/Form/Functions.hs view
@@ -20,10 +20,17 @@ , runFormPost , runFormPostNoNonce , runFormGet+ -- * Generate a blank form+ , generateFormPost+ , generateFormGet -- * Rendering , FormRender , renderTable , renderDivs+ -- * Validation+ , check+ , checkBool+ , checkM ) where import Yesod.Form.Types@@ -34,25 +41,27 @@ import Control.Monad (liftM, join) import Text.Blaze (Html, toHtml) import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)-import Yesod.Core (RenderMessage)-import Yesod.Widget (GGWidget, whamlet)+import Yesod.Core (RenderMessage, liftIOHandler, SomeMessage (..))+import Yesod.Widget (GWidget, whamlet) import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages) import Network.Wai (requestMethod)-import Text.Hamlet.NonPoly (html)+import Text.Hamlet (shamlet) import Data.Monoid (mempty)-import Data.Maybe (fromMaybe)+import Data.Maybe (listToMaybe, fromMaybe) import Yesod.Message (RenderMessage (..))+import Control.Monad.IO.Class (MonadIO)+import qualified Data.Map as Map #if __GLASGOW_HASKELL__ >= 700 #define WHAMLET whamlet-#define HTML html+#define HTML shamlet #else-#define HTML $html+#define HTML $shamlet #define WHAMLET $whamlet #endif -- | Get a unique identifier.-newFormIdent :: Monad m => Form msg m Text+newFormIdent :: Form sub master Text newFormIdent = do i <- get let i' = incrInts i@@ -62,12 +71,12 @@ incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntCons i is) = (i + 1) `IntCons` is -formToAForm :: Monad m => Form msg m (FormResult a, xml) -> AForm ([xml] -> [xml]) msg m a+formToAForm :: Form sub master (FormResult a, FieldView sub master) -> AForm sub master a formToAForm form = AForm $ \(master, langs) env ints -> do ((a, xml), ints', enc) <- runRWST form (env, master, langs) ints return (a, (:) xml, ints', enc) -aFormToForm :: Monad m => AForm xml msg m a -> Form msg m (FormResult a, xml)+aFormToForm :: AForm sub master a -> Form sub master (FormResult a, [FieldView sub master] -> [FieldView sub master]) aFormToForm (AForm aform) = do ints <- get (env, master, langs) <- ask@@ -76,52 +85,53 @@ tell enc return (a, xml) -askParams :: Monad m => Form msg m (Maybe Env)+askParams :: Form sub master (Maybe Env) askParams = do (x, _, _) <- ask return $ liftM fst x -askFiles :: Monad m => Form msg m (Maybe FileEnv)+askFiles :: Form sub master (Maybe FileEnv) askFiles = do (x, _, _) <- ask return $ liftM snd x -mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage)- => Field xml msg a -> FieldSettings msg2 -> Maybe a- -> Form master (GGHandler sub master m) (FormResult a, FieldView xml)+mreq :: (RenderMessage master msg, RenderMessage master FormMessage)+ => Field sub master a -> FieldSettings msg -> Maybe a+ -> Form sub master (FormResult a, FieldView sub master) mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True -mopt :: (Monad m, RenderMessage master msg, RenderMessage master msg2)- => Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)- -> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)+mopt :: RenderMessage master msg+ => Field sub master a -> FieldSettings msg -> Maybe (Maybe a)+ -> Form sub master (FormResult (Maybe a), FieldView sub master) mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False -mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)- => Field xml msg a- -> FieldSettings msg2+mhelper :: RenderMessage master msg+ => Field sub master a+ -> FieldSettings msg -> Maybe a -> (master -> [Text] -> FormResult b) -- ^ on missing -> (a -> FormResult b) -- ^ on success -> Bool -- ^ is it required?- -> Form master (GGHandler sub master m) (FormResult b, FieldView xml)+ -> Form sub master (FormResult b, FieldView sub master)+ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mp <- askParams name <- maybe newFormIdent return fsName theId <- lift $ maybe (liftM pack newIdent) return fsId (_, master, langs) <- ask let mr2 = renderMessage master langs- let (res, val) =- case mp of- Nothing -> (FormMissing, maybe "" fieldRender mdef)- Just p ->- let mval = lookup name p- valB = fromMaybe "" mval- in case fieldParse mval of- Left e -> (FormFailure [renderMessage master langs e], valB)- Right mx ->- case mx of- Nothing -> (onMissing master langs, valB)- Just x -> (onFound x, valB)+ (res, val) <-+ case mp of+ Nothing -> return (FormMissing, maybe (Left "") Right mdef)+ Just p -> do+ let mvals = fromMaybe [] $ Map.lookup name p+ emx <- lift $ fieldParse mvals+ return $ case emx of+ Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))+ Right mx ->+ case mx of+ Nothing -> (onMissing master langs, Left "")+ Just x -> (onFound x, Right x) return (res, FieldView { fvLabel = toHtml $ mr2 fsLabel , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip@@ -134,71 +144,114 @@ , fvRequired = isReq }) -areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage)- => Field xml msg1 a -> FieldSettings msg2 -> Maybe a- -> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a+areq :: (RenderMessage master msg, RenderMessage master FormMessage)+ => Field sub master a -> FieldSettings msg -> Maybe a+ -> AForm sub master a areq a b = formToAForm . mreq a b -aopt :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)- => Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a)- -> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a)+aopt :: RenderMessage master msg+ => Field sub master a+ -> FieldSettings msg+ -> Maybe (Maybe a)+ -> AForm sub master (Maybe a) aopt a b = formToAForm . mopt a b -runFormGeneric :: Monad m => Form master m a -> master -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype)-runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)+runFormGeneric :: MonadIO m => Form sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype)+runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, master, langs) (IntSingle 1) +-- | 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 master FormMessage- => (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)+ => (Html -> Form sub master (FormResult a, xml))+ -> GHandler sub master ((FormResult a, xml), Enctype) runFormPost form = do+ env <- postEnv+ postHelper form env++postHelper :: RenderMessage master FormMessage+ => (Html -> Form sub master (FormResult a, xml))+ -> Maybe (Env, FileEnv)+ -> GHandler sub master ((FormResult a, xml), Enctype)+postHelper form env = do req <- getRequest let nonceKey = "_nonce" let nonce = case reqNonce req of Nothing -> mempty Just n -> [HTML|<input type=hidden name=#{nonceKey} value=#{n}>|]- env <- if requestMethod (reqWaiRequest req) == "GET"- then return Nothing- else fmap Just runRequestBody m <- getYesod langs <- languages ((res, xml), enctype) <- runFormGeneric (form nonce) m langs env let res' = case (res, env) of (FormSuccess{}, Just (params, _))- | lookup nonceKey params /= reqNonce req ->+ | Map.lookup nonceKey params /= fmap return (reqNonce req) -> FormFailure [renderMessage m langs MsgCsrfWarning] _ -> res return ((res', xml), enctype) -runFormPostNoNonce :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)-runFormPostNoNonce form = do+-- | Similar to 'runFormPost', except it always ignore 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 master FormMessage+ => (Html -> Form sub master (FormResult a, xml))+ -> GHandler sub master ((FormResult a, xml), Enctype)+generateFormPost form = postHelper form Nothing++postEnv :: GHandler sub master (Maybe (Env, FileEnv))+postEnv = do req <- getRequest- env <- if requestMethod (reqWaiRequest req) == "GET"- then return Nothing- else fmap Just runRequestBody+ 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.fromList f)++runFormPostNoNonce :: (Html -> Form sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)+runFormPostNoNonce form = do langs <- languages m <- getYesod+ env <- postEnv runFormGeneric (form mempty) m langs env -runFormGet :: Monad m => (Html -> Form master (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype)+runFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype) runFormGet form = do- let key = "_hasdata"- let fragment = [HTML|<input type=hidden name=#{key}>|] gets <- liftM reqGetParams getRequest let env =- case lookup key gets of+ case lookup getKey gets of Nothing -> Nothing- Just _ -> Just (gets, [])+ Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)+ getHelper form env++generateFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype)+generateFormGet form = getHelper form Nothing++getKey :: Text+getKey = "_hasdata"++getHelper :: (Html -> Form sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)+getHelper form env = do+ let fragment = [HTML|<input type=hidden name=#{getKey}>|] langs <- languages m <- getYesod runFormGeneric (form fragment) m langs env -type FormRender master msg m a =- AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) msg m a+type FormRender sub master a =+ AForm sub master a -> Html- -> Form msg m (FormResult a, GGWidget master m ())+ -> Form sub master (FormResult a, GWidget sub master ()) -renderTable, renderDivs :: Monad m => FormRender master msg m a+renderTable, renderDivs :: FormRender sub master a renderTable aform fragment = do (res, views') <- aFormToForm aform let views = views' []@@ -232,3 +285,25 @@ <div .errors>#{err} |] return (res, widget)++check :: RenderMessage master msg+ => (a -> Either msg a) -> Field sub master a -> Field sub master a+check f = checkM $ return . f++-- | Return the given error message if the predicate is false.+checkBool :: RenderMessage master msg+ => (a -> Bool) -> msg -> Field sub master a -> Field sub master a+checkBool b s = check $ \x -> if b x then Right x else Left s++checkM :: RenderMessage master msg+ => (a -> GGHandler sub master IO (Either msg a))+ -> Field sub master a+ -> Field sub master a+checkM f 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+ }
Yesod/Form/Input.hs view
@@ -12,52 +12,64 @@ import Yesod.Form.Fields (FormMessage (MsgInputNotFound)) import Data.Text (Text) import Control.Applicative (Applicative (..))-import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod)+import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod, liftIOHandler) import Yesod.Request (reqGetParams, languages) import Control.Monad (liftM)-import Yesod.Widget (GWidget)-import Yesod.Message (RenderMessage (..))+import Yesod.Message (RenderMessage (..), SomeMessage (..))+import qualified Data.Map as Map+import Data.Maybe (fromMaybe) type DText = [Text] -> [Text]-newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> Either DText a }-instance Functor (FormInput master) where- fmap a (FormInput f) = FormInput $ \c d e -> either Left (Right . a) $ f c d e-instance Applicative (FormInput master) where- pure = FormInput . const . const . const . Right- (FormInput f) <*> (FormInput x) = FormInput $ \c d e ->- case (f c d e, x c d e) of+newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GGHandler sub master IO (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+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+ 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 -ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a-ireq field name = FormInput $ \m l env ->- case fieldParse field $ lookup name env of- Left e -> Left $ (:) $ renderMessage m l e- Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name- Right (Just a) -> Right a+ireq :: (RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a+ireq field name = FormInput $ \m l env -> do+ let filteredEnv = fromMaybe [] $ Map.lookup name env+ emx <- fieldParse field $ filteredEnv+ 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 :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)-iopt field name = FormInput $ \m l env ->- case fieldParse field $ lookup name env of- Left e -> Left $ (:) $ renderMessage m l e+iopt :: Field sub master a -> Text -> FormInput sub master (Maybe a)+iopt field name = FormInput $ \m l env -> do+ let filteredEnv = fromMaybe [] $ Map.lookup name env+ emx <- fieldParse field $ filteredEnv+ return $ case emx of+ Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e Right x -> Right x -runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a+runInputGet :: FormInput sub master a -> GHandler sub master a runInputGet (FormInput f) = do- env <- liftM reqGetParams getRequest+ env <- liftM (toMap . reqGetParams) getRequest m <- getYesod l <- languages- case f m l env of+ emx <- liftIOHandler $ f m l env+ case emx of Left errs -> invalidArgs $ errs [] Right x -> return x -runInputPost :: FormInput master a -> GHandler sub master a+toMap :: [(Text, a)] -> Map.Map Text [a]+toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])++runInputPost :: FormInput sub master a -> GHandler sub master a runInputPost (FormInput f) = do- env <- liftM fst runRequestBody+ env <- liftM (toMap . fst) runRequestBody m <- getYesod l <- languages- case f m l env of+ emx <- liftIOHandler $ f m l env+ case emx of Left errs -> invalidArgs $ errs [] Right x -> return x
Yesod/Form/Jquery.hs view
@@ -22,17 +22,20 @@ timeToTimeOfDay) import Data.Char (isSpace) import Data.Default-import Text.Hamlet (hamlet)+import Text.Hamlet (shamlet) import Text.Julius (julius) import Control.Monad.Trans.Class (lift) import Data.Text (Text, pack, unpack) import Data.Monoid (mconcat)+import Yesod.Core (RenderMessage, SomeMessage (..)) #if __GLASGOW_HASKELL__ >= 700+#define HTML shamlet #define HAMLET hamlet #define CASSIUS cassius #define JULIUS julius #else+#define HTML $shamlet #define HAMLET $hamlet #define CASSIUS $cassius #define JULIUS $julius@@ -63,22 +66,21 @@ urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)-blank _ Nothing = Right Nothing-blank _ (Just "") = Right Nothing-blank f (Just t) = either Left (Right . Just) $ f t+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 :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day+jqueryDayField :: (RenderMessage master FormMessage, YesodJquery master) => JqueryDaySettings -> Field sub master Day jqueryDayField jds = Field { fieldParse = blank $ maybe (Left MsgInvalidDay) Right . readMay . unpack- , fieldRender = pack . show , fieldView = \theId name val isReq -> do- addHtml [HAMLET|\-<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">+ addHtml [HTML|\+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}"> |] addScript' urlJqueryJs addScript' urlJqueryUiJs@@ -94,6 +96,7 @@ |] } where+ showVal = either id (pack . show) jsBool True = "true" :: Text jsBool False = "false" :: Text mos (Left i) = show i@@ -121,28 +124,30 @@ where showTimeOfDay (TimeOfDay hour minute _) = let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")- in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm+ in (showLeadingZero h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm -jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime+jqueryDayTimeField :: (RenderMessage master FormMessage, YesodJquery master) => Field sub master UTCTime jqueryDayTimeField = Field { fieldParse = blank $ parseUTCTime . unpack- , fieldRender = pack . jqueryDayTimeUTCTime , fieldView = \theId name val isReq -> do- addHtml [HAMLET|\-<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">+ addHtml [HTML|\+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}"> |] addScript' urlJqueryJs addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss addJulius [JULIUS|-$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});+$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd hh:MM TT"})}); |] }+ where+ showVal = either id (pack . jqueryDayTimeUTCTime) parseUTCTime :: String -> Either FormMessage UTCTime parseUTCTime s =- let (dateS, timeS) = break isSpace (dropWhile isSpace s)+ let (dateS, timeS') = break isSpace (dropWhile isSpace s)+ timeS = drop 1 timeS' dateE = parseDate dateS in case dateE of Left l -> Left l@@ -150,13 +155,13 @@ ifRight (parseTime timeS) (UTCTime date . timeOfDayToTime) -jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text+jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master)+ => Route master -> Field sub master Text jqueryAutocompleteField src = Field- { fieldParse = Right- , fieldRender = id+ { fieldParse = blank $ Right , fieldView = \theId name val isReq -> do- addHtml [HAMLET|\-<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete>+ addHtml [HTML|\+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete> |] addScript' urlJqueryJs addScript' urlJqueryUiJs
+ Yesod/Form/MassInput.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Form.MassInput+ ( inputList+ , massDivs+ , massTable+ ) where++import Yesod.Form.Types+import Yesod.Form.Functions+import Yesod.Form.Fields (boolField, FormMessage (MsgDelete))+import Yesod.Widget (GWidget, whamlet)+import Yesod.Message (RenderMessage)+import Yesod.Handler (newIdent, GGHandler)+import Text.Blaze (Html)+import Control.Monad.Trans.Class (lift)+import Data.Text (pack)+import Control.Monad.Trans.RWS (get, put, ask)+import Data.Maybe (fromMaybe)+import Data.Text.Read (decimal)+import Control.Monad (liftM)+import Data.Either (partitionEithers)+import Data.Traversable (sequenceA)+import qualified Data.Map as Map+import Data.Maybe (listToMaybe)++#if __GLASGOW_HASKELL__ >= 700+#define WHAMLET whamlet+#define HTML html+#else+#define HTML $html+#define WHAMLET $whamlet+#endif++down :: Int -> Form sub master ()+down 0 = return ()+down i | i < 0 = error "called down with a negative number"+down i = do+ is <- get+ put $ IntCons 0 is+ down $ i - 1++up :: Int -> Form sub master ()+up 0 = return ()+up i | i < 0 = error "called down with a negative number"+up i = do+ is <- get+ case is of+ IntSingle _ -> error "up on IntSingle"+ IntCons _ is' -> put is' >> newFormIdent >> return ()+ up $ i - 1++inputList :: (m ~ GGHandler sub master IO, xml ~ GWidget sub master (), RenderMessage master FormMessage)+ => Html+ -> ([[FieldView sub master]] -> xml)+ -> (Maybe a -> AForm sub master a)+ -> (Maybe [a] -> AForm sub master [a])+inputList label fixXml single mdef = formToAForm $ do+ theId <- lift newIdent+ down 1+ countName <- newFormIdent+ addName <- newFormIdent+ (menv, _, _) <- ask+ let readInt t =+ case decimal t of+ Right (i, "") -> Just i+ _ -> Nothing+ let vals =+ case menv of+ Nothing -> map Just $ fromMaybe [] mdef+ Just (env, _) ->+ let toAdd = maybe False (const True) $ Map.lookup addName env+ count' = fromMaybe 0 $ Map.lookup countName env >>= listToMaybe >>= readInt+ count = (if toAdd then 1 else 0) + count'+ in replicate count Nothing+ let count = length vals+ (res, xmls, views) <- liftM fixme $ mapM (withDelete . single) vals+ up 1+ return (res, FieldView+ { fvLabel = label+ , fvTooltip = Nothing+ , fvId = pack theId+ , fvInput = [WHAMLET|+^{fixXml views}+<p>+ $forall xml <- xmls+ ^{xml}+ <input .count type=hidden name=#{countName} value=#{count}>+ <input type=checkbox name=#{addName}>+ Add another row+|]+ , fvErrors = Nothing+ , fvRequired = False+ })++withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage)+ => AForm sub master a+ -> Form sub master (Either xml (FormResult a, [FieldView sub master]))+withDelete af = do+ down 1+ deleteName <- newFormIdent+ (menv, _, _) <- ask+ res <- case menv >>= Map.lookup deleteName . fst of+ Just ("yes":_) -> return $ Left [WHAMLET|<input type=hidden name=#{deleteName} value=yes>|]+ _ -> do+ (_, xml2) <- aFormToForm $ areq boolField FieldSettings+ { fsLabel = MsgDelete+ , fsTooltip = Nothing+ , fsName = Just deleteName+ , fsId = Nothing+ } $ Just False+ (res, xml) <- aFormToForm af+ return $ Right (res, xml $ xml2 [])+ up 1+ return res++fixme :: (xml ~ GWidget sub master ())+ => [Either xml (FormResult a, [FieldView sub master])]+ -> (FormResult [a], [xml], [[FieldView sub master]])+fixme eithers =+ (res, xmls, map snd rest)+ where+ (xmls, rest) = partitionEithers eithers+ res = sequenceA $ map fst rest++massDivs, massTable+ :: [[FieldView sub master]]+ -> GWidget sub master ()+massDivs viewss = [WHAMLET|+$forall views <- viewss+ <fieldset>+ $forall view <- views+ <div :fvRequired view:.required :not $ fvRequired view:.optional>+ <label for=#{fvId view}>#{fvLabel view}+ $maybe tt <- fvTooltip view+ <div .tooltip>#{tt}+ ^{fvInput view}+ $maybe err <- fvErrors view+ <div .errors>#{err}+|]++massTable viewss = [WHAMLET|+$forall views <- viewss+ <fieldset>+ <table>+ $forall view <- views+ <tr :fvRequired view:.required :not $ fvRequired view:.optional>+ <td>+ <label for=#{fvId view}>#{fvLabel view}+ $maybe tt <- fvTooltip view+ <div .tooltip>#{tt}+ <td>^{fvInput view}+ $maybe err <- fvErrors view+ <td .errors>#{err}+|]
Yesod/Form/Nic.hs view
@@ -14,35 +14,30 @@ import Yesod.Form import Yesod.Widget import Text.HTML.SanitizeXSS (sanitizeBalance)-import Text.Hamlet (Html, hamlet)+import Text.Hamlet (Html, shamlet) import Text.Julius (julius) import Text.Blaze.Renderer.String (renderHtml)-import Text.Blaze (preEscapedString)+import Text.Blaze (preEscapedText) import Control.Monad.Trans.Class (lift)-import Data.Text (Text, pack, unpack)+import Data.Text (Text, pack)+import Data.Maybe (listToMaybe) class YesodNic a where -- | NIC Editor Javascript file. urlNicEdit :: a -> Either (Route a) Text urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" -blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)-blank _ Nothing = Right Nothing-blank _ (Just "") = Right Nothing-blank f (Just t) = either Left (Right . Just) $ f t--nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html+nicHtmlField :: YesodNic master => Field sub master Html nicHtmlField = Field- { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME- , fieldRender = pack . renderHtml+ { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe , fieldView = \theId name val _isReq -> do addHtml #if __GLASGOW_HASKELL__ >= 700- [hamlet|+ [shamlet| #else- [$hamlet|+ [$shamlet| #endif- <textarea id="#{theId}" name="#{name}" .html>#{val}+ <textarea id="#{theId}" name="#{name}" .html>#{showVal val} |] addScript' urlNicEdit addJulius@@ -54,6 +49,8 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")}); |] }+ where+ showVal = either id (pack . renderHtml) addScript' :: (y -> Either (Route y) Text) -> GWidget sub y () addScript' f = do
Yesod/Form/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-} module Yesod.Form.Types ( -- * Helpers Enctype (..)@@ -24,7 +25,8 @@ import Control.Applicative ((<$>), Applicative (..)) import Control.Monad (liftM) import Data.String (IsString (..))-import Control.Monad.Trans.Class (MonadTrans (..))+import Yesod.Core (GGHandler, GWidget, SomeMessage)+import qualified Data.Map as Map -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse.@@ -67,35 +69,32 @@ show (IntSingle i) = show i show (IntCons i is) = show i ++ ('-' : show is) -type Env = [(Text, Text)] -- FIXME use a Map-type FileEnv = [(Text, FileInfo)]+type Env = Map.Map Text [Text]+type FileEnv = Map.Map Text FileInfo -type Form master m a = RWST (Maybe (Env, FileEnv), master, [Text]) Enctype Ints m a+type Lang = Text+type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a -newtype AForm xml master m a = AForm- { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)+newtype AForm sub master a = AForm+ { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GGHandler sub master IO (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype) }-instance Monad m => Functor (AForm xml msg m) where+instance Functor (AForm sub master) 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, Monoid xml) => Applicative (AForm xml msg m) where+instance Applicative (AForm sub master) where pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, 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 `mappend` y, ints'', c `mappend` z)-instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml msg m a) where+instance Monoid a => Monoid (AForm sub master a) where mempty = pure mempty mappend a b = mappend <$> a <*> b-instance Monoid xml => MonadTrans (AForm xml msg) where- lift mx = AForm $ const $ const $ \ints -> do- x <- mx- return (pure x, mempty, ints, mempty) data FieldSettings msg = FieldSettings- { fsLabel :: msg+ { fsLabel :: msg -- FIXME switch to SomeMessage? , fsTooltip :: Maybe msg , fsId :: Maybe Text , fsName :: Maybe Text@@ -104,22 +103,21 @@ instance (a ~ Text) => IsString (FieldSettings a) where fromString s = FieldSettings (fromString s) Nothing Nothing Nothing -data FieldView xml = FieldView+data FieldView sub master = FieldView { fvLabel :: Html , fvTooltip :: Maybe Html , fvId :: Text- , fvInput :: xml+ , fvInput :: GWidget sub master () , fvErrors :: Maybe Html , fvRequired :: Bool } -data Field xml msg a = Field- { fieldParse :: Maybe Text -> Either msg (Maybe a)- , fieldRender :: a -> Text- -- | ID, name, value, required+data Field sub master a = Field+ { fieldParse :: [Text] -> GGHandler sub master IO (Either (SomeMessage master) (Maybe a))+ -- | ID, name, (invalid text OR legimiate result), required? , fieldView :: Text -> Text- -> Text+ -> Either Text a -> Bool- -> xml+ -> GWidget sub master () }
yesod-form.cabal view
@@ -1,5 +1,5 @@ name: yesod-form-version: 0.2.0.1+version: 0.3.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -10,26 +10,29 @@ cabal-version: >= 1.6 build-type: Simple homepage: http://www.yesodweb.com/+description: Form handling support for Yesod Web Framework library build-depends: base >= 4 && < 5- , yesod-core >= 0.8.2 && < 0.9+ , yesod-core >= 0.9 && < 0.10 , time >= 1.1.4 && < 1.3- , hamlet >= 0.8.1 && < 0.9- , persistent >= 0.5 && < 0.6- , yesod-persistent >= 0.1 && < 0.2+ , hamlet >= 0.10 && < 0.11+ , shakespeare-css >= 0.10 && < 0.11+ , shakespeare-js >= 0.10 && < 0.11+ , persistent >= 0.6 && < 0.7+ , yesod-persistent >= 0.2 && < 0.3 , template-haskell , transformers >= 0.2.2 && < 0.3- , data-default >= 0.2 && < 0.3- , xss-sanitize >= 0.2.4 && < 0.3+ , data-default >= 0.3 && < 0.4+ , xss-sanitize >= 0.3.0.1 && < 0.4 , blaze-builder >= 0.2.1 && < 0.4 , network >= 2.2 && < 2.4 , email-validate >= 0.2.6 && < 0.3 , blaze-html >= 0.4 && < 0.5 , bytestring >= 0.9 && < 0.10 , text >= 0.7 && < 1.0- , web-routes-quasi >= 0.7 && < 0.8 , wai >= 0.4 && < 0.5+ , containers >= 0.2 && < 0.5 exposed-modules: Yesod.Form Yesod.Form.Class Yesod.Form.Types@@ -38,6 +41,7 @@ Yesod.Form.Fields Yesod.Form.Jquery Yesod.Form.Nic+ Yesod.Form.MassInput -- FIXME Yesod.Helpers.Crud ghc-options: -Wall