From 010cb4863b4c75cd09aa1d8845de6d68fc28eeeb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 9 May 2011 17:28:42 +0300 Subject: [PATCH] Beginning of serious refactor --- Yesod/Form/Fields.hs | 627 ++++++++++++++-------------------------- Yesod/Form/Functions.hs | 174 +++++++++++ Yesod/Form/Profiles.hs | 251 ---------------- Yesod/Form/Types.hs | 123 ++++++++ 4 files changed, 514 insertions(+), 661 deletions(-) create mode 100644 Yesod/Form/Functions.hs delete mode 100644 Yesod/Form/Profiles.hs create mode 100644 Yesod/Form/Types.hs diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 98291d47..fc945240 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -1,444 +1,251 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} module Yesod.Form.Fields - ( -- * Fields - -- ** Required - stringField + ( textField , passwordField , textareaField , hiddenField , intField - , doubleField , dayField , timeField , htmlField - , selectField - , radioField - , boolField , emailField , searchField + , AutoFocus , urlField - , fileField - -- ** Optional - , maybeStringField - , maybePasswordField - , maybeTextareaField - , maybeHiddenField - , maybeIntField - , maybeDoubleField - , maybeDayField - , maybeTimeField - , maybeHtmlField - , maybeSelectField - , maybeRadioField - , maybeEmailField - , maybeSearchField - , maybeUrlField - , maybeFileField - {- FIXME - -- * Inputs - -- ** Required - , stringInput - , intInput - , boolInput - , dayInput - , emailInput - , urlInput - -- ** Optional - , maybeStringInput - , maybeDayInput - , maybeIntInput - -} + , doubleField + , parseDate + , parseTime + , Textarea (..) ) where -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Request (FileInfo) -import Yesod.Widget (GWidget) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.Time (Day, TimeOfDay) -import Text.Hamlet -import Data.Monoid -import Control.Monad (join) -import Data.Maybe (fromMaybe, isNothing) -import Data.Text (Text, unpack) -import qualified Data.Text as T +import Yesod.Form.Types +import Yesod.Widget +import Text.Hamlet hiding (renderHtml) +import Text.Blaze (ToHtml (..)) +import Text.Cassius +import Data.Time (Day, TimeOfDay(..)) +import qualified Text.Email.Validate as Email +import Network.URI (parseURI) +import Database.Persist (PersistField) +import Text.HTML.SanitizeXSS (sanitizeBalance) +import Control.Monad (when) + +import qualified Blaze.ByteString.Builder.Html.Utf8 as B +import Blaze.ByteString.Builder (writeByteString, toLazyByteString) +import Blaze.ByteString.Builder.Internal.Write (fromWriteList) + +import Text.Blaze.Renderer.String (renderHtml) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Text (Text, unpack, pack) #if __GLASGOW_HASKELL__ >= 700 #define HAMLET hamlet +#define CASSIUS cassius +#define JULIUS julius #else #define HAMLET $hamlet +#define CASSIUS $cassius +#define JULIUS $julius #endif -stringField = requiredFieldHelper stringFieldProfile - -maybeStringField = optionalFieldHelper stringFieldProfile - -passwordField = requiredFieldHelper passwordFieldProfile - -maybePasswordField = optionalFieldHelper passwordFieldProfile - -{- FIXME -intInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile (nameSettings n) Nothing - -maybeIntInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper intFieldProfile (nameSettings n) Nothing --} - -intField = requiredFieldHelper intFieldProfile - -maybeIntField = optionalFieldHelper intFieldProfile - -doubleField = requiredFieldHelper doubleFieldProfile - -maybeDoubleField = optionalFieldHelper doubleFieldProfile - -dayField = requiredFieldHelper dayFieldProfile - -maybeDayField = optionalFieldHelper dayFieldProfile - -timeField = requiredFieldHelper timeFieldProfile - -maybeTimeField = optionalFieldHelper timeFieldProfile - -boolField ffs orig = do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - name <- maybe newFormIdent return $ ffsName ffs - theId <- maybe newFormIdent return $ ffsId ffs - let (res, val) = - if null env - then (FormMissing, fromMaybe False orig) - else case lookup name env of - Nothing -> (FormSuccess False, False) - Just "" -> (FormSuccess False, False) - Just "false" -> (FormSuccess False, False) - Just _ -> (FormSuccess True, True) - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = [HAMLET| - +intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) i +intField = Field + { fieldParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read + , fieldRender = pack . showI + , fieldView = \theId name val isReq -> addHamlet + [HAMLET|\ + |] - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) + } + where + showI x = show (fromIntegral x :: Integer) + readMayI s = case reads s of + (x, _):_ -> Just $ fromInteger x + [] -> Nothing -htmlField = requiredFieldHelper htmlFieldProfile - -maybeHtmlField = optionalFieldHelper htmlFieldProfile - -selectField pairs ffs initial = do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormFailure ["Field is required"] - Just x -> - case reads $ unpack x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> x == y - _ -> Just x == initial - let input = -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif - |] - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) + } -maybeSelectField pairs ffs initial' = do - env <- askParams - let initial = join initial' - label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormSuccess Nothing - Just x -> - case reads $ unpack x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess $ Just y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> Just x == y - _ -> Just x == initial - let input = -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif - |] - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = False - } - return (res, fi, UrlEncoded) + } -{- FIXME -stringInput :: Text -> FormInput sub master Text -stringInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile (nameSettings n) Nothing - -maybeStringInput :: Text -> FormInput sub master (Maybe Text) -maybeStringInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile (nameSettings n) Nothing - -boolInput :: Text -> FormInput sub master Bool -boolInput n = GForm $ do - env <- askParams - let res = case lookup n env of - Nothing -> FormSuccess False - Just "" -> FormSuccess False - Just "false" -> FormSuccess False - Just _ -> FormSuccess True - let xml = [HAMLET| - +timeField :: Monad monad => Field (GGWidget master monad ()) TimeOfDay +timeField = Field + { fieldParse = parseTime . unpack + , fieldRender = pack . show . roundFullSeconds + , fieldView = \theId name val isReq -> addHamlet + [HAMLET|\ + |] - return (res, [xml], UrlEncoded) + } + where + roundFullSeconds tod = + TimeOfDay (todHour tod) (todMin tod) fullSec + where + fullSec = fromInteger $ floor $ todSec tod -dayInput :: Text -> FormInput sub master Day -dayInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile (nameSettings n) Nothing - -maybeDayInput :: Text -> FormInput sub master (Maybe Day) -maybeDayInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile (nameSettings n) Nothing --} - -nameSettings :: Text -> FormFieldSettings -nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) - -urlField = requiredFieldHelper urlFieldProfile - -maybeUrlField = optionalFieldHelper urlFieldProfile - -{- FIXME -urlInput :: Text -> FormInput sub master Text -urlInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper urlFieldProfile (nameSettings n) Nothing --} - -emailField = requiredFieldHelper emailFieldProfile - -maybeEmailField = optionalFieldHelper emailFieldProfile - -{- FIXME -emailInput :: Text -> FormInput sub master Text -emailInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile (nameSettings n) Nothing --} - -searchField = requiredFieldHelper . searchFieldProfile - -maybeSearchField = optionalFieldHelper . searchFieldProfile - -textareaField = requiredFieldHelper textareaFieldProfile - -maybeTextareaField = optionalFieldHelper textareaFieldProfile - -hiddenField = requiredFieldHelper hiddenFieldProfile - -maybeHiddenField = optionalFieldHelper hiddenFieldProfile - -fileField ffs = do - env <- lift ask - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = - if null env && null fenv - then FormMissing - else case lookup name fenv of - Nothing -> FormFailure ["File is required"] - Just x -> FormSuccess x - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name True - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [T.concat [label, ": ", e]] - _ -> res - return (res', fi, Multipart) - -maybeFileField ffs = do - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = FormSuccess $ lookup name fenv - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name False - , fiErrors = Nothing - , fiRequired = True - } - return (res, fi, Multipart) - -fileWidget :: Text -> Text -> Bool -> GWidget s m () -fileWidget theId name isReq = [HAMLET| - +htmlField :: Monad monad => Field (GGWidget master monad ()) Html +htmlField = Field + { fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize + , fieldRender = pack . renderHtml + , fieldView = \theId name val _isReq -> addHamlet + [HAMLET|\ +