haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Yesod 0.7

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-05 00:26:21 +03:00
parent 8a97f4fe11
commit c35decd8af
8 changed files with 162 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
Yesod/Form.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Parse forms (and query strings). -- | Parse forms (and query strings).
module Yesod.Form module Yesod.Form
( -- * Data types ( -- * Data types
@ -63,6 +64,8 @@ import Data.Char (toUpper, isUpper)
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Data.List (group, sort) import Data.List (group, sort)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Text (Text)
import Text.Blaze (toHtml)
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet #define HAMLET hamlet
@ -88,7 +91,7 @@ fieldsToTable = mapFormXml $ mapM_ go
$maybe err <- fiErrors fi $maybe err <- fiErrors fi
<td .errors>#{err} <td .errors>#{err}
|] |]
clazz fi = if fiRequired fi then "required" else "optional" clazz fi = if fiRequired fi then "required" else "optional" :: Text
-- | Display the label, tooltip, input code and errors in a single div. -- | Display the label, tooltip, input code and errors in a single div.
fieldsToDivs :: FormField sub y a -> Form sub y a fieldsToDivs :: FormField sub y a -> Form sub y a
@ -102,7 +105,7 @@ fieldsToDivs = mapFormXml $ mapM_ go
$maybe err <- fiErrors fi $maybe err <- fiErrors fi
<div .errors>#{err} <div .errors>#{err}
|] |]
clazz fi = if fiRequired fi then "required" else "optional" clazz fi = if fiRequired fi then "required" else "optional" :: Text
-- | Run a form against POST parameters, without CSRF protection. -- | Run a form against POST parameters, without CSRF protection.
runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
@ -133,7 +136,7 @@ runFormPost f = do
<input type="hidden" name="#{nonceName}" value="#{nonce}"> <input type="hidden" name="#{nonceName}" value="#{nonce}">
|] |]
nonceName :: String nonceName :: Text
nonceName = "_nonce" nonceName = "_nonce"
-- | Run a form against POST parameters. Please note that this does not provide -- | Run a form against POST parameters. Please note that this does not provide
@ -258,7 +261,7 @@ mkToForm =
just <- [|pure|] just <- [|pure|]
nothing <- [|Nothing|] nothing <- [|Nothing|]
let just' = just `AppE` ConE (mkName $ entityName t) let just' = just `AppE` ConE (mkName $ entityName t)
string' <- [|string|] string' <- [|toHtml|]
ftt <- [|fieldsToTable|] ftt <- [|fieldsToTable|]
ffs' <- [|FormFieldSettings|] ffs' <- [|FormFieldSettings|]
let stm "" = nothing let stm "" = nothing
@ -306,6 +309,6 @@ toLabel (x:rest) = toUpper x : go rest
| isUpper c = ' ' : c : go cs | isUpper c = ' ' : c : go cs
| otherwise = c : go cs | otherwise = c : go cs
formFailures :: FormResult a -> Maybe [String] formFailures :: FormResult a -> Maybe [Text]
formFailures (FormFailure x) = Just x formFailures (FormFailure x) = Just x
formFailures _ = Nothing formFailures _ = Nothing

8
Yesod/Form/Class.hs
View File

@ -12,16 +12,24 @@ import Yesod.Form.Core
import Yesod.Form.Profiles (Textarea) import Yesod.Form.Profiles (Textarea)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Time (Day, TimeOfDay) import Data.Time (Day, TimeOfDay)
import Data.Text (Text)
class ToForm a y where class ToForm a y where
toForm :: Formlet sub y a toForm :: Formlet sub y a
class ToFormField a y where class ToFormField a y where
toFormField :: FormFieldSettings -> FormletField sub y a toFormField :: FormFieldSettings -> FormletField sub y a
{- FIXME
instance ToFormField String y where instance ToFormField String y where
toFormField = stringField toFormField = stringField
instance ToFormField (Maybe String) y where instance ToFormField (Maybe String) y where
toFormField = maybeStringField toFormField = maybeStringField
-}
instance ToFormField Text y where
toFormField = stringField
instance ToFormField (Maybe Text) y where
toFormField = maybeStringField
instance ToFormField Int y where instance ToFormField Int y where
toFormField = intField toFormField = intField

47
Yesod/Form/Core.hs
View File

@ -52,6 +52,13 @@ import Text.Hamlet
import Text.Blaze (ToHtml (..)) import Text.Blaze (ToHtml (..))
import Data.String import Data.String
import Control.Monad (join) import Control.Monad (join)
import Data.Text (Text, pack)
import qualified Data.Text as T
import Prelude hiding ((++))
import Data.Monoid (Monoid (mappend))
(++) :: Monoid a => a -> a -> a
(++) = mappend
-- | A form can produce three different results: there was no data available, -- | A form can produce three different results: there was no data available,
-- the data was invalid, or there was a successful parse. -- the data was invalid, or there was a successful parse.
@ -59,7 +66,7 @@ import Control.Monad (join)
-- The 'Applicative' instance will concatenate the failure messages in two -- The 'Applicative' instance will concatenate the failure messages in two
-- 'FormResult's. -- 'FormResult's.
data FormResult a = FormMissing data FormResult a = FormMissing
| FormFailure [String] | FormFailure [Text]
| FormSuccess a | FormSuccess a
deriving Show deriving Show
instance Functor FormResult where instance Functor FormResult where
@ -92,7 +99,7 @@ instance Monoid Enctype where
data Ints = IntCons Int Ints | IntSingle Int data Ints = IntCons Int Ints | IntSingle Int
instance Show Ints where instance Show Ints where
show (IntSingle i) = show i show (IntSingle i) = show i
show (IntCons i is) = show i ++ '-' : show is show (IntCons i is) = show i ++ ('-' : show is)
incrInts :: Ints -> Ints incrInts :: Ints -> Ints
incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntSingle i) = IntSingle $ i + 1
@ -113,16 +120,16 @@ type FormInner s m =
GHandler s m GHandler s m
))) )))
type Env = [(String, String)] type Env = [(Text, Text)]
type FileEnv = [(String, FileInfo)] type FileEnv = [(Text, FileInfo)]
-- | Get a unique identifier. -- | Get a unique identifier.
newFormIdent :: Monad m => StateT Ints m String newFormIdent :: Monad m => StateT Ints m Text
newFormIdent = do newFormIdent = do
i <- get i <- get
let i' = incrInts i let i' = incrInts i
put i' put i'
return $ 'f' : show i' return $ pack $ 'f' : show i'
deeperFormIdent :: Monad m => StateT Ints m () deeperFormIdent :: Monad m => StateT Ints m ()
deeperFormIdent = do deeperFormIdent = do
@ -172,12 +179,12 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do
Left e -> (FormFailure [e], x) Left e -> (FormFailure [e], x)
Right y -> (FormSuccess y, x) Right y -> (FormSuccess y, x)
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = mkWidget theId name val True , fiInput = mkWidget theId name val True
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ toHtml x
_ -> Nothing _ -> Nothing
, fiRequired = True , fiRequired = True
} }
@ -261,12 +268,12 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do
Left e -> (FormFailure [e], x) Left e -> (FormFailure [e], x)
Right y -> (FormSuccess $ Just y, x) Right y -> (FormSuccess $ Just y, x)
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = mkWidget theId name val False , fiInput = mkWidget theId name val False
, fiErrors = case res of , fiErrors = case res of
FormFailure x -> Just $ string $ unlines x FormFailure x -> Just $ toHtml $ T.unlines x
_ -> Nothing _ -> Nothing
, fiRequired = False , fiRequired = False
} }
@ -290,29 +297,29 @@ mapFormXml f (GForm g) = GForm $ do
data FieldInfo sub y = FieldInfo data FieldInfo sub y = FieldInfo
{ fiLabel :: Html { fiLabel :: Html
, fiTooltip :: Html , fiTooltip :: Html
, fiIdent :: String , fiIdent :: Text
, fiInput :: GWidget sub y () , fiInput :: GWidget sub y ()
, fiErrors :: Maybe Html , fiErrors :: Maybe Html
, fiRequired :: Bool , fiRequired :: Bool
} }
data FormFieldSettings = FormFieldSettings data FormFieldSettings = FormFieldSettings
{ ffsLabel :: String { ffsLabel :: Text
, ffsTooltip :: Html , ffsTooltip :: Html
, ffsId :: Maybe String , ffsId :: Maybe Text
, ffsName :: Maybe String , ffsName :: Maybe Text
} }
instance IsString FormFieldSettings where instance IsString FormFieldSettings where
fromString s = FormFieldSettings s mempty Nothing Nothing fromString s = FormFieldSettings (pack s) mempty Nothing Nothing
-- | A generic definition of a form field that can be used for generating both -- | A generic definition of a form field that can be used for generating both
-- required and optional fields. See 'requiredFieldHelper and -- required and optional fields. See 'requiredFieldHelper and
-- 'optionalFieldHelper'. -- 'optionalFieldHelper'.
data FieldProfile sub y a = FieldProfile data FieldProfile sub y a = FieldProfile
{ fpParse :: String -> Either String a { fpParse :: Text -> Either Text a
, fpRender :: a -> String , fpRender :: a -> Text
-- | ID, name, value, required -- | ID, name, value, required
, fpWidget :: String -> String -> String -> Bool -> GWidget sub y () , fpWidget :: Text -> Text -> Text -> Bool -> GWidget sub y ()
} }
type Form sub y = GForm sub y (GWidget sub y ()) type Form sub y = GForm sub y (GWidget sub y ())
@ -338,7 +345,7 @@ checkForm f (GForm form) = GForm $ do
-- --
-- Unlike 'checkForm', the validation error will appear in the generated HTML -- Unlike 'checkForm', the validation error will appear in the generated HTML
-- of the form. -- of the form.
checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b checkField :: (a -> Either Text b) -> FormField s m a -> FormField s m b
checkField f (GForm form) = GForm $ do checkField f (GForm form) = GForm $ do
(res, xml, enc) <- form (res, xml, enc) <- form
let (res', merr) = let (res', merr) =
@ -355,7 +362,7 @@ checkField f (GForm form) = GForm $ do
Just err -> flip map xml $ \fi -> fi Just err -> flip map xml $ \fi -> fi
{ fiErrors = Just $ { fiErrors = Just $
case fiErrors fi of case fiErrors fi of
Nothing -> string err Nothing -> toHtml err
Just x -> x Just x -> x
} }
return (res', xml', enc) return (res', xml', enc)

112
Yesod/Form/Fields.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Form.Fields module Yesod.Form.Fields
( -- * Fields ( -- * Fields
-- ** Required -- ** Required
@ -62,6 +63,9 @@ import Text.Hamlet
import Data.Monoid import Data.Monoid
import Control.Monad (join) import Control.Monad (join)
import Data.Maybe (fromMaybe, isNothing) import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Text.Blaze (toHtml)
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet #define HAMLET hamlet
@ -69,28 +73,28 @@ import Data.Maybe (fromMaybe, isNothing)
#define HAMLET $hamlet #define HAMLET $hamlet
#endif #endif
stringField :: (IsForm f, FormType f ~ String) stringField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe String -> f => FormFieldSettings -> Maybe Text -> f
stringField = requiredFieldHelper stringFieldProfile stringField = requiredFieldHelper stringFieldProfile
maybeStringField :: (IsForm f, FormType f ~ Maybe String) maybeStringField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe String) -> f => FormFieldSettings -> Maybe (Maybe Text) -> f
maybeStringField = optionalFieldHelper stringFieldProfile maybeStringField = optionalFieldHelper stringFieldProfile
passwordField :: (IsForm f, FormType f ~ String) passwordField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe String -> f => FormFieldSettings -> Maybe Text -> f
passwordField = requiredFieldHelper passwordFieldProfile passwordField = requiredFieldHelper passwordFieldProfile
maybePasswordField :: (IsForm f, FormType f ~ Maybe String) maybePasswordField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe String) -> f => FormFieldSettings -> Maybe (Maybe Text) -> f
maybePasswordField = optionalFieldHelper passwordFieldProfile maybePasswordField = optionalFieldHelper passwordFieldProfile
intInput :: Integral i => String -> FormInput sub master i intInput :: Integral i => Text -> FormInput sub master i
intInput n = intInput n =
mapFormXml fieldsToInput $ mapFormXml fieldsToInput $
requiredFieldHelper intFieldProfile (nameSettings n) Nothing requiredFieldHelper intFieldProfile (nameSettings n) Nothing
maybeIntInput :: Integral i => String -> FormInput sub master (Maybe i) maybeIntInput :: Integral i => Text -> FormInput sub master (Maybe i)
maybeIntInput n = maybeIntInput n =
mapFormXml fieldsToInput $ mapFormXml fieldsToInput $
optionalFieldHelper intFieldProfile (nameSettings n) Nothing optionalFieldHelper intFieldProfile (nameSettings n) Nothing
@ -144,14 +148,14 @@ boolField ffs orig = toForm $ do
Just "false" -> (FormSuccess False, False) Just "false" -> (FormSuccess False, False)
Just _ -> (FormSuccess True, True) Just _ -> (FormSuccess True, True)
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = [HAMLET| , fiInput = [HAMLET|
<input id="#{theId}" type="checkbox" name="#{name}" :val:checked=""> <input id="#{theId}" type="checkbox" name="#{name}" :val:checked="">
|] |]
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ toHtml x
_ -> Nothing _ -> Nothing
, fiRequired = True , fiRequired = True
} }
@ -181,7 +185,7 @@ selectField pairs ffs initial = toForm $ do
Nothing -> FormMissing Nothing -> FormMissing
Just "none" -> FormFailure ["Field is required"] Just "none" -> FormFailure ["Field is required"]
Just x -> Just x ->
case reads x of case reads $ unpack x of
(x', _):_ -> (x', _):_ ->
case lookup x' pairs' of case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"] Nothing -> FormFailure ["Invalid entry"]
@ -203,19 +207,19 @@ selectField pairs ffs initial = toForm $ do
<option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)} <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}
|] |]
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = input , fiInput = input
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ toHtml x
_ -> Nothing _ -> Nothing
, fiRequired = True , fiRequired = True
} }
return (res, fi, UrlEncoded) return (res, fi, UrlEncoded)
maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)
=> [(x, String)] => [(x, Text)]
-> FormFieldSettings -> FormFieldSettings
-> Maybe (FormType f) -> Maybe (FormType f)
-> f -> f
@ -231,7 +235,7 @@ maybeSelectField pairs ffs initial' = toForm $ do
Nothing -> FormMissing Nothing -> FormMissing
Just "none" -> FormSuccess Nothing Just "none" -> FormSuccess Nothing
Just x -> Just x ->
case reads x of case reads $ unpack x of
(x', _):_ -> (x', _):_ ->
case lookup x' pairs' of case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"] Nothing -> FormFailure ["Invalid entry"]
@ -253,28 +257,28 @@ maybeSelectField pairs ffs initial' = toForm $ do
<option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)} <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}
|] |]
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = input , fiInput = input
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ toHtml x
_ -> Nothing _ -> Nothing
, fiRequired = False , fiRequired = False
} }
return (res, fi, UrlEncoded) return (res, fi, UrlEncoded)
stringInput :: String -> FormInput sub master String stringInput :: Text -> FormInput sub master Text
stringInput n = stringInput n =
mapFormXml fieldsToInput $ mapFormXml fieldsToInput $
requiredFieldHelper stringFieldProfile (nameSettings n) Nothing requiredFieldHelper stringFieldProfile (nameSettings n) Nothing
maybeStringInput :: String -> FormInput sub master (Maybe String) maybeStringInput :: Text -> FormInput sub master (Maybe Text)
maybeStringInput n = maybeStringInput n =
mapFormXml fieldsToInput $ mapFormXml fieldsToInput $
optionalFieldHelper stringFieldProfile (nameSettings n) Nothing optionalFieldHelper stringFieldProfile (nameSettings n) Nothing
boolInput :: String -> FormInput sub master Bool boolInput :: Text -> FormInput sub master Bool
boolInput n = GForm $ do boolInput n = GForm $ do
env <- askParams env <- askParams
let res = case lookup n env of let res = case lookup n env of
@ -287,51 +291,51 @@ boolInput n = GForm $ do
|] |]
return (res, [xml], UrlEncoded) return (res, [xml], UrlEncoded)
dayInput :: String -> FormInput sub master Day dayInput :: Text -> FormInput sub master Day
dayInput n = dayInput n =
mapFormXml fieldsToInput $ mapFormXml fieldsToInput $
requiredFieldHelper dayFieldProfile (nameSettings n) Nothing requiredFieldHelper dayFieldProfile (nameSettings n) Nothing
maybeDayInput :: String -> FormInput sub master (Maybe Day) maybeDayInput :: Text -> FormInput sub master (Maybe Day)
maybeDayInput n = maybeDayInput n =
mapFormXml fieldsToInput $ mapFormXml fieldsToInput $
optionalFieldHelper dayFieldProfile (nameSettings n) Nothing optionalFieldHelper dayFieldProfile (nameSettings n) Nothing
nameSettings :: String -> FormFieldSettings nameSettings :: Text -> FormFieldSettings
nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
urlField :: (IsForm f, FormType f ~ String) urlField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe String -> f => FormFieldSettings -> Maybe Text -> f
urlField = requiredFieldHelper urlFieldProfile urlField = requiredFieldHelper urlFieldProfile
maybeUrlField :: (IsForm f, FormType f ~ Maybe String) maybeUrlField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe String) -> f => FormFieldSettings -> Maybe (Maybe Text) -> f
maybeUrlField = optionalFieldHelper urlFieldProfile maybeUrlField = optionalFieldHelper urlFieldProfile
urlInput :: String -> FormInput sub master String urlInput :: Text -> FormInput sub master Text
urlInput n = urlInput n =
mapFormXml fieldsToInput $ mapFormXml fieldsToInput $
requiredFieldHelper urlFieldProfile (nameSettings n) Nothing requiredFieldHelper urlFieldProfile (nameSettings n) Nothing
emailField :: (IsForm f, FormType f ~ String) emailField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe String -> f => FormFieldSettings -> Maybe Text -> f
emailField = requiredFieldHelper emailFieldProfile emailField = requiredFieldHelper emailFieldProfile
maybeEmailField :: (IsForm f, FormType f ~ Maybe String) maybeEmailField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe String) -> f => FormFieldSettings -> Maybe (Maybe Text) -> f
maybeEmailField = optionalFieldHelper emailFieldProfile maybeEmailField = optionalFieldHelper emailFieldProfile
emailInput :: String -> FormInput sub master String emailInput :: Text -> FormInput sub master Text
emailInput n = emailInput n =
mapFormXml fieldsToInput $ mapFormXml fieldsToInput $
requiredFieldHelper emailFieldProfile (nameSettings n) Nothing requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
searchField :: (IsForm f, FormType f ~ String) searchField :: (IsForm f, FormType f ~ Text)
=> AutoFocus -> FormFieldSettings -> Maybe String -> f => AutoFocus -> FormFieldSettings -> Maybe Text -> f
searchField = requiredFieldHelper . searchFieldProfile searchField = requiredFieldHelper . searchFieldProfile
maybeSearchField :: (IsForm f, FormType f ~ Maybe String) maybeSearchField :: (IsForm f, FormType f ~ Maybe Text)
=> AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> f => AutoFocus -> FormFieldSettings -> Maybe (Maybe Text) -> f
maybeSearchField = optionalFieldHelper . searchFieldProfile maybeSearchField = optionalFieldHelper . searchFieldProfile
textareaField :: (IsForm f, FormType f ~ Textarea) textareaField :: (IsForm f, FormType f ~ Textarea)
@ -341,12 +345,12 @@ textareaField = requiredFieldHelper textareaFieldProfile
maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)
maybeTextareaField = optionalFieldHelper textareaFieldProfile maybeTextareaField = optionalFieldHelper textareaFieldProfile
hiddenField :: (IsForm f, FormType f ~ String) hiddenField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe String -> f => FormFieldSettings -> Maybe Text -> f
hiddenField = requiredFieldHelper hiddenFieldProfile hiddenField = requiredFieldHelper hiddenFieldProfile
maybeHiddenField :: (IsForm f, FormType f ~ Maybe String) maybeHiddenField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe String) -> f => FormFieldSettings -> Maybe (Maybe Text) -> f
maybeHiddenField = optionalFieldHelper hiddenFieldProfile maybeHiddenField = optionalFieldHelper hiddenFieldProfile
fileField :: (IsForm f, FormType f ~ FileInfo) fileField :: (IsForm f, FormType f ~ FileInfo)
@ -364,17 +368,17 @@ fileField ffs = toForm $ do
Nothing -> FormFailure ["File is required"] Nothing -> FormFailure ["File is required"]
Just x -> FormSuccess x Just x -> FormSuccess x
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = fileWidget theId name True , fiInput = fileWidget theId name True
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ toHtml x
_ -> Nothing _ -> Nothing
, fiRequired = True , fiRequired = True
} }
let res' = case res of let res' = case res of
FormFailure [e] -> FormFailure [label ++ ": " ++ e] FormFailure [e] -> FormFailure [T.concat [label, ": ", e]]
_ -> res _ -> res
return (res', fi, Multipart) return (res', fi, Multipart)
@ -387,7 +391,7 @@ maybeFileField ffs = toForm $ do
theId <- maybe newFormIdent return theId' theId <- maybe newFormIdent return theId'
let res = FormSuccess $ lookup name fenv let res = FormSuccess $ lookup name fenv
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = fileWidget theId name False , fiInput = fileWidget theId name False
@ -396,7 +400,7 @@ maybeFileField ffs = toForm $ do
} }
return (res, fi, Multipart) return (res, fi, Multipart)
fileWidget :: String -> String -> Bool -> GWidget s m () fileWidget :: Text -> Text -> Bool -> GWidget s m ()
fileWidget theId name isReq = [HAMLET| fileWidget theId name isReq = [HAMLET|
<input id="#{theId}" type="file" name="#{name}" :isReq:required=""> <input id="#{theId}" type="file" name="#{name}" :isReq:required="">
|] |]
@ -417,7 +421,7 @@ radioField pairs ffs initial = toForm $ do
Nothing -> FormMissing Nothing -> FormMissing
Just "none" -> FormFailure ["Field is required"] Just "none" -> FormFailure ["Field is required"]
Just x -> Just x ->
case reads x of case reads $ unpack x of
(x', _):_ -> (x', _):_ ->
case lookup x' pairs' of case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"] Nothing -> FormFailure ["Invalid entry"]
@ -435,12 +439,12 @@ radioField pairs ffs initial = toForm $ do
<label for="#{name}-#{show (fst pair)}">#{snd (snd pair)} <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}
|] |]
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = input , fiInput = input
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ toHtml x
_ -> Nothing _ -> Nothing
, fiRequired = True , fiRequired = True
} }
@ -464,7 +468,7 @@ maybeRadioField pairs ffs initial' = toForm $ do
Nothing -> FormMissing Nothing -> FormMissing
Just "none" -> FormSuccess Nothing Just "none" -> FormSuccess Nothing
Just x -> Just x ->
case reads x of case reads $ unpack x of
(x', _):_ -> (x', _):_ ->
case lookup x' pairs' of case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"] Nothing -> FormFailure ["Invalid entry"]
@ -494,12 +498,12 @@ maybeRadioField pairs ffs initial' = toForm $ do
<label for="#{name}-#{show (fst pair)}">#{snd (snd pair)} <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}
|] |]
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = string label { fiLabel = toHtml label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = theId , fiIdent = theId
, fiInput = input , fiInput = input
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ toHtml x
_ -> Nothing _ -> Nothing
, fiRequired = False , fiRequired = False
} }

38
Yesod/Form/Jquery.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Some fields spiced up with jQuery UI. -- | Some fields spiced up with jQuery UI.
module Yesod.Form.Jquery module Yesod.Form.Jquery
( YesodJquery (..) ( YesodJquery (..)
@ -28,6 +29,8 @@ import Data.Default
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import Text.Julius (julius) import Text.Julius (julius)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Text (Text, pack, unpack)
import Data.Monoid (mconcat)
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet #define HAMLET hamlet
@ -40,8 +43,8 @@ import Control.Monad.Trans.Class (lift)
#endif #endif
-- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme.
googleHostedJqueryUiCss :: String -> String googleHostedJqueryUiCss :: Text -> Text
googleHostedJqueryUiCss theme = concat googleHostedJqueryUiCss theme = mconcat
[ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/" [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/"
, theme , theme
, "/jquery-ui.css" , "/jquery-ui.css"
@ -49,19 +52,19 @@ googleHostedJqueryUiCss theme = concat
class YesodJquery a where class YesodJquery a where
-- | The jQuery 1.4 Javascript file. -- | The jQuery 1.4 Javascript file.
urlJqueryJs :: a -> Either (Route a) String urlJqueryJs :: a -> Either (Route a) Text
urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js" urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js"
-- | The jQuery UI 1.8 Javascript file. -- | The jQuery UI 1.8 Javascript file.
urlJqueryUiJs :: a -> Either (Route a) String urlJqueryUiJs :: a -> Either (Route a) Text
urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js" urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js"
-- | The jQuery UI 1.8 CSS file; defaults to cupertino theme. -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme.
urlJqueryUiCss :: a -> Either (Route a) String urlJqueryUiCss :: a -> Either (Route a) Text
urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino" urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino"
-- | jQuery UI time picker add-on. -- | jQuery UI time picker add-on.
urlJqueryUiDateTimePicker :: a -> Either (Route a) String urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f)) jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f))
@ -86,7 +89,8 @@ jqueryDayFieldProfile jds = FieldProfile
(Left "Invalid day, must be in YYYY-MM-DD format") (Left "Invalid day, must be in YYYY-MM-DD format")
Right Right
. readMay . readMay
, fpRender = show . unpack
, fpRender = pack . show
, fpWidget = \theId name val isReq -> do , fpWidget = \theId name val isReq -> do
addHtml [HAMLET|\ addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
@ -105,8 +109,8 @@ $(function(){$("##{theId}").datepicker({
|] |]
} }
where where
jsBool True = "true" jsBool True = "true" :: Text
jsBool False = "false" jsBool False = "false" :: Text
mos (Left i) = show i mos (Left i) = show i
mos (Right (x, y)) = concat mos (Right (x, y)) = concat
[ "[" [ "["
@ -143,8 +147,8 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime
jqueryDayTimeFieldProfile = FieldProfile jqueryDayTimeFieldProfile = FieldProfile
{ fpParse = parseUTCTime { fpParse = parseUTCTime . unpack
, fpRender = jqueryDayTimeUTCTime , fpRender = pack . jqueryDayTimeUTCTime
, fpWidget = \theId name val isReq -> do , fpWidget = \theId name val isReq -> do
addHtml [HAMLET|\ addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
@ -158,7 +162,7 @@ $(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}
|] |]
} }
parseUTCTime :: String -> Either String UTCTime parseUTCTime :: String -> Either Text UTCTime
parseUTCTime s = parseUTCTime s =
let (dateS, timeS) = break isSpace (dropWhile isSpace s) let (dateS, timeS) = break isSpace (dropWhile isSpace s)
dateE = parseDate dateS dateE = parseDate dateS
@ -169,7 +173,7 @@ parseUTCTime s =
(UTCTime date . timeOfDayToTime) (UTCTime date . timeOfDayToTime)
jqueryAutocompleteField jqueryAutocompleteField
:: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f)) :: (IsForm f, FormType f ~ Text, YesodJquery (FormMaster f))
=> Route (FormMaster f) => Route (FormMaster f)
-> FormFieldSettings -> FormFieldSettings
-> Maybe (FormType f) -> Maybe (FormType f)
@ -177,7 +181,7 @@ jqueryAutocompleteField
jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile
maybeJqueryAutocompleteField maybeJqueryAutocompleteField
:: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f)) :: (IsForm f, FormType f ~ Maybe Text, YesodJquery (FormMaster f))
=> Route (FormMaster f) => Route (FormMaster f)
-> FormFieldSettings -> FormFieldSettings
-> Maybe (FormType f) -> Maybe (FormType f)
@ -185,7 +189,7 @@ maybeJqueryAutocompleteField
maybeJqueryAutocompleteField src = maybeJqueryAutocompleteField src =
optionalFieldHelper $ jqueryAutocompleteFieldProfile src optionalFieldHelper $ jqueryAutocompleteFieldProfile src
jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y Text
jqueryAutocompleteFieldProfile src = FieldProfile jqueryAutocompleteFieldProfile src = FieldProfile
{ fpParse = Right { fpParse = Right
, fpRender = id , fpRender = id
@ -201,12 +205,12 @@ $(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
|] |]
} }
addScript' :: (y -> Either (Route y) String) -> GWidget sub y () addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
addScript' f = do addScript' f = do
y <- lift getYesod y <- lift getYesod
addScriptEither $ f y addScriptEither $ f y
addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y () addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y ()
addStylesheet' f = do addStylesheet' f = do
y <- lift getYesod y <- lift getYesod
addStylesheetEither $ f y addStylesheetEither $ f y

10
Yesod/Form/Nic.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Provide the user with a rich text editor. -- | Provide the user with a rich text editor.
module Yesod.Form.Nic module Yesod.Form.Nic
( YesodNic (..) ( YesodNic (..)
@ -18,10 +19,11 @@ import Text.Julius (julius)
import Text.Blaze.Renderer.String (renderHtml) import Text.Blaze.Renderer.String (renderHtml)
import Text.Blaze (preEscapedString) import Text.Blaze (preEscapedString)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Text (Text, pack, unpack)
class YesodNic a where class YesodNic a where
-- | NIC Editor Javascript file. -- | NIC Editor Javascript file.
urlNicEdit :: a -> Either (Route a) String urlNicEdit :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f)) nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f))
@ -35,8 +37,8 @@ maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile
nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html
nicHtmlFieldProfile = FieldProfile nicHtmlFieldProfile = FieldProfile
{ fpParse = Right . preEscapedString . sanitizeBalance { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
, fpRender = renderHtml , fpRender = pack . renderHtml
, fpWidget = \theId name val _isReq -> do , fpWidget = \theId name val _isReq -> do
addHtml addHtml
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
@ -57,7 +59,7 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{th
|] |]
} }
addScript' :: (y -> Either (Route y) String) -> GWidget sub y () addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
addScript' f = do addScript' f = do
y <- lift getYesod y <- lift getYesod
addScriptEither $ f y addScriptEither $ f y

52
Yesod/Form/Profiles.hs
View File

@ -40,6 +40,7 @@ import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
import Text.Blaze.Renderer.String (renderHtml) import Text.Blaze.Renderer.String (renderHtml)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Text (Text, unpack, pack)
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet #define HAMLET hamlet
@ -53,8 +54,8 @@ import qualified Data.ByteString.Lazy as L
intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile :: Integral i => FieldProfile sub y i
intFieldProfile = FieldProfile intFieldProfile = FieldProfile
{ fpParse = maybe (Left "Invalid integer") Right . readMayI { fpParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read
, fpRender = showI , fpRender = pack . showI
, fpWidget = \theId name val isReq -> addHamlet , fpWidget = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">
@ -68,8 +69,8 @@ intFieldProfile = FieldProfile
doubleFieldProfile :: FieldProfile sub y Double doubleFieldProfile :: FieldProfile sub y Double
doubleFieldProfile = FieldProfile doubleFieldProfile = FieldProfile
{ fpParse = maybe (Left "Invalid number") Right . readMay { fpParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read
, fpRender = show , fpRender = pack . show
, fpWidget = \theId name val isReq -> addHamlet , fpWidget = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
@ -78,8 +79,8 @@ doubleFieldProfile = FieldProfile
dayFieldProfile :: FieldProfile sub y Day dayFieldProfile :: FieldProfile sub y Day
dayFieldProfile = FieldProfile dayFieldProfile = FieldProfile
{ fpParse = parseDate { fpParse = parseDate . unpack
, fpRender = show , fpRender = pack . show
, fpWidget = \theId name val isReq -> addHamlet , fpWidget = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
@ -88,8 +89,8 @@ dayFieldProfile = FieldProfile
timeFieldProfile :: FieldProfile sub y TimeOfDay timeFieldProfile :: FieldProfile sub y TimeOfDay
timeFieldProfile = FieldProfile timeFieldProfile = FieldProfile
{ fpParse = parseTime { fpParse = parseTime . unpack
, fpRender = show . roundFullSeconds , fpRender = pack . show . roundFullSeconds
, fpWidget = \theId name val isReq -> addHamlet , fpWidget = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}"> <input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
@ -103,8 +104,8 @@ timeFieldProfile = FieldProfile
htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile :: FieldProfile sub y Html
htmlFieldProfile = FieldProfile htmlFieldProfile = FieldProfile
{ fpParse = Right . preEscapedString . sanitizeBalance { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
, fpRender = renderHtml , fpRender = pack . renderHtml
, fpWidget = \theId name val _isReq -> addHamlet , fpWidget = \theId name val _isReq -> addHamlet
[HAMLET|\ [HAMLET|\
<textarea id="#{theId}" name="#{name}" .html>#{val} <textarea id="#{theId}" name="#{name}" .html>#{val}
@ -113,7 +114,7 @@ htmlFieldProfile = FieldProfile
-- | A newtype wrapper around a 'String' that converts newlines to HTML -- | A newtype wrapper around a 'String' that converts newlines to HTML
-- br-tags. -- br-tags.
newtype Textarea = Textarea { unTextarea :: String } newtype Textarea = Textarea { unTextarea :: Text }
deriving (Show, Read, Eq, PersistField) deriving (Show, Read, Eq, PersistField)
instance ToHtml Textarea where instance ToHtml Textarea where
toHtml = toHtml =
@ -122,6 +123,7 @@ instance ToHtml Textarea where
. L.toChunks . L.toChunks
. toLazyByteString . toLazyByteString
. fromWriteList writeHtmlEscapedChar . fromWriteList writeHtmlEscapedChar
. unpack
. unTextarea . unTextarea
where where
-- Taken from blaze-builder and modified with newline handling. -- Taken from blaze-builder and modified with newline handling.
@ -138,7 +140,7 @@ textareaFieldProfile = FieldProfile
|] |]
} }
hiddenFieldProfile :: FieldProfile sub y String hiddenFieldProfile :: FieldProfile sub y Text
hiddenFieldProfile = FieldProfile hiddenFieldProfile = FieldProfile
{ fpParse = Right { fpParse = Right
, fpRender = id , fpRender = id
@ -148,7 +150,7 @@ hiddenFieldProfile = FieldProfile
|] |]
} }
stringFieldProfile :: FieldProfile sub y String stringFieldProfile :: FieldProfile sub y Text
stringFieldProfile = FieldProfile stringFieldProfile = FieldProfile
{ fpParse = Right { fpParse = Right
, fpRender = id , fpRender = id
@ -158,7 +160,7 @@ stringFieldProfile = FieldProfile
|] |]
} }
passwordFieldProfile :: FieldProfile s m String passwordFieldProfile :: FieldProfile s m Text
passwordFieldProfile = FieldProfile passwordFieldProfile = FieldProfile
{ fpParse = Right { fpParse = Right
, fpRender = id , fpRender = id
@ -173,7 +175,7 @@ readMay s = case reads s of
(x, _):_ -> Just x (x, _):_ -> Just x
[] -> Nothing [] -> Nothing
parseDate :: String -> Either String Day parseDate :: String -> Either Text Day
parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
. readMay . replace '/' '-' . readMay . replace '/' '-'
@ -182,7 +184,7 @@ parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
replace :: Eq a => a -> a -> [a] -> [a] replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z) replace x y = map (\z -> if z == x then y else z)
parseTime :: String -> Either String TimeOfDay parseTime :: String -> Either Text TimeOfDay
parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') 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:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =
@ -195,20 +197,20 @@ parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"
parseTimeHelper :: (Char, Char, Char, Char, Char, Char) parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
-> Either [Char] TimeOfDay -> Either Text TimeOfDay
parseTimeHelper (h1, h2, m1, m2, s1, s2) parseTimeHelper (h1, h2, m1, m2, s1, s2)
| h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h | h < 0 || h > 23 = Left $ pack $ "Invalid hour: " ++ show h
| m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m | m < 0 || m > 59 = Left $ pack $ "Invalid minute: " ++ show m
| s < 0 || s > 59 = Left $ "Invalid second: " ++ show s | s < 0 || s > 59 = Left $ pack $ "Invalid second: " ++ show s
| otherwise = Right $ TimeOfDay h m s | otherwise = Right $ TimeOfDay h m s
where where
h = read [h1, h2] h = read [h1, h2]
m = read [m1, m2] m = read [m1, m2]
s = fromInteger $ read [s1, s2] s = fromInteger $ read [s1, s2]
emailFieldProfile :: FieldProfile s y String emailFieldProfile :: FieldProfile s y Text
emailFieldProfile = FieldProfile emailFieldProfile = FieldProfile
{ fpParse = \s -> if Email.isValid s { fpParse = \s -> if Email.isValid (unpack s)
then Right s then Right s
else Left "Invalid e-mail address" else Left "Invalid e-mail address"
, fpRender = id , fpRender = id
@ -219,7 +221,7 @@ emailFieldProfile = FieldProfile
} }
type AutoFocus = Bool type AutoFocus = Bool
searchFieldProfile :: AutoFocus -> FieldProfile s y String searchFieldProfile :: AutoFocus -> FieldProfile s y Text
searchFieldProfile autoFocus = FieldProfile searchFieldProfile autoFocus = FieldProfile
{ fpParse = Right { fpParse = Right
, fpRender = id , fpRender = id
@ -236,9 +238,9 @@ searchFieldProfile autoFocus = FieldProfile
|] |]
} }
urlFieldProfile :: FieldProfile s y String urlFieldProfile :: FieldProfile s y Text
urlFieldProfile = FieldProfile urlFieldProfile = FieldProfile
{ fpParse = \s -> case parseURI s of { fpParse = \s -> case parseURI $ unpack s of
Nothing -> Left "Invalid URL" Nothing -> Left "Invalid URL"
Just _ -> Right s Just _ -> Right s
, fpRender = id , fpRender = id

13
yesod-form.cabal
View File

@ -1,5 +1,5 @@
name: yesod-form name: yesod-form
version: 0.0.0.1 version: 0.1.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -9,23 +9,24 @@ category: Web, Yesod
stability: Stable stability: Stable
cabal-version: >= 1.6 cabal-version: >= 1.6
build-type: Simple build-type: Simple
homepage: http://docs.yesodweb.com/ homepage: http://www.yesodweb.com/
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.7 && < 0.8 , yesod-core >= 0.8 && < 0.9
, time >= 1.1.4 && < 1.3 , time >= 1.1.4 && < 1.3
, hamlet >= 0.7 && < 0.8 , hamlet >= 0.8 && < 0.9
, persistent >= 0.4 && < 0.5 , persistent >= 0.5 && < 0.6
, template-haskell , template-haskell
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
, data-default >= 0.2 && < 0.3 , data-default >= 0.2 && < 0.3
, xss-sanitize >= 0.2.4 && < 0.3 , xss-sanitize >= 0.2.4 && < 0.3
, blaze-builder >= 0.2.1 && < 0.3 , blaze-builder >= 0.2.1 && < 0.4
, network >= 2.2 && < 2.4 , network >= 2.2 && < 2.4
, email-validate >= 0.2.6 && < 0.3 , email-validate >= 0.2.6 && < 0.3
, blaze-html >= 0.4 && < 0.5 , blaze-html >= 0.4 && < 0.5
, bytestring >= 0.9 && < 0.10 , bytestring >= 0.9 && < 0.10
, text >= 0.7 && < 1.0
exposed-modules: Yesod.Form exposed-modules: Yesod.Form
Yesod.Form.Class Yesod.Form.Class
Yesod.Form.Core Yesod.Form.Core