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

i18n, not entirely complete

Browse Source
This commit is contained in:
Michael Snoyman 2011-05-15 17:01:30 +03:00
parent e7ca38515d
commit 87535d468b
8 changed files with 205 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
Yesod/Form/Class.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Form.Class module Yesod.Form.Class
( ToForm (..) ( ToForm (..)
, ToField (..) , ToField (..)
@ -15,12 +16,13 @@ import Data.Int (Int64)
import Data.Time (Day, TimeOfDay) import Data.Time (Day, TimeOfDay)
import Data.Text (Text) import Data.Text (Text)
import Yesod.Handler (GGHandler) import Yesod.Handler (GGHandler)
import Yesod.Message (RenderMessage)
class ToForm a master monad where class ToForm a master monad where
toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) monad a toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a
class ToField a master monad where class ToField a master monad where
toField :: FieldSettings -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) monad a toField :: RenderMessage master msg => FieldSettings msg -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a
{- FIXME {- FIXME
instance ToFormField String y where instance ToFormField String y where
@ -29,44 +31,44 @@ instance ToFormField (Maybe String) y where
toFormField = maybeStringField toFormField = maybeStringField
-} -}
instance Monad m => ToField Text master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where
toField = areq textField toField = areq textField
instance Monad m => ToField (Maybe Text) master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where
toField = aopt textField toField = aopt textField
instance Monad m => ToField Int master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where
toField = areq intField toField = areq intField
instance Monad m => ToField (Maybe Int) master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where
toField = aopt intField toField = aopt intField
instance Monad m => ToField Int64 master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where
toField = areq intField toField = areq intField
instance Monad m => ToField (Maybe Int64) master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where
toField = aopt intField toField = aopt intField
instance Monad m => ToField Double master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where
toField = areq doubleField toField = areq doubleField
instance Monad m => ToField (Maybe Double) master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where
toField = aopt doubleField toField = aopt doubleField
instance Monad m => ToField Day master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where
toField = areq dayField toField = areq dayField
instance Monad m => ToField (Maybe Day) master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where
toField = aopt dayField toField = aopt dayField
instance Monad m => ToField TimeOfDay master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where
toField = areq timeField toField = areq timeField
instance Monad m => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where
toField = aopt timeField toField = aopt timeField
instance Monad m => ToField Html master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where
toField = areq htmlField toField = areq htmlField
instance Monad m => ToField (Maybe Html) master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where
toField = aopt htmlField toField = aopt htmlField
instance Monad m => ToField Textarea master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where
toField = areq textareaField toField = areq textareaField
instance Monad m => ToField (Maybe Textarea) master (GGHandler sub master m) where instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where
toField = aopt textareaField toField = aopt textareaField
{- FIXME {- FIXME

102
Yesod/Form/Fields.hs
View File

@ -3,7 +3,9 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Yesod.Form.Fields module Yesod.Form.Fields
( textField ( FormMessage (..)
, defaultFormMessage
, textField
, passwordField , passwordField
, textareaField , textareaField
, hiddenField , hiddenField
@ -13,6 +15,7 @@ module Yesod.Form.Fields
, htmlField , htmlField
, emailField , emailField
, searchField , searchField
, selectField
, AutoFocus , AutoFocus
, urlField , urlField
, doubleField , doubleField
@ -41,6 +44,8 @@ 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) import Data.Text (Text, unpack, pack)
import qualified Data.Text.Read
import Data.Monoid (mappend)
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
#define WHAMLET whamlet #define WHAMLET whamlet
@ -54,9 +59,32 @@ import Data.Text (Text, unpack, pack)
#define JULIUS $julius #define JULIUS $julius
#endif #endif
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) i data FormMessage = MsgInvalidInteger Text
| MsgInvalidNumber Text
| MsgInvalidEntry Text
| MsgInvalidUrl Text
| MsgInvalidEmail Text
| MsgInvalidTimeFormat
| MsgInvalidHour Text
| MsgInvalidMinute Text
| MsgInvalidSecond Text
| MsgInvalidDay
defaultFormMessage :: FormMessage -> Text
defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
defaultFormMessage (MsgInvalidNumber t) = "Invalid number: " `mappend` t
defaultFormMessage (MsgInvalidEntry t) = "Invalid entry: " `mappend` t
defaultFormMessage MsgInvalidTimeFormat = "Invalid time, must be in HH:MM[:SS] format"
defaultFormMessage MsgInvalidDay = "Invalid day, must be in YYYY-MM-DD format"
defaultFormMessage (MsgInvalidUrl t) = "Invalid URL: " `mappend` t
defaultFormMessage (MsgInvalidEmail t) = "Invalid e-mail address: " `mappend` t
defaultFormMessage (MsgInvalidHour t) = "Invalid hour: " `mappend` t
defaultFormMessage (MsgInvalidMinute t) = "Invalid minute: " `mappend` t
defaultFormMessage (MsgInvalidSecond t) = "Invalid second: " `mappend` t
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
intField = Field intField = Field
{ fieldParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read { fieldParse = \s -> maybe (Left $ MsgInvalidInteger s) Right . readMayI $ unpack s -- FIXME Data.Text.Read
, fieldRender = pack . showI , fieldRender = pack . showI
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
@ -69,9 +97,9 @@ intField = Field
(x, _):_ -> Just $ fromInteger x (x, _):_ -> Just $ fromInteger x
[] -> Nothing [] -> Nothing
doubleField :: Monad monad => Field (GGWidget master monad ()) Double doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
doubleField = Field doubleField = Field
{ fieldParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read { fieldParse = \s -> maybe (Left $ MsgInvalidNumber s) Right . readMay $ unpack s -- FIXME use Data.Text.Read
, fieldRender = pack . show , fieldRender = pack . show
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
@ -79,7 +107,7 @@ doubleField = Field
|] |]
} }
dayField :: Monad monad => Field (GGWidget master monad ()) Day dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
dayField = Field dayField = Field
{ fieldParse = parseDate . unpack { fieldParse = parseDate . unpack
, fieldRender = pack . show , fieldRender = pack . show
@ -89,7 +117,7 @@ dayField = Field
|] |]
} }
timeField :: Monad monad => Field (GGWidget master monad ()) TimeOfDay timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
timeField = Field timeField = Field
{ fieldParse = parseTime . unpack { fieldParse = parseTime . unpack
, fieldRender = pack . show . roundFullSeconds , fieldRender = pack . show . roundFullSeconds
@ -104,7 +132,7 @@ timeField = Field
where where
fullSec = fromInteger $ floor $ todSec tod fullSec = fromInteger $ floor $ todSec tod
htmlField :: Monad monad => Field (GGWidget master monad ()) Html htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
htmlField = Field htmlField = Field
{ fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize { fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
, fieldRender = pack . renderHtml , fieldRender = pack . renderHtml
@ -132,7 +160,7 @@ instance ToHtml Textarea where
writeHtmlEscapedChar '\n' = writeByteString "<br>" writeHtmlEscapedChar '\n' = writeByteString "<br>"
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
textareaField :: Monad monad => Field (GGWidget master monad ()) Textarea textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
textareaField = Field textareaField = Field
{ fieldParse = Right . Textarea { fieldParse = Right . Textarea
, fieldRender = unTextarea , fieldRender = unTextarea
@ -142,7 +170,7 @@ textareaField = Field
|] |]
} }
hiddenField :: Monad monad => Field (GGWidget master monad ()) Text hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
hiddenField = Field hiddenField = Field
{ fieldParse = Right { fieldParse = Right
, fieldRender = id , fieldRender = id
@ -152,7 +180,7 @@ hiddenField = Field
|] |]
} }
textField :: Monad monad => Field (GGWidget master monad ()) Text textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
textField = Field textField = Field
{ fieldParse = Right { fieldParse = Right
, fieldRender = id , fieldRender = id
@ -162,7 +190,7 @@ textField = Field
|] |]
} }
passwordField :: Monad monad => Field (GGWidget master monad ()) Text passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
passwordField = Field passwordField = Field
{ fieldParse = Right { fieldParse = Right
, fieldRender = id , fieldRender = id
@ -177,8 +205,8 @@ readMay s = case reads s of
(x, _):_ -> Just x (x, _):_ -> Just x
[] -> Nothing [] -> Nothing
parseDate :: String -> Either Text Day parseDate :: String -> Either FormMessage Day
parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right parseDate = maybe (Left MsgInvalidDay) Right
. readMay . replace '/' '-' . readMay . replace '/' '-'
-- | Replaces all instances of a value in a list by another value. -- | Replaces all instances of a value in a list by another value.
@ -186,7 +214,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 Text TimeOfDay parseTime :: String -> Either FormMessage 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':[]) =
@ -196,25 +224,25 @@ parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =
in parseTimeHelper (h1', h2', m1, m2, '0', '0') in parseTimeHelper (h1', h2', m1, m2, '0', '0')
parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
parseTimeHelper (h1, h2, m1, m2, s1, s2) parseTimeHelper (h1, h2, m1, m2, s1, s2)
parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" parseTime _ = Left MsgInvalidTimeFormat
parseTimeHelper :: (Char, Char, Char, Char, Char, Char) parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
-> Either Text TimeOfDay -> Either FormMessage TimeOfDay
parseTimeHelper (h1, h2, m1, m2, s1, s2) parseTimeHelper (h1, h2, m1, m2, s1, s2)
| h < 0 || h > 23 = Left $ pack $ "Invalid hour: " ++ show h | h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]
| m < 0 || m > 59 = Left $ pack $ "Invalid minute: " ++ show m | m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]
| s < 0 || s > 59 = Left $ pack $ "Invalid second: " ++ show s | s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]
| otherwise = Right $ TimeOfDay h m s | otherwise = Right $ TimeOfDay h m s
where where
h = read [h1, h2] h = read [h1, h2] -- FIXME isn't this a really bad idea?
m = read [m1, m2] m = read [m1, m2]
s = fromInteger $ read [s1, s2] s = fromInteger $ read [s1, s2]
emailField :: Monad monad => Field (GGWidget master monad ()) Text emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
emailField = Field emailField = Field
{ fieldParse = \s -> if Email.isValid (unpack s) { fieldParse = \s -> if Email.isValid (unpack s)
then Right s then Right s
else Left "Invalid e-mail address" else Left $ MsgInvalidEmail s
, fieldRender = id , fieldRender = id
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
[HAMLET|\ [HAMLET|\
@ -223,7 +251,7 @@ emailField = Field
} }
type AutoFocus = Bool type AutoFocus = Bool
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) Text searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
searchField autoFocus = Field searchField autoFocus = Field
{ fieldParse = Right { fieldParse = Right
, fieldRender = id , fieldRender = id
@ -240,10 +268,10 @@ searchField autoFocus = Field
|] |]
} }
urlField :: Monad monad => Field (GGWidget master monad ()) Text urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
urlField = Field urlField = Field
{ fieldParse = \s -> case parseURI $ unpack s of { fieldParse = \s -> case parseURI $ unpack s of
Nothing -> Left "Invalid URL" Nothing -> Left $ MsgInvalidUrl s
Just _ -> Right s Just _ -> Right s
, fieldRender = id , fieldRender = id
, fieldView = \theId name val isReq -> addHtml , fieldView = \theId name val isReq -> addHtml
@ -251,3 +279,25 @@ urlField = Field
<input ##{theId} name=#{name} type=url :isReq:required value=#{val}> <input ##{theId} name=#{name} type=url :isReq:required value=#{val}>
|] |]
} }
selectField :: (Eq a, Monad monad) => [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
selectField opts = Field -- FIXME won't work for optional yet
{ fieldParse = \s ->
case Data.Text.Read.decimal s of
Right (a, "") ->
case lookup a pairs of
Nothing -> Left $ MsgInvalidEntry s
Just x -> Right $ snd x
_ -> Left $ MsgInvalidNumber s
, fieldRender = \a -> maybe "" (pack . show) $ lookup a rpairs
, fieldView = \theId name val isReq -> [WHAMLET|
<select id=#{theId} name=#{name}
$if not isReq
<option value=none>
$forall pair <- pairs
<option value=#{show $ fst pair} :(==) val (fst $ snd pair):selected>#{fst $ snd pair}
|]
}
where
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
rpairs = zip (map snd opts) [1 :: Int ..]

99
Yesod/Form/Functions.hs
View File

@ -31,13 +31,15 @@ import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM, join) import Control.Monad (liftM, join)
import Text.Blaze (Html, toHtml) import Text.Blaze (Html, toHtml)
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent) import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)
import Yesod.Core (RenderMessage)
import Yesod.Widget (GGWidget, whamlet) import Yesod.Widget (GGWidget, whamlet)
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams) import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
import Network.Wai (requestMethod) import Network.Wai (requestMethod)
import Text.Hamlet.NonPoly (html) import Text.Hamlet.NonPoly (html)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Yesod.Message (RenderMessage (..))
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
#define WHAMLET whamlet #define WHAMLET whamlet
@ -48,7 +50,7 @@ import Data.Maybe (fromMaybe)
#endif #endif
-- | Get a unique identifier. -- | Get a unique identifier.
newFormIdent :: Monad m => Form m Text newFormIdent :: Monad m => Form msg m Text
newFormIdent = do newFormIdent = do
i <- get i <- get
let i' = incrInts i let i' = incrInts i
@ -58,56 +60,65 @@ newFormIdent = do
incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is incrInts (IntCons i is) = (i + 1) `IntCons` is
formToAForm :: Monad m => Form m (FormResult a, xml) -> AForm ([xml] -> [xml]) m a formToAForm :: Monad m => Form msg m (FormResult a, xml) -> AForm ([xml] -> [xml]) msg m a
formToAForm form = AForm $ \env ints -> do formToAForm form = AForm $ \(master, langs) env ints -> do
((a, xml), ints', enc) <- runRWST form env ints ((a, xml), ints', enc) <- runRWST form (env, master, langs) ints
return (a, (:) xml, ints', enc) return (a, (:) xml, ints', enc)
aFormToForm :: Monad m => AForm xml m a -> Form m (FormResult a, xml) aFormToForm :: Monad m => AForm xml msg m a -> Form msg m (FormResult a, xml)
aFormToForm (AForm aform) = do aFormToForm (AForm aform) = do
ints <- get ints <- get
env <- ask (env, master, langs) <- ask
(a, xml, ints', enc) <- lift $ aform env ints (a, xml, ints', enc) <- lift $ aform (master, langs) env ints
put ints' put ints'
tell enc tell enc
return (a, xml) return (a, xml)
askParams :: Monad m => Form m (Maybe Env) askParams :: Monad m => Form msg m (Maybe Env)
askParams = liftM (liftM fst) ask askParams = do
(x, _, _) <- ask
return $ liftM fst x
askFiles :: Monad m => Form m (Maybe FileEnv) askFiles :: Monad m => Form msg m (Maybe FileEnv)
askFiles = liftM (liftM snd) ask askFiles = do
(x, _, _) <- ask
return $ liftM snd x
mreq :: Monad m => Field xml a -> FieldSettings -> Maybe a mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
-> Form (GGHandler sub master m) (FormResult a, FieldView xml) => Field xml msg a -> FieldSettings msg2 -> Maybe a
-> Form master (GGHandler sub master m) (FormResult a, FieldView xml)
mreq field fs mdef = mhelper field fs mdef (FormFailure ["Value is required"]) FormSuccess True -- TRANS mreq field fs mdef = mhelper field fs mdef (FormFailure ["Value is required"]) FormSuccess True -- TRANS
mopt :: Monad m => Field xml a -> FieldSettings -> Maybe (Maybe a) mopt :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
-> Form (GGHandler sub master m) (FormResult (Maybe a), FieldView xml) => Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)
-> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)
mopt field fs mdef = mhelper field fs (join mdef) (FormSuccess Nothing) (FormSuccess . Just) False mopt field fs mdef = mhelper field fs (join mdef) (FormSuccess Nothing) (FormSuccess . Just) False
mhelper :: Monad m mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
=> Field xml a => Field xml msg a
-> FieldSettings -> FieldSettings msg2
-> Maybe a -> Maybe a
-> FormResult b -- ^ on missing -> FormResult b -- ^ on missing
-> (a -> FormResult b) -- ^ on success -> (a -> FormResult b) -- ^ on success
-> Bool -- ^ is it required? -> Bool -- ^ is it required?
-> Form (GGHandler sub master m) (FormResult b, FieldView xml) -> Form master (GGHandler sub master m) (FormResult b, FieldView xml)
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
mp <- askParams mp <- askParams
name <- maybe newFormIdent return fsName name <- maybe newFormIdent return fsName
theId <- lift $ maybe (liftM pack newIdent) return fsId theId <- lift $ maybe (liftM pack newIdent) return fsId
(_, master, langs) <- ask
let mr = renderMessage master langs
let mr2 = renderMessage master langs
let (res, val) = let (res, val) =
case mp of case mp of
Nothing -> (FormMissing, maybe "" fieldRender mdef) Nothing -> (FormMissing, maybe "" fieldRender mdef)
Just p -> Just p ->
case fromMaybe "" $ lookup name p of case fromMaybe "" $ lookup name p of
"" -> (onMissing, "") -- TRANS "" -> (onMissing, "") -- TRANS
x -> (either (FormFailure . return) onFound $ fieldParse x, x) x -> (either (FormFailure . return . mr) onFound $ fieldParse x, x)
return (res, FieldView return (res, FieldView
{ fvLabel = fsLabel { fvLabel = toHtml $ mr2 fsLabel
, fvTooltip = fsTooltip , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
, fvId = theId , fvId = theId
, fvInput = fieldView theId name val isReq , fvInput = fieldView theId name val isReq
, fvErrors = , fvErrors =
@ -117,18 +128,20 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
, fvRequired = isReq , fvRequired = isReq
}) })
areq :: Monad m => Field xml a -> FieldSettings -> Maybe a areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
-> AForm ([FieldView xml] -> [FieldView xml]) (GGHandler sub master m) a => Field xml msg1 a -> FieldSettings msg2 -> Maybe a
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a
areq a b = formToAForm . mreq a b areq a b = formToAForm . mreq a b
aopt :: Monad m => Field xml a -> FieldSettings -> Maybe (Maybe a) aopt :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
-> AForm ([FieldView xml] -> [FieldView xml]) (GGHandler sub master m) (Maybe a) => Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a)
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a)
aopt a b = formToAForm . mopt a b aopt a b = formToAForm . mopt a b
runFormGeneric :: Monad m => Form m a -> Maybe (Env, FileEnv) -> m (a, Enctype) runFormGeneric :: Monad m => Form master m a -> master -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype)
runFormGeneric form env = evalRWST form env (IntSingle 1) runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)
runFormPost :: (Html -> Form (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) runFormPost :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
runFormPost form = do runFormPost form = do
req <- getRequest req <- getRequest
let nonceKey = "_nonce" let nonceKey = "_nonce"
@ -139,7 +152,9 @@ runFormPost form = do
env <- if requestMethod (reqWaiRequest req) == "GET" env <- if requestMethod (reqWaiRequest req) == "GET"
then return Nothing then return Nothing
else fmap Just runRequestBody else fmap Just runRequestBody
((res, xml), enctype) <- runFormGeneric (form nonce) env m <- getYesod
langs <- languages
((res, xml), enctype) <- runFormGeneric (form nonce) m langs env
let res' = let res' =
case (res, env) of case (res, env) of
(FormSuccess{}, Just (params, _)) (FormSuccess{}, Just (params, _))
@ -151,15 +166,17 @@ runFormPost form = do
csrfWarning :: Text csrfWarning :: Text
csrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission." -- TRANS csrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission." -- TRANS
runFormPostNoNonce :: (Html -> Form (GHandler sub master) a) -> GHandler sub master (a, Enctype) runFormPostNoNonce :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
runFormPostNoNonce form = do runFormPostNoNonce form = do
req <- getRequest req <- getRequest
env <- if requestMethod (reqWaiRequest req) == "GET" env <- if requestMethod (reqWaiRequest req) == "GET"
then return Nothing then return Nothing
else fmap Just runRequestBody else fmap Just runRequestBody
runFormGeneric (form mempty) env langs <- languages
m <- getYesod
runFormGeneric (form mempty) m langs env
runFormGet :: Monad m => (Html -> Form (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype) runFormGet :: Monad m => (Html -> Form master (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype)
runFormGet form = do runFormGet form = do
let key = "_hasdata" let key = "_hasdata"
let fragment = [HTML|<input type=hidden name=#{key}>|] let fragment = [HTML|<input type=hidden name=#{key}>|]
@ -168,14 +185,16 @@ runFormGet form = do
case lookup key gets of case lookup key gets of
Nothing -> Nothing Nothing -> Nothing
Just _ -> Just (gets, []) Just _ -> Just (gets, [])
runFormGeneric (form fragment) env langs <- languages
m <- getYesod
runFormGeneric (form fragment) m langs env
type FormRender master m a = type FormRender master msg m a =
AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) m a AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) msg m a
-> Html -> Html
-> Form m (FormResult a, GGWidget master m ()) -> Form msg m (FormResult a, GGWidget master m ())
renderTable, renderDivs :: Monad m => FormRender master m a renderTable, renderDivs :: Monad m => FormRender master msg m a
renderTable aform fragment = do renderTable aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []

43
Yesod/Form/Input.hs
View File

@ -10,47 +10,52 @@ module Yesod.Form.Input
import Yesod.Form.Types import Yesod.Form.Types
import Data.Text (Text, append) import Data.Text (Text, append)
import Control.Applicative (Applicative (..)) import Control.Applicative (Applicative (..))
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest) import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod)
import Yesod.Request (reqGetParams) import Yesod.Request (reqGetParams, languages)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Control.Monad (liftM) import Control.Monad (liftM)
import Yesod.Widget (GWidget) import Yesod.Widget (GWidget)
import Yesod.Message (RenderMessage (..))
type DText = [Text] -> [Text] type DText = [Text] -> [Text]
newtype FormInput a = FormInput { unFormInput :: Env -> Either DText a } newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> Either DText a }
instance Functor FormInput where instance Functor (FormInput master) where
fmap a (FormInput f) = FormInput $ \e -> either Left (Right . a) $ f e fmap a (FormInput f) = FormInput $ \c d e -> either Left (Right . a) $ f c d e
instance Applicative FormInput where instance Applicative (FormInput master) where
pure = FormInput . const . Right pure = FormInput . const . const . const . Right
(FormInput f) <*> (FormInput x) = FormInput $ \e -> (FormInput f) <*> (FormInput x) = FormInput $ \c d e ->
case (f e, x e) of case (f c d e, x c d e) of
(Left a, Left b) -> Left $ a . b (Left a, Left b) -> Left $ a . b
(Left a, _) -> Left a (Left a, _) -> Left a
(_, Left b) -> Left b (_, Left b) -> Left b
(Right a, Right b) -> Right $ a b (Right a, Right b) -> Right $ a b
ireq :: Field (GWidget sub master ()) a -> Text -> FormInput a ireq :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
ireq field name = FormInput $ \env -> ireq field name = FormInput $ \m l env ->
case lookup name env of case lookup name env of
Nothing -> Left $ (:) $ append "Input not found: " name -- TRANS Nothing -> Left $ (:) $ append "Input not found: " name -- TRANS
Just x -> either (Left . (:)) Right $ fieldParse field x Just x -> either (Left . (:) . renderMessage m l) Right $ fieldParse field x
iopt :: Field (GWidget sub master ()) a -> Text -> FormInput (Maybe a) iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)
iopt field name = FormInput $ \env -> iopt field name = FormInput $ \m l env ->
case fromMaybe "" $ lookup name env of case fromMaybe "" $ lookup name env of
"" -> Right Nothing "" -> Right Nothing
x -> either (Left . (:)) (Right . Just) $ fieldParse field x x -> either (Left . (:) . renderMessage m l) (Right . Just) $ fieldParse field x
runInputGet :: Monad monad => FormInput a -> GGHandler sub master monad a runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a
runInputGet (FormInput f) = do runInputGet (FormInput f) = do
env <- liftM reqGetParams getRequest env <- liftM reqGetParams getRequest
case f env of m <- getYesod
l <- languages
case f m l env of
Left errs -> invalidArgs $ errs [] Left errs -> invalidArgs $ errs []
Right x -> return x Right x -> return x
runInputPost :: FormInput a -> GHandler sub master a runInputPost :: FormInput master a -> GHandler sub master a
runInputPost (FormInput f) = do runInputPost (FormInput f) = do
env <- liftM fst runRequestBody env <- liftM fst runRequestBody
case f env of m <- getYesod
l <- languages
case f m l env of
Left errs -> invalidArgs $ errs [] Left errs -> invalidArgs $ errs []
Right x -> return x Right x -> return x

10
Yesod/Form/Jquery.hs
View File

@ -63,10 +63,10 @@ class YesodJquery a where
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text 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 :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) Day jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
jqueryDayField jds = Field jqueryDayField jds = Field
{ fieldParse = maybe { fieldParse = maybe
(Left "Invalid day, must be in YYYY-MM-DD format") (Left MsgInvalidDay)
Right Right
. readMay . readMay
. unpack . unpack
@ -118,7 +118,7 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")
in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) UTCTime jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime
jqueryDayTimeField = Field jqueryDayTimeField = Field
{ fieldParse = parseUTCTime . unpack { fieldParse = parseUTCTime . unpack
, fieldRender = pack . jqueryDayTimeUTCTime , fieldRender = pack . jqueryDayTimeUTCTime
@ -135,7 +135,7 @@ $(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}
|] |]
} }
parseUTCTime :: String -> Either Text UTCTime parseUTCTime :: String -> Either FormMessage 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
@ -145,7 +145,7 @@ parseUTCTime s =
ifRight (parseTime timeS) ifRight (parseTime timeS)
(UTCTime date . timeOfDayToTime) (UTCTime date . timeOfDayToTime)
jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) Text jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text
jqueryAutocompleteField src = Field jqueryAutocompleteField src = Field
{ fieldParse = Right { fieldParse = Right
, fieldRender = id , fieldRender = id

2
Yesod/Form/Nic.hs
View File

@ -26,7 +26,7 @@ class YesodNic a where
urlNicEdit :: a -> Either (Route a) Text 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 :: YesodNic master => Field (GWidget sub master ()) Html nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
nicHtmlField = Field nicHtmlField = Field
{ fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME { fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
, fieldRender = pack . renderHtml , fieldRender = pack . renderHtml

38
Yesod/Form/Types.hs
View File

@ -69,38 +69,38 @@ instance Show Ints where
type Env = [(Text, Text)] -- FIXME use a Map type Env = [(Text, Text)] -- FIXME use a Map
type FileEnv = [(Text, FileInfo)] type FileEnv = [(Text, FileInfo)]
type Form m a = RWST (Maybe (Env, FileEnv)) Enctype Ints m a type Form master m a = RWST (Maybe (Env, FileEnv), master, [Text]) Enctype Ints m a
newtype AForm xml m a = AForm newtype AForm xml master m a = AForm
{ unAForm :: Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype) { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)
} }
instance Monad m => Functor (AForm xml m) where instance Monad m => Functor (AForm xml msg m) where
fmap f (AForm a) = fmap f (AForm a) =
AForm $ \x y -> liftM go $ a x y AForm $ \x y z -> liftM go $ a x y z
where where
go (w, x, y, z) = (fmap f w, x, y, z) go (w, x, y, z) = (fmap f w, x, y, z)
instance (Monad m, Monoid xml) => Applicative (AForm xml m) where instance (Monad m, Monoid xml) => Applicative (AForm xml msg m) where
pure x = AForm $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty) pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
(AForm f) <*> (AForm g) = AForm $ \env ints -> do (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
(a, b, ints', c) <- f env ints (a, b, ints', c) <- f mr env ints
(x, y, ints'', z) <- g env ints' (x, y, ints'', z) <- g mr env ints'
return (a <*> x, b `mappend` y, ints'', c `mappend` z) return (a <*> x, b `mappend` y, ints'', c `mappend` z)
instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml m a) where instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml msg m a) where
mempty = pure mempty mempty = pure mempty
mappend a b = mappend <$> a <*> b mappend a b = mappend <$> a <*> b
instance Monoid xml => MonadTrans (AForm xml) where instance Monoid xml => MonadTrans (AForm xml msg) where
lift mx = AForm $ const $ \ints -> do lift mx = AForm $ const $ const $ \ints -> do
x <- mx x <- mx
return (pure x, mempty, ints, mempty) return (pure x, mempty, ints, mempty)
data FieldSettings = FieldSettings data FieldSettings msg = FieldSettings
{ fsLabel :: Html -- FIXME do we need Text? { fsLabel :: msg
, fsTooltip :: Maybe Html , fsTooltip :: Maybe msg
, fsId :: Maybe Text , fsId :: Maybe Text
, fsName :: Maybe Text , fsName :: Maybe Text
} }
instance IsString FieldSettings where instance IsString a => IsString (FieldSettings a) where
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing fromString s = FieldSettings (fromString s) Nothing Nothing Nothing
data FieldView xml = FieldView data FieldView xml = FieldView
@ -112,8 +112,8 @@ data FieldView xml = FieldView
, fvRequired :: Bool , fvRequired :: Bool
} }
data Field xml a = Field data Field xml msg a = Field
{ fieldParse :: Text -> Either Text a -- FIXME probably want to make this more sophisticated, handle no form, no field { fieldParse :: Text -> Either msg a -- FIXME probably want to make this more sophisticated, handle no form, no field
, fieldRender :: a -> Text , fieldRender :: a -> Text
, fieldView :: Text -- ^ ID , fieldView :: Text -- ^ ID
-> Text -- ^ name -> Text -- ^ name

2
yesod-form.cabal
View File

@ -13,7 +13,7 @@ homepage: http://www.yesodweb.com/
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.8.1 && < 0.9 , yesod-core >= 0.8.2 && < 0.9
, time >= 1.1.4 && < 1.3 , time >= 1.1.4 && < 1.3
, hamlet >= 0.8.1 && < 0.9 , hamlet >= 0.8.1 && < 0.9
, persistent >= 0.5 && < 0.6 , persistent >= 0.5 && < 0.6