diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 7ec3afa1..8cff7183 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -1,211 +1,50 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -- | Parse forms (and query strings). module Yesod.Form ( -- * Data types - GForm (..) - , Form - , Formlet - , FormField - , FormletField - , FormInput + GForm , FormResult (..) , Enctype (..) - , FieldInfo (..) -- * Unwrapping functions , runFormGet , runFormPost , runFormGet' , runFormPost' - -- * Type classes - , ToForm (..) - , ToFormField (..) -- * Field/form helpers - , requiredFieldHelper - , optionalFieldHelper - , mapFormXml - , newFormIdent - , deeperFormIdent - , shallowerFormIdent , fieldsToTable , fieldsToPlain - , fieldsToInput - -- * Field profiles - , FieldProfile (..) - , stringFieldProfile - , textareaFieldProfile - , hiddenFieldProfile - , intFieldProfile - , dayFieldProfile - , timeFieldProfile - , htmlFieldProfile - , emailFieldProfile - , urlFieldProfile - , FormFieldSettings (..) - -- * Pre-built fields - , stringField - , maybeStringField - , textareaField - , maybeTextareaField - , hiddenField - , maybeHiddenField - , intField - , maybeIntField - , doubleField - , maybeDoubleField - , dayField - , maybeDayField - , timeField - , maybeTimeField - , htmlField - , maybeHtmlField - , selectField - , maybeSelectField - , boolField - , emailField - , maybeEmailField - , urlField - , maybeUrlField - -- * Pre-built inputs - , stringInput - , maybeStringInput - , intInput - , boolInput - , dayInput - , maybeDayInput - , emailInput - , urlInput + , module Yesod.Form.Fields -- * Template Haskell , mkToForm - -- * Utilities - , parseDate - , parseTime ) where +import Yesod.Form.Core +import Yesod.Form.Fields +import Yesod.Form.Class + import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) -import Data.Time (Day, TimeOfDay(..)) import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class -import Control.Monad ((<=<), liftM, join) -import Data.Monoid (Monoid (..)) +import Control.Monad ((<=<)) import Control.Monad.Trans.State import Language.Haskell.TH.Syntax import Database.Persist.Base (EntityDef (..)) import Data.Char (toUpper, isUpper) -import Data.Int (Int64) -import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget import Control.Arrow ((&&&)) -import qualified Text.Email.Validate as Email import Data.List (group, sort) -import Network.URI (parseURI) -import Data.String (IsString (..)) - --- | A form can produce three different results: there was no data available, --- the data was invalid, or there was a successful parse. --- --- The 'Applicative' instance will concatenate the failure messages in two --- 'FormResult's. -data FormResult a = FormMissing - | FormFailure [String] - | FormSuccess a - deriving Show -instance Functor FormResult where - fmap _ FormMissing = FormMissing - fmap _ (FormFailure errs) = FormFailure errs - fmap f (FormSuccess a) = FormSuccess $ f a -instance Applicative FormResult where - pure = FormSuccess - (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g - (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y - (FormFailure x) <*> _ = FormFailure x - _ <*> (FormFailure y) = FormFailure y - _ <*> _ = FormMissing -instance Monoid m => Monoid (FormResult m) where - mempty = pure mempty - mappend x y = mappend <$> x <*> y - --- | The encoding type required by a form. The 'Show' instance produces values --- that can be inserted directly into HTML. -data Enctype = UrlEncoded | Multipart -instance Show Enctype where - show UrlEncoded = "application/x-www-form-urlencoded" - show Multipart = "multipart/form-data" -instance Monoid Enctype where - mempty = UrlEncoded - mappend UrlEncoded UrlEncoded = UrlEncoded - mappend _ _ = Multipart - -data Ints = IntCons Int Ints | IntSingle Int -instance Show Ints where - show (IntSingle i) = show i - show (IntCons i is) = show i ++ '-' : show is - -incrInts :: Ints -> Ints -incrInts (IntSingle i) = IntSingle $ i + 1 -incrInts (IntCons i is) = (i + 1) `IntCons` is - --- | A generic form, allowing you to specifying the subsite datatype, master --- site datatype, a datatype for the form XML and the return type. -newtype GForm sub y xml a = GForm - { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype) - } -type Form sub y = GForm sub y (GWidget sub y ()) -type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a -type FormInput sub y = GForm sub y [GWidget sub y ()] - --- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ \e fe -> do - (res, xml, enc) <- g e fe - return (res, f xml, enc) - --- | Using this as the intermediate XML representation for fields allows us to --- write generic field functions and then different functions for producing --- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo - { fiLabel :: Html - , fiTooltip :: Html - , fiIdent :: String - , fiName :: String - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - } - -type Env = [(String, String)] -type FileEnv = [(String, FileInfo)] - -instance Monoid xml => Functor (GForm sub url xml) where - fmap f (GForm g) = - GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe) - where - first3 f' (x, y, z) = (f' x, y, z) - -instance Monoid xml => Applicative (GForm sub url xml) where - pure a = GForm $ const $ const $ return (pure a, mempty, mempty) - (GForm f) <*> (GForm g) = GForm $ \env fe -> do - (f1, f2, f3) <- f env fe - (g1, g2, g3) <- g env fe - return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) -- | Display only the actual input widget code, without any decoration. fieldsToPlain :: [FieldInfo sub y] -> GWidget sub y () fieldsToPlain = mapM_ fiInput -fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] -fieldsToInput = map fiInput - -- | Display the label, tooltip, input code and errors in a single row of a -- table. fieldsToTable :: [FieldInfo sub y] -> GWidget sub y () @@ -223,429 +62,6 @@ fieldsToTable = mapM_ go %td.errors $err$ |] -class ToForm a y where - toForm :: Maybe a -> Form sub y a -class ToFormField a y where - toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: Html - , ffsTooltip :: Html - , ffsId :: Maybe String - , ffsName :: Maybe String - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings (string s) mempty Nothing Nothing - --- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'.ngs -requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = - GForm $ \env _ -> do - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormMissing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess y, x) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val True) - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - --- | Create an optional field (ie, one that can be blank) from a --- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> FormletField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = - GForm $ \env _ -> do - let (FormFieldSettings label tooltip theId' name') = ffs - let orig = join orig' - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormSuccess Nothing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormSuccess Nothing, "") - Just "" -> (FormSuccess Nothing, "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess $ Just y, x) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val False) - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - --- | A generic definition of a form field that can be used for generating both --- required and optional fields. See 'requiredFieldHelper and --- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile - { fpParse :: String -> Either String a - , fpRender :: a -> String - , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) - , fpWidget :: String -> GWidget sub y () - } - ---------------------- Begin prebuilt forms - -stringField :: FormFieldSettings -> FormletField sub y String -stringField = requiredFieldHelper stringFieldProfile - -maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeStringField = optionalFieldHelper stringFieldProfile - -stringFieldProfile :: FieldProfile sub y String -stringFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - , fpWidget = \_name -> return () - } -instance ToFormField String y where - toFormField = stringField -instance ToFormField (Maybe String) y where - toFormField = maybeStringField - -intInput :: Integral i => String -> FormInput sub master i -intInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile (nameSettings n) Nothing - -intField :: Integral i => FormFieldSettings -> FormletField sub y i -intField = requiredFieldHelper intFieldProfile - -maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i) -maybeIntField = optionalFieldHelper intFieldProfile - -intFieldProfile :: Integral i => FieldProfile sub y i -intFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid integer") Right . readMayI - , fpRender = showI - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ -|] - , fpWidget = \_name -> return () - } - where - showI x = show (fromIntegral x :: Integer) - readMayI s = case reads s of - (x, _):_ -> Just $ fromInteger x - [] -> Nothing -instance ToFormField Int y where - toFormField = intField -instance ToFormField (Maybe Int) y where - toFormField = maybeIntField -instance ToFormField Int64 y where - toFormField = intField -instance ToFormField (Maybe Int64) y where - toFormField = maybeIntField - -doubleField :: FormFieldSettings -> FormletField sub y Double -doubleField = requiredFieldHelper doubleFieldProfile - -maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double) -maybeDoubleField = optionalFieldHelper doubleFieldProfile - -doubleFieldProfile :: FieldProfile sub y Double -doubleFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid number") Right . readMay - , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ -|] - , fpWidget = \_name -> return () - } -instance ToFormField Double y where - toFormField = doubleField -instance ToFormField (Maybe Double) y where - toFormField = maybeDoubleField - -dayField :: FormFieldSettings -> FormletField sub y Day -dayField = requiredFieldHelper dayFieldProfile - -maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day) -maybeDayField = optionalFieldHelper dayFieldProfile - -dayFieldProfile :: FieldProfile sub y Day -dayFieldProfile = FieldProfile - { fpParse = parseDate - , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - , fpWidget = const $ return () - } -instance ToFormField Day y where - toFormField = dayField -instance ToFormField (Maybe Day) y where - toFormField = maybeDayField - -parseDate :: String -> Either String Day -parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right - . readMay . replace '/' '-' - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -parseTime :: String -> Either String 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 "Invalid time, must be in HH:MM[:SS] format" - -parseTimeHelper :: (Char, Char, Char, Char, Char, Char) - -> Either [Char] TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h - | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m - | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s - | otherwise = Right $ TimeOfDay h m s - where - h = read [h1, h2] - m = read [m1, m2] - s = fromInteger $ read [s1, s2] - -timeField :: FormFieldSettings -> FormletField sub y TimeOfDay -timeField = requiredFieldHelper timeFieldProfile - -maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) -maybeTimeField = optionalFieldHelper timeFieldProfile - -timeFieldProfile :: FieldProfile sub y TimeOfDay -timeFieldProfile = FieldProfile - { fpParse = parseTime - , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!:isReq:required!value=$val$ -|] - , fpWidget = const $ return () - } -instance ToFormField TimeOfDay y where - toFormField = timeField -instance ToFormField (Maybe TimeOfDay) y where - toFormField = maybeTimeField - -boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool -boolField ffs orig = GForm $ \env _ -> do - 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 True, True) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = addBody [$hamlet| -%input#$theId$!type=checkbox!name=$name$!:val:checked -|] - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) -instance ToFormField Bool y where - toFormField = boolField - -htmlField :: FormFieldSettings -> FormletField sub y Html -htmlField = requiredFieldHelper htmlFieldProfile - -maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html) -maybeHtmlField = optionalFieldHelper htmlFieldProfile - -htmlFieldProfile :: FieldProfile sub y Html -htmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString - , fpRender = U.toString . renderHtml - , fpHamlet = \theId name val _isReq -> [$hamlet| -%textarea.html#$theId$!name=$name$ $val$ -|] - , fpWidget = const $ return () - } -instance ToFormField Html y where - toFormField = htmlField -instance ToFormField (Maybe Html) y where - toFormField = maybeHtmlField - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - -selectField :: Eq x => [(x, String)] - -> FormFieldSettings - -> Maybe x -> FormField sub master x -selectField pairs ffs initial = GForm $ \env _ -> do - 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 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 = [$hamlet| -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = addBody input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - -maybeSelectField :: Eq x => [(x, String)] - -> FormFieldSettings - -> FormletField sub master (Maybe x) -maybeSelectField pairs ffs initial' = GForm $ \env _ -> do - 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 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 = [$hamlet| -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = addBody input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - ---------------------- End prebuilt forms - ---------------------- Begin prebuilt inputs - -stringInput :: String -> FormInput sub master String -stringInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile (nameSettings n) Nothing - -maybeStringInput :: String -> FormInput sub master (Maybe String) -maybeStringInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile (nameSettings n) Nothing - -boolInput :: String -> FormInput sub master Bool -boolInput n = GForm $ \env _ -> return - (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet| -%input#$n$!type=checkbox!name=$n$ -|], UrlEncoded) - -dayInput :: String -> FormInput sub master Day -dayInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile (nameSettings n) Nothing - -maybeDayInput :: String -> FormInput sub master (Maybe Day) -maybeDayInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile (nameSettings n) Nothing - ---------------------- End prebuilt inputs - --- | Get a unique identifier. -newFormIdent :: Monad m => StateT Ints m String -newFormIdent = do - i <- get - let i' = incrInts i - put i' - return $ 'f' : show i' - -deeperFormIdent :: Monad m => StateT Ints m () -deeperFormIdent = do - i <- get - let i' = 1 `IntCons` incrInts i - put i' - -shallowerFormIdent :: Monad m => StateT Ints m () -shallowerFormIdent = do - IntCons _ i <- get - put i - runFormGeneric :: Env -> FileEnv -> GForm sub y xml a @@ -770,84 +186,3 @@ toLabel (x:rest) = toUpper x : go rest go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs - -urlFieldProfile :: FieldProfile s y String -urlFieldProfile = FieldProfile - { fpParse = \s -> case parseURI s of - Nothing -> Left "Invalid URL" - Just _ -> Right s - , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ -|] - , fpWidget = const $ return () - } - -urlField :: FormFieldSettings -> FormletField sub y String -urlField = requiredFieldHelper urlFieldProfile - -maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeUrlField = optionalFieldHelper urlFieldProfile - -urlInput :: String -> FormInput sub master String -urlInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper urlFieldProfile (nameSettings n) Nothing - -emailFieldProfile :: FieldProfile s y String -emailFieldProfile = FieldProfile - { fpParse = \s -> if Email.isValid s - then Right s - else Left "Invalid e-mail address" - , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ -|] - , fpWidget = const $ return () - } - -emailField :: FormFieldSettings -> FormletField sub y String -emailField = requiredFieldHelper emailFieldProfile - -maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeEmailField = optionalFieldHelper emailFieldProfile - -emailInput :: String -> FormInput sub master String -emailInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile (nameSettings n) Nothing - -nameSettings :: String -> FormFieldSettings -nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) - -textareaFieldProfile :: FieldProfile sub y String -textareaFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpHamlet = \theId name val _isReq -> [$hamlet| -%textarea#$theId$!name=$name$ $val$ -|] - , fpWidget = const $ return () - } - -textareaField :: FormFieldSettings -> FormletField sub y String -textareaField = requiredFieldHelper textareaFieldProfile - -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeTextareaField = optionalFieldHelper textareaFieldProfile - -hiddenFieldProfile :: FieldProfile sub y String -hiddenFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpHamlet = \theId name val _isReq -> [$hamlet| -%input!type=hidden#$theId$!name=$name$!value=$val$ -|] - , fpWidget = const $ return () - } - -hiddenField :: FormFieldSettings -> FormletField sub y String -hiddenField = requiredFieldHelper hiddenFieldProfile - -maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeHiddenField = optionalFieldHelper hiddenFieldProfile diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs new file mode 100644 index 00000000..78af7e9c --- /dev/null +++ b/Yesod/Form/Class.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Yesod.Form.Class + ( ToForm (..) + , ToFormField (..) + ) where + +import Text.Hamlet +import Yesod.Form.Fields +import Data.Int (Int64) +import Data.Time (Day, TimeOfDay) + +class ToForm a y where + toForm :: Maybe a -> Form sub y a +class ToFormField a y where + toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a + +instance ToFormField String y where + toFormField = stringField +instance ToFormField (Maybe String) y where + toFormField = maybeStringField + +instance ToFormField Int y where + toFormField = intField +instance ToFormField (Maybe Int) y where + toFormField = maybeIntField +instance ToFormField Int64 y where + toFormField = intField +instance ToFormField (Maybe Int64) y where + toFormField = maybeIntField + +instance ToFormField Double y where + toFormField = doubleField +instance ToFormField (Maybe Double) y where + toFormField = maybeDoubleField + +instance ToFormField Day y where + toFormField = dayField +instance ToFormField (Maybe Day) y where + toFormField = maybeDayField + +instance ToFormField TimeOfDay y where + toFormField = timeField +instance ToFormField (Maybe TimeOfDay) y where + toFormField = maybeTimeField + +instance ToFormField Bool y where + toFormField = boolField + +instance ToFormField Html y where + toFormField = htmlField +instance ToFormField (Maybe Html) y where + toFormField = maybeHtmlField diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs new file mode 100644 index 00000000..f05437ec --- /dev/null +++ b/Yesod/Form/Core.hs @@ -0,0 +1,103 @@ +module Yesod.Form.Core + ( FormResult (..) + , GForm (..) + , newFormIdent + , deeperFormIdent + , shallowerFormIdent + , Env + , FileEnv + , Enctype (..) + , Ints (..) + ) where + +import Control.Monad.Trans.State +import Yesod.Handler +import Data.Monoid (Monoid (..)) +import Control.Applicative +import Yesod.Request +import Control.Monad (liftM) + +-- | A form can produce three different results: there was no data available, +-- the data was invalid, or there was a successful parse. +-- +-- The 'Applicative' instance will concatenate the failure messages in two +-- 'FormResult's. +data FormResult a = FormMissing + | FormFailure [String] + | FormSuccess a + deriving Show +instance Functor FormResult where + fmap _ FormMissing = FormMissing + fmap _ (FormFailure errs) = FormFailure errs + fmap f (FormSuccess a) = FormSuccess $ f a +instance Applicative FormResult where + pure = FormSuccess + (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g + (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y + (FormFailure x) <*> _ = FormFailure x + _ <*> (FormFailure y) = FormFailure y + _ <*> _ = FormMissing +instance Monoid m => Monoid (FormResult m) where + mempty = pure mempty + mappend x y = mappend <$> x <*> y + +-- | The encoding type required by a form. The 'Show' instance produces values +-- that can be inserted directly into HTML. +data Enctype = UrlEncoded | Multipart +instance Show Enctype where + show UrlEncoded = "application/x-www-form-urlencoded" + show Multipart = "multipart/form-data" +instance Monoid Enctype where + mempty = UrlEncoded + mappend UrlEncoded UrlEncoded = UrlEncoded + mappend _ _ = Multipart + +data Ints = IntCons Int Ints | IntSingle Int +instance Show Ints where + show (IntSingle i) = show i + show (IntCons i is) = show i ++ '-' : show is + +incrInts :: Ints -> Ints +incrInts (IntSingle i) = IntSingle $ i + 1 +incrInts (IntCons i is) = (i + 1) `IntCons` is + +-- | A generic form, allowing you to specifying the subsite datatype, master +-- site datatype, a datatype for the form XML and the return type. +newtype GForm sub y xml a = GForm + { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype) + } + +type Env = [(String, String)] +type FileEnv = [(String, FileInfo)] + +-- | Get a unique identifier. +newFormIdent :: Monad m => StateT Ints m String +newFormIdent = do + i <- get + let i' = incrInts i + put i' + return $ 'f' : show i' + +deeperFormIdent :: Monad m => StateT Ints m () +deeperFormIdent = do + i <- get + let i' = 1 `IntCons` incrInts i + put i' + +shallowerFormIdent :: Monad m => StateT Ints m () +shallowerFormIdent = do + IntCons _ i <- get + put i + +instance Monoid xml => Functor (GForm sub url xml) where + fmap f (GForm g) = + GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe) + where + first3 f' (x, y, z) = (f' x, y, z) + +instance Monoid xml => Applicative (GForm sub url xml) where + pure a = GForm $ const $ const $ return (pure a, mempty, mempty) + (GForm f) <*> (GForm g) = GForm $ \env fe -> do + (f1, f2, f3) <- f env fe + (g1, g2, g3) <- g env fe + return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs new file mode 100644 index 00000000..09204f76 --- /dev/null +++ b/Yesod/Form/Fields.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Form.Fields + ( -- * Type synonyms + Form + , Formlet + , FormField + , FormletField + , FormInput + -- * Data types + , FieldInfo (..) + , FormFieldSettings (..) + -- * Fields + -- ** Required + , stringField + , textareaField + , hiddenField + , intField + , doubleField + , dayField + , timeField + , htmlField + , selectField + , boolField + , emailField + , urlField + -- ** Optional + , maybeStringField + , maybeTextareaField + , maybeHiddenField + , maybeIntField + , maybeDoubleField + , maybeDayField + , maybeTimeField + , maybeHtmlField + , maybeSelectField + , maybeEmailField + , maybeUrlField + -- * Inputs + -- ** Required + , stringInput + , intInput + , boolInput + , dayInput + , emailInput + , urlInput + -- ** Optional + , maybeStringInput + , maybeDayInput + -- * Utils + , requiredFieldHelper + , optionalFieldHelper + , fieldsToInput + , mapFormXml + ) where + +import Yesod.Form.Core +import Yesod.Form.Profiles +import Yesod.Widget +import Data.Time (Day, TimeOfDay) +import Text.Hamlet +import Data.Monoid +import Control.Monad (join) +import Data.Maybe (fromMaybe) +import Data.String + +data FormFieldSettings = FormFieldSettings + { ffsLabel :: Html + , ffsTooltip :: Html + , ffsId :: Maybe String + , ffsName :: Maybe String + } +instance IsString FormFieldSettings where + fromString s = FormFieldSettings (string s) mempty Nothing Nothing + +-- | Using this as the intermediate XML representation for fields allows us to +-- write generic field functions and then different functions for producing +-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. +data FieldInfo sub y = FieldInfo + { fiLabel :: Html + , fiTooltip :: Html + , fiIdent :: String + , fiName :: String + , fiInput :: GWidget sub y () + , fiErrors :: Maybe Html + } + +type Form sub y = GForm sub y (GWidget sub y ()) +type Formlet sub y a = Maybe a -> Form sub y a +type FormField sub y = GForm sub y [FieldInfo sub y] +type FormletField sub y a = Maybe a -> FormField sub y a +type FormInput sub y = GForm sub y [GWidget sub y ()] + +stringField :: FormFieldSettings -> FormletField sub y String +stringField = requiredFieldHelper stringFieldProfile + +maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeStringField = optionalFieldHelper stringFieldProfile + +intInput :: Integral i => String -> FormInput sub master i +intInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper intFieldProfile (nameSettings n) Nothing + +intField :: Integral i => FormFieldSettings -> FormletField sub y i +intField = requiredFieldHelper intFieldProfile + +maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i) +maybeIntField = optionalFieldHelper intFieldProfile + +doubleField :: FormFieldSettings -> FormletField sub y Double +doubleField = requiredFieldHelper doubleFieldProfile + +maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double) +maybeDoubleField = optionalFieldHelper doubleFieldProfile + +dayField :: FormFieldSettings -> FormletField sub y Day +dayField = requiredFieldHelper dayFieldProfile + +maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day) +maybeDayField = optionalFieldHelper dayFieldProfile + +timeField :: FormFieldSettings -> FormletField sub y TimeOfDay +timeField = requiredFieldHelper timeFieldProfile + +maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) +maybeTimeField = optionalFieldHelper timeFieldProfile + +boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool +boolField ffs orig = GForm $ \env _ -> do + 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 True, True) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = addBody [$hamlet| +%input#$theId$!type=checkbox!name=$name$!:val:checked +|] + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +htmlField :: FormFieldSettings -> FormletField sub y Html +htmlField = requiredFieldHelper htmlFieldProfile + +maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html) +maybeHtmlField = optionalFieldHelper htmlFieldProfile + +selectField :: Eq x => [(x, String)] + -> FormFieldSettings + -> Maybe x -> FormField sub master x +selectField pairs ffs initial = GForm $ \env _ -> do + 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 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 = [$hamlet| +%select#$theId$!name=$name$ + %option!value=none + $forall pairs' pair + %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ +|] + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = addBody input + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +maybeSelectField :: Eq x => [(x, String)] + -> FormFieldSettings + -> FormletField sub master (Maybe x) +maybeSelectField pairs ffs initial' = GForm $ \env _ -> do + 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 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 = [$hamlet| +%select#$theId$!name=$name$ + %option!value=none + $forall pairs' pair + %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ +|] + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = addBody input + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +stringInput :: String -> FormInput sub master String +stringInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper stringFieldProfile (nameSettings n) Nothing + +maybeStringInput :: String -> FormInput sub master (Maybe String) +maybeStringInput n = + mapFormXml fieldsToInput $ + optionalFieldHelper stringFieldProfile (nameSettings n) Nothing + +boolInput :: String -> FormInput sub master Bool +boolInput n = GForm $ \env _ -> return + (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet| +%input#$n$!type=checkbox!name=$n$ +|], UrlEncoded) + +dayInput :: String -> FormInput sub master Day +dayInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper dayFieldProfile (nameSettings n) Nothing + +maybeDayInput :: String -> FormInput sub master (Maybe Day) +maybeDayInput n = + mapFormXml fieldsToInput $ + optionalFieldHelper dayFieldProfile (nameSettings n) Nothing + +nameSettings :: String -> FormFieldSettings +nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) + +-- | Create a required field (ie, one that cannot be blank) from a +-- 'FieldProfile'.ngs +requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> Maybe a -> FormField sub y a +requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = + GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let (res, val) = + if null env + then (FormMissing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormMissing, "") + Just "" -> (FormFailure ["Value is required"], "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val True) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +-- | Create an optional field (ie, one that can be blank) from a +-- 'FieldProfile'. +optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> FormletField sub y (Maybe a) +optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = + GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs + let orig = join orig' + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let (res, val) = + if null env + then (FormSuccess Nothing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormSuccess Nothing, "") + Just "" -> (FormSuccess Nothing, "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess $ Just y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val False) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] +fieldsToInput = map fiInput + +-- | Convert the XML in a 'GForm'. +mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a +mapFormXml f (GForm g) = GForm $ \e fe -> do + (res, xml, enc) <- g e fe + return (res, f xml, enc) + +urlField :: FormFieldSettings -> FormletField sub y String +urlField = requiredFieldHelper urlFieldProfile + +maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeUrlField = optionalFieldHelper urlFieldProfile + +urlInput :: String -> FormInput sub master String +urlInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper urlFieldProfile (nameSettings n) Nothing + +emailField :: FormFieldSettings -> FormletField sub y String +emailField = requiredFieldHelper emailFieldProfile + +maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeEmailField = optionalFieldHelper emailFieldProfile + +emailInput :: String -> FormInput sub master String +emailInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper emailFieldProfile (nameSettings n) Nothing + +textareaField :: FormFieldSettings -> FormletField sub y String +textareaField = requiredFieldHelper textareaFieldProfile + +maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeTextareaField = optionalFieldHelper textareaFieldProfile + +hiddenField :: FormFieldSettings -> FormletField sub y String +hiddenField = requiredFieldHelper hiddenFieldProfile + +maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeHiddenField = optionalFieldHelper hiddenFieldProfile diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 305ab44c..915a017d 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -12,6 +12,7 @@ module Yesod.Form.Jquery import Yesod.Handler import Yesod.Form +import Yesod.Form.Profiles import Yesod.Widget import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, timeToTimeOfDay) diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index 402187a5..b0c02192 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -7,6 +7,7 @@ module Yesod.Form.Nic import Yesod.Handler import Yesod.Form +import Yesod.Form.Profiles import Yesod.Hamlet import Yesod.Widget import qualified Data.ByteString.Lazy.UTF8 as U diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs new file mode 100644 index 00000000..b86f8149 --- /dev/null +++ b/Yesod/Form/Profiles.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Form.Profiles + ( FieldProfile (..) + , stringFieldProfile + , textareaFieldProfile + , hiddenFieldProfile + , intFieldProfile + , dayFieldProfile + , timeFieldProfile + , htmlFieldProfile + , emailFieldProfile + , urlFieldProfile + , doubleFieldProfile + , parseDate + , parseTime + ) where + +import Yesod.Widget +import Yesod.Handler +import Text.Hamlet +import Data.Time (Day, TimeOfDay(..)) +import qualified Data.ByteString.Lazy.UTF8 as U +import qualified Text.Email.Validate as Email +import Network.URI (parseURI) + +-- | A generic definition of a form field that can be used for generating both +-- required and optional fields. See 'requiredFieldHelper and +-- 'optionalFieldHelper'. +data FieldProfile sub y a = FieldProfile + { fpParse :: String -> Either String a + , fpRender :: a -> String + , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) + , fpWidget :: String -> GWidget sub y () + } + +intFieldProfile :: Integral i => FieldProfile sub y i +intFieldProfile = FieldProfile + { fpParse = maybe (Left "Invalid integer") Right . readMayI + , fpRender = showI + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + where + showI x = show (fromIntegral x :: Integer) + readMayI s = case reads s of + (x, _):_ -> Just $ fromInteger x + [] -> Nothing + +doubleFieldProfile :: FieldProfile sub y Double +doubleFieldProfile = FieldProfile + { fpParse = maybe (Left "Invalid number") Right . readMay + , fpRender = show + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + +dayFieldProfile :: FieldProfile sub y Day +dayFieldProfile = FieldProfile + { fpParse = parseDate + , fpRender = show + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } + +timeFieldProfile :: FieldProfile sub y TimeOfDay +timeFieldProfile = FieldProfile + { fpParse = parseTime + , fpRender = show + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } + +htmlFieldProfile :: FieldProfile sub y Html +htmlFieldProfile = FieldProfile + { fpParse = Right . preEscapedString + , fpRender = U.toString . renderHtml + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea.html#$theId$!name=$name$ $val$ +|] + , fpWidget = const $ return () + } + +textareaFieldProfile :: FieldProfile sub y String +textareaFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea#$theId$!name=$name$ $val$ +|] + , fpWidget = const $ return () + } + +hiddenFieldProfile :: FieldProfile sub y String +hiddenFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val _isReq -> [$hamlet| +%input!type=hidden#$theId$!name=$name$!value=$val$ +|] + , fpWidget = const $ return () + } + +stringFieldProfile :: FieldProfile sub y String +stringFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + +readMay :: Read a => String -> Maybe a +readMay s = case reads s of + (x, _):_ -> Just x + [] -> Nothing + +parseDate :: String -> Either String Day +parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right + . readMay . replace '/' '-' + +-- | Replaces all instances of a value in a list by another value. +-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace +replace :: Eq a => a -> a -> [a] -> [a] +replace x y = map (\z -> if z == x then y else z) + +parseTime :: String -> Either String 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 "Invalid time, must be in HH:MM[:SS] format" + +parseTimeHelper :: (Char, Char, Char, Char, Char, Char) + -> Either [Char] TimeOfDay +parseTimeHelper (h1, h2, m1, m2, s1, s2) + | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h + | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m + | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s + | otherwise = Right $ TimeOfDay h m s + where + h = read [h1, h2] + m = read [m1, m2] + s = fromInteger $ read [s1, s2] + +emailFieldProfile :: FieldProfile s y String +emailFieldProfile = FieldProfile + { fpParse = \s -> if Email.isValid s + then Right s + else Left "Invalid e-mail address" + , fpRender = id + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } + +urlFieldProfile :: FieldProfile s y String +urlFieldProfile = FieldProfile + { fpParse = \s -> case parseURI s of + Nothing -> Left "Invalid URL" + Just _ -> Right s + , fpRender = id + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 446526c1..06c031e6 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -17,6 +17,7 @@ import Yesod.Content import Yesod.Handler import Text.Hamlet import Yesod.Form +import Yesod.Form.Class import Data.Monoid (mempty) import Language.Haskell.TH.Syntax diff --git a/yesod.cabal b/yesod.cabal index 8152a9dc..51bc22bd 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -52,6 +52,10 @@ library Yesod.Content Yesod.Dispatch Yesod.Form + Yesod.Form.Class + Yesod.Form.Core + Yesod.Form.Fields + Yesod.Form.Profiles Yesod.Form.Jquery Yesod.Form.Nic Yesod.Hamlet