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 GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Parse forms (and query strings).
module Yesod.Form
( -- * Data types
@ -63,6 +64,8 @@ import Data.Char (toUpper, isUpper)
import Control.Arrow ((&&&))
import Data.List (group, sort)
import Data.Monoid (mempty)
import Data.Text (Text)
import Text.Blaze (toHtml)
#if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet
@ -88,7 +91,7 @@ fieldsToTable = mapFormXml $ mapM_ go
$maybe err <- fiErrors fi
<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.
fieldsToDivs :: FormField sub y a -> Form sub y a
@ -102,7 +105,7 @@ fieldsToDivs = mapFormXml $ mapM_ go
$maybe err <- fiErrors fi
<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.
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}">
|]
nonceName :: String
nonceName :: Text
nonceName = "_nonce"
-- | Run a form against POST parameters. Please note that this does not provide
@ -258,7 +261,7 @@ mkToForm =
just <- [|pure|]
nothing <- [|Nothing|]
let just' = just `AppE` ConE (mkName $ entityName t)
string' <- [|string|]
string' <- [|toHtml|]
ftt <- [|fieldsToTable|]
ffs' <- [|FormFieldSettings|]
let stm "" = nothing
@ -306,6 +309,6 @@ toLabel (x:rest) = toUpper x : go rest
| isUpper c = ' ' : c : go cs
| otherwise = c : go cs
formFailures :: FormResult a -> Maybe [String]
formFailures :: FormResult a -> Maybe [Text]
formFailures (FormFailure x) = Just x
formFailures _ = Nothing

8
Yesod/Form/Class.hs
View File

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

47
Yesod/Form/Core.hs
View File

@ -52,6 +52,13 @@ import Text.Hamlet
import Text.Blaze (ToHtml (..))
import Data.String
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,
-- 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
-- 'FormResult's.
data FormResult a = FormMissing
| FormFailure [String]
| FormFailure [Text]
| FormSuccess a
deriving Show
instance Functor FormResult where
@ -92,7 +99,7 @@ instance Monoid Enctype where
data Ints = IntCons Int Ints | IntSingle Int
instance Show Ints where
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 (IntSingle i) = IntSingle $ i + 1
@ -113,16 +120,16 @@ type FormInner s m =
GHandler s m
)))
type Env = [(String, String)]
type FileEnv = [(String, FileInfo)]
type Env = [(Text, Text)]
type FileEnv = [(Text, FileInfo)]
-- | Get a unique identifier.
newFormIdent :: Monad m => StateT Ints m String
newFormIdent :: Monad m => StateT Ints m Text
newFormIdent = do
i <- get
let i' = incrInts i
put i'
return $ 'f' : show i'
return $ pack $ 'f' : show i'
deeperFormIdent :: Monad m => StateT Ints m ()
deeperFormIdent = do
@ -172,12 +179,12 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do
Left e -> (FormFailure [e], x)
Right y -> (FormSuccess y, x)
let fi = FieldInfo
{ fiLabel = string label
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = mkWidget theId name val True
, fiErrors = case res of
FormFailure [x] -> Just $ string x
FormFailure [x] -> Just $ toHtml x
_ -> Nothing
, fiRequired = True
}
@ -261,12 +268,12 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do
Left e -> (FormFailure [e], x)
Right y -> (FormSuccess $ Just y, x)
let fi = FieldInfo
{ fiLabel = string label
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = mkWidget theId name val False
, fiErrors = case res of
FormFailure x -> Just $ string $ unlines x
FormFailure x -> Just $ toHtml $ T.unlines x
_ -> Nothing
, fiRequired = False
}
@ -290,29 +297,29 @@ mapFormXml f (GForm g) = GForm $ do
data FieldInfo sub y = FieldInfo
{ fiLabel :: Html
, fiTooltip :: Html
, fiIdent :: String
, fiIdent :: Text
, fiInput :: GWidget sub y ()
, fiErrors :: Maybe Html
, fiRequired :: Bool
}
data FormFieldSettings = FormFieldSettings
{ ffsLabel :: String
{ ffsLabel :: Text
, ffsTooltip :: Html
, ffsId :: Maybe String
, ffsName :: Maybe String
, ffsId :: Maybe Text
, ffsName :: Maybe Text
}
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
-- required and optional fields. See 'requiredFieldHelper and
-- 'optionalFieldHelper'.
data FieldProfile sub y a = FieldProfile
{ fpParse :: String -> Either String a
, fpRender :: a -> String
{ fpParse :: Text -> Either Text a
, fpRender :: a -> Text
-- | 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 ())
@ -338,7 +345,7 @@ checkForm f (GForm form) = GForm $ do
--
-- Unlike 'checkForm', the validation error will appear in the generated HTML
-- 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
(res, xml, enc) <- form
let (res', merr) =
@ -355,7 +362,7 @@ checkField f (GForm form) = GForm $ do
Just err -> flip map xml $ \fi -> fi
{ fiErrors = Just $
case fiErrors fi of
Nothing -> string err
Nothing -> toHtml err
Just x -> x
}
return (res', xml', enc)

112
Yesod/Form/Fields.hs
View File

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

38
Yesod/Form/Jquery.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Some fields spiced up with jQuery UI.
module Yesod.Form.Jquery
( YesodJquery (..)
@ -28,6 +29,8 @@ import Data.Default
import Text.Hamlet (hamlet)
import Text.Julius (julius)
import Control.Monad.Trans.Class (lift)
import Data.Text (Text, pack, unpack)
import Data.Monoid (mconcat)
#if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet
@ -40,8 +43,8 @@ import Control.Monad.Trans.Class (lift)
#endif
-- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme.
googleHostedJqueryUiCss :: String -> String
googleHostedJqueryUiCss theme = concat
googleHostedJqueryUiCss :: Text -> Text
googleHostedJqueryUiCss theme = mconcat
[ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/"
, theme
, "/jquery-ui.css"
@ -49,19 +52,19 @@ googleHostedJqueryUiCss theme = concat
class YesodJquery a where
-- | 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"
-- | 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"
-- | 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"
-- | 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"
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")
Right
. readMay
, fpRender = show
. unpack
, fpRender = pack . show
, fpWidget = \theId name val isReq -> do
addHtml [HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
@ -105,8 +109,8 @@ $(function(){$("##{theId}").datepicker({
|]
}
where
jsBool True = "true"
jsBool False = "false"
jsBool True = "true" :: Text
jsBool False = "false" :: Text
mos (Left i) = show i
mos (Right (x, y)) = concat
[ "["
@ -143,8 +147,8 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime
jqueryDayTimeFieldProfile = FieldProfile
{ fpParse = parseUTCTime
, fpRender = jqueryDayTimeUTCTime
{ fpParse = parseUTCTime . unpack
, fpRender = pack . jqueryDayTimeUTCTime
, fpWidget = \theId name val isReq -> do
addHtml [HAMLET|\
<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 =
let (dateS, timeS) = break isSpace (dropWhile isSpace s)
dateE = parseDate dateS
@ -169,7 +173,7 @@ parseUTCTime s =
(UTCTime date . timeOfDayToTime)
jqueryAutocompleteField
:: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f))
:: (IsForm f, FormType f ~ Text, YesodJquery (FormMaster f))
=> Route (FormMaster f)
-> FormFieldSettings
-> Maybe (FormType f)
@ -177,7 +181,7 @@ jqueryAutocompleteField
jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile
maybeJqueryAutocompleteField
:: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f))
:: (IsForm f, FormType f ~ Maybe Text, YesodJquery (FormMaster f))
=> Route (FormMaster f)
-> FormFieldSettings
-> Maybe (FormType f)
@ -185,7 +189,7 @@ maybeJqueryAutocompleteField
maybeJqueryAutocompleteField 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
{ fpParse = Right
, 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
y <- lift getYesod
addScriptEither $ f y
addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()
addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y ()
addStylesheet' f = do
y <- lift getYesod
addStylesheetEither $ f y

10
Yesod/Form/Nic.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Provide the user with a rich text editor.
module Yesod.Form.Nic
( YesodNic (..)
@ -18,10 +19,11 @@ import Text.Julius (julius)
import Text.Blaze.Renderer.String (renderHtml)
import Text.Blaze (preEscapedString)
import Control.Monad.Trans.Class (lift)
import Data.Text (Text, pack, unpack)
class YesodNic a where
-- | 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"
nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f))
@ -35,8 +37,8 @@ maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile
nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html
nicHtmlFieldProfile = FieldProfile
{ fpParse = Right . preEscapedString . sanitizeBalance
, fpRender = renderHtml
{ fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
, fpRender = pack . renderHtml
, fpWidget = \theId name val _isReq -> do
addHtml
#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
y <- lift getYesod
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 qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Text (Text, unpack, pack)
#if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet
@ -53,8 +54,8 @@ import qualified Data.ByteString.Lazy as L
intFieldProfile :: Integral i => FieldProfile sub y i
intFieldProfile = FieldProfile
{ fpParse = maybe (Left "Invalid integer") Right . readMayI
, fpRender = showI
{ fpParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read
, fpRender = pack . showI
, fpWidget = \theId name val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">
@ -68,8 +69,8 @@ intFieldProfile = FieldProfile
doubleFieldProfile :: FieldProfile sub y Double
doubleFieldProfile = FieldProfile
{ fpParse = maybe (Left "Invalid number") Right . readMay
, fpRender = show
{ fpParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read
, fpRender = pack . show
, fpWidget = \theId name val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
@ -78,8 +79,8 @@ doubleFieldProfile = FieldProfile
dayFieldProfile :: FieldProfile sub y Day
dayFieldProfile = FieldProfile
{ fpParse = parseDate
, fpRender = show
{ fpParse = parseDate . unpack
, fpRender = pack . show
, fpWidget = \theId name val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
@ -88,8 +89,8 @@ dayFieldProfile = FieldProfile
timeFieldProfile :: FieldProfile sub y TimeOfDay
timeFieldProfile = FieldProfile
{ fpParse = parseTime
, fpRender = show . roundFullSeconds
{ fpParse = parseTime . unpack
, fpRender = pack . show . roundFullSeconds
, fpWidget = \theId name val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
@ -103,8 +104,8 @@ timeFieldProfile = FieldProfile
htmlFieldProfile :: FieldProfile sub y Html
htmlFieldProfile = FieldProfile
{ fpParse = Right . preEscapedString . sanitizeBalance
, fpRender = renderHtml
{ fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
, fpRender = pack . renderHtml
, fpWidget = \theId name val _isReq -> addHamlet
[HAMLET|\
<textarea id="#{theId}" name="#{name}" .html>#{val}
@ -113,7 +114,7 @@ htmlFieldProfile = FieldProfile
-- | A newtype wrapper around a 'String' that converts newlines to HTML
-- br-tags.
newtype Textarea = Textarea { unTextarea :: String }
newtype Textarea = Textarea { unTextarea :: Text }
deriving (Show, Read, Eq, PersistField)
instance ToHtml Textarea where
toHtml =
@ -122,6 +123,7 @@ instance ToHtml Textarea where
. L.toChunks
. toLazyByteString
. fromWriteList writeHtmlEscapedChar
. unpack
. unTextarea
where
-- 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
{ fpParse = Right
, fpRender = id
@ -148,7 +150,7 @@ hiddenFieldProfile = FieldProfile
|]
}
stringFieldProfile :: FieldProfile sub y String
stringFieldProfile :: FieldProfile sub y Text
stringFieldProfile = FieldProfile
{ fpParse = Right
, fpRender = id
@ -158,7 +160,7 @@ stringFieldProfile = FieldProfile
|]
}
passwordFieldProfile :: FieldProfile s m String
passwordFieldProfile :: FieldProfile s m Text
passwordFieldProfile = FieldProfile
{ fpParse = Right
, fpRender = id
@ -173,7 +175,7 @@ readMay s = case reads s of
(x, _):_ -> Just x
[] -> Nothing
parseDate :: String -> Either String Day
parseDate :: String -> Either Text Day
parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
. 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 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 (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
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"
parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
-> Either [Char] TimeOfDay
-> Either Text 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
| h < 0 || h > 23 = Left $ pack $ "Invalid hour: " ++ show h
| m < 0 || m > 59 = Left $ pack $ "Invalid minute: " ++ show m
| s < 0 || s > 59 = Left $ pack $ "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 s y Text
emailFieldProfile = FieldProfile
{ fpParse = \s -> if Email.isValid s
{ fpParse = \s -> if Email.isValid (unpack s)
then Right s
else Left "Invalid e-mail address"
, fpRender = id
@ -219,7 +221,7 @@ emailFieldProfile = FieldProfile
}
type AutoFocus = Bool
searchFieldProfile :: AutoFocus -> FieldProfile s y String
searchFieldProfile :: AutoFocus -> FieldProfile s y Text
searchFieldProfile autoFocus = FieldProfile
{ fpParse = Right
, fpRender = id
@ -236,9 +238,9 @@ searchFieldProfile autoFocus = FieldProfile
|]
}
urlFieldProfile :: FieldProfile s y String
urlFieldProfile :: FieldProfile s y Text
urlFieldProfile = FieldProfile
{ fpParse = \s -> case parseURI s of
{ fpParse = \s -> case parseURI $ unpack s of
Nothing -> Left "Invalid URL"
Just _ -> Right s
, fpRender = id

13
yesod-form.cabal
View File

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