6f5459f70f
git-subtree-dir: yesod-form git-subtree-mainline:41faf62094git-subtree-split:53b7c3b810
422 lines
16 KiB
Haskell
422 lines
16 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Yesod.Form.Fields
|
|
( FormMessage (..)
|
|
, defaultFormMessage
|
|
, textField
|
|
, passwordField
|
|
, textareaField
|
|
, hiddenField
|
|
, intField
|
|
, dayField
|
|
, timeField
|
|
, htmlField
|
|
, emailField
|
|
, searchField
|
|
, selectField
|
|
, multiSelectField
|
|
, AutoFocus
|
|
, urlField
|
|
, doubleField
|
|
, parseDate
|
|
, parseTime
|
|
, Textarea (..)
|
|
, radioField
|
|
, boolField
|
|
) where
|
|
|
|
import Yesod.Form.Types
|
|
import Yesod.Widget
|
|
import Yesod.Message (RenderMessage)
|
|
import Yesod.Handler (GGHandler)
|
|
import Text.Hamlet
|
|
import Text.Blaze (ToHtml (..), preEscapedString, unsafeByteString)
|
|
import Text.Cassius
|
|
import Data.Time (Day, TimeOfDay(..))
|
|
import qualified Text.Email.Validate as Email
|
|
import Network.URI (parseURI)
|
|
import Database.Persist (PersistField)
|
|
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
|
import Control.Monad (when, unless)
|
|
import Data.List (intersect, nub)
|
|
import Data.Either (rights)
|
|
import Data.Maybe (catMaybes)
|
|
|
|
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
|
|
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
|
|
import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
|
|
|
|
import Text.Blaze.Renderer.String (renderHtml)
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Lazy as L
|
|
import Data.Text (Text, unpack, pack)
|
|
import qualified Data.Text.Read
|
|
import Data.Monoid (mappend)
|
|
import Text.Hamlet (html)
|
|
|
|
#if __GLASGOW_HASKELL__ >= 700
|
|
#define WHAMLET whamlet
|
|
#define HAMLET hamlet
|
|
#define CASSIUS cassius
|
|
#define JULIUS julius
|
|
#define HTML html
|
|
#else
|
|
#define WHAMLET $whamlet
|
|
#define HAMLET $hamlet
|
|
#define CASSIUS $cassius
|
|
#define JULIUS $julius
|
|
#define HTML $html
|
|
#endif
|
|
|
|
data FormMessage = MsgInvalidInteger Text
|
|
| MsgInvalidNumber Text
|
|
| MsgInvalidEntry Text
|
|
| MsgInvalidUrl Text
|
|
| MsgInvalidEmail Text
|
|
| MsgInvalidTimeFormat
|
|
| MsgInvalidHour Text
|
|
| MsgInvalidMinute Text
|
|
| MsgInvalidSecond Text
|
|
| MsgInvalidDay
|
|
| MsgCsrfWarning
|
|
| MsgValueRequired
|
|
| MsgInputNotFound Text
|
|
| MsgSelectNone
|
|
| MsgInvalidBool Text
|
|
| MsgBoolYes
|
|
| MsgBoolNo
|
|
|
|
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
|
|
defaultFormMessage MsgCsrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission."
|
|
defaultFormMessage MsgValueRequired = "Value is required"
|
|
defaultFormMessage (MsgInputNotFound t) = "Input not found: " `mappend` t
|
|
defaultFormMessage MsgSelectNone = "<None>"
|
|
defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
|
|
defaultFormMessage MsgBoolYes = "Yes"
|
|
defaultFormMessage MsgBoolNo = "No"
|
|
|
|
blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
|
|
blank _ [] = Right Nothing
|
|
blank _ ("":_) = Right Nothing
|
|
blank f (x:_) = either Left (Right . Just) $ f x
|
|
|
|
|
|
|
|
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
|
|
intField = Field
|
|
{ fieldParse = blank $ \s ->
|
|
case Data.Text.Read.signed Data.Text.Read.decimal s of
|
|
Right (a, "") -> Right a
|
|
_ -> Left $ MsgInvalidInteger s
|
|
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}">
|
|
|]
|
|
}
|
|
where
|
|
showVal = either id (pack . showI)
|
|
showI x = show (fromIntegral x :: Integer)
|
|
|
|
doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
|
|
doubleField = Field
|
|
{ fieldParse = blank $ \s ->
|
|
case Data.Text.Read.double s of
|
|
Right (a, "") -> Right a
|
|
_ -> Left $ MsgInvalidNumber s
|
|
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}">
|
|
|]
|
|
}
|
|
where showVal = either id (pack . show)
|
|
|
|
dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
|
|
dayField = Field
|
|
{ fieldParse = blank $ parseDate . unpack
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
|
|
|]
|
|
}
|
|
where showVal = either id (pack . show)
|
|
|
|
timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
|
|
timeField = Field
|
|
{ fieldParse = blank $ parseTime . unpack
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
|
|
|]
|
|
}
|
|
where
|
|
showVal = either id (pack . show . roundFullSeconds)
|
|
roundFullSeconds tod =
|
|
TimeOfDay (todHour tod) (todMin tod) fullSec
|
|
where
|
|
fullSec = fromInteger $ floor $ todSec tod
|
|
|
|
htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
|
|
htmlField = Field
|
|
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
|
|
, fieldView = \theId name val _isReq -> addHamlet
|
|
[HAMLET|\
|
|
<textarea id="#{theId}" name="#{name}" .html>#{showVal val}
|
|
|]
|
|
}
|
|
where showVal = either id (pack . renderHtml)
|
|
|
|
-- | A newtype wrapper around a 'String' that converts newlines to HTML
|
|
-- br-tags.
|
|
newtype Textarea = Textarea { unTextarea :: Text }
|
|
deriving (Show, Read, Eq, PersistField)
|
|
instance ToHtml Textarea where
|
|
toHtml =
|
|
unsafeByteString
|
|
. S.concat
|
|
. L.toChunks
|
|
. toLazyByteString
|
|
. fromWriteList writeHtmlEscapedChar
|
|
. unpack
|
|
. unTextarea
|
|
where
|
|
-- Taken from blaze-builder and modified with newline handling.
|
|
writeHtmlEscapedChar '\n' = writeByteString "<br>"
|
|
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
|
|
|
|
textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
|
|
textareaField = Field
|
|
{ fieldParse = blank $ Right . Textarea
|
|
, fieldView = \theId name val _isReq -> addHamlet
|
|
[HAMLET|\
|
|
<textarea id="#{theId}" name="#{name}">#{either id unTextarea val}
|
|
|]
|
|
}
|
|
|
|
hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
|
hiddenField = Field
|
|
{ fieldParse = blank $ Right
|
|
, fieldView = \theId name val _isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}">
|
|
|]
|
|
}
|
|
|
|
textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
|
textField = Field
|
|
{ fieldParse = blank $ Right
|
|
, fieldView = \theId name val isReq ->
|
|
[WHAMLET|
|
|
<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}">
|
|
|]
|
|
}
|
|
|
|
passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
|
passwordField = Field
|
|
{ fieldParse = blank $ Right
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}">
|
|
|]
|
|
}
|
|
|
|
readMay :: Read a => String -> Maybe a
|
|
readMay s = case reads s of
|
|
(x, _):_ -> Just x
|
|
[] -> Nothing
|
|
|
|
parseDate :: String -> Either FormMessage Day
|
|
parseDate = maybe (Left MsgInvalidDay) Right
|
|
. readMay . replace '/' '-'
|
|
|
|
-- | Replaces all instances of a value in a list by another value.
|
|
-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
|
|
replace :: Eq a => a -> a -> [a] -> [a]
|
|
replace x y = map (\z -> if z == x then y else z)
|
|
|
|
parseTime :: String -> Either FormMessage TimeOfDay
|
|
parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
|
|
parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
|
|
parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =
|
|
parseTimeHelper (h1, h2, m1, m2, '0', '0')
|
|
parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =
|
|
let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12
|
|
in parseTimeHelper (h1', h2', m1, m2, '0', '0')
|
|
parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
|
|
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
|
parseTime _ = Left MsgInvalidTimeFormat
|
|
|
|
parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
|
|
-> Either FormMessage TimeOfDay
|
|
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
|
| h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]
|
|
| m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]
|
|
| s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]
|
|
| otherwise = Right $ TimeOfDay h m s
|
|
where
|
|
h = read [h1, h2] -- FIXME isn't this a really bad idea?
|
|
m = read [m1, m2]
|
|
s = fromInteger $ read [s1, s2]
|
|
|
|
emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
|
emailField = Field
|
|
{ fieldParse = blank $
|
|
\s -> if Email.isValid (unpack s)
|
|
then Right s
|
|
else Left $ MsgInvalidEmail s
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}">
|
|
|]
|
|
}
|
|
|
|
type AutoFocus = Bool
|
|
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
|
|
searchField autoFocus = Field
|
|
{ fieldParse = blank Right
|
|
, fieldView = \theId name val isReq -> do
|
|
[WHAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|
|
|]
|
|
when autoFocus $ do
|
|
[WHAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script>
|
|
|]
|
|
addCassius [CASSIUS|
|
|
#{theId}
|
|
-webkit-appearance: textfield
|
|
|]
|
|
}
|
|
|
|
urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
|
urlField = Field
|
|
{ fieldParse = blank $ \s ->
|
|
case parseURI $ unpack s of
|
|
Nothing -> Left $ MsgInvalidUrl s
|
|
Just _ -> Right s
|
|
, fieldView = \theId name val isReq ->
|
|
[WHAMLET|
|
|
<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}>
|
|
|]
|
|
}
|
|
|
|
selectField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a
|
|
selectField = selectFieldHelper
|
|
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|])
|
|
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])
|
|
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
|
|
|
|
multiSelectField :: (Show a, Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage [a]
|
|
multiSelectField = multiSelectFieldHelper
|
|
(\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])
|
|
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
|
|
|
|
radioField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a
|
|
radioField = selectFieldHelper
|
|
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
|
|
(\theId name isSel -> [WHAMLET|
|
|
<div>
|
|
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
|
|
<label for=#{theId}-none>_{MsgSelectNone}
|
|
|])
|
|
(\theId name value isSel text -> [WHAMLET|
|
|
<div>
|
|
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked>
|
|
<label for=#{theId}-#{value}>#{text}
|
|
|])
|
|
|
|
boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool
|
|
boolField = Field
|
|
{ fieldParse = boolParser
|
|
, fieldView = \theId name val isReq -> [WHAMLET|
|
|
$if not isReq
|
|
<input id=#{theId}-none type=radio name=#{name} value=none checked>
|
|
<label for=#{theId}-none>_{MsgSelectNone}
|
|
|
|
|
|
<input id=#{theId}-yes type=radio name=#{name} value=yes :showVal id val:checked>
|
|
<label for=#{theId}-yes>_{MsgBoolYes}
|
|
|
|
<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked>
|
|
<label for=#{theId}-no>_{MsgBoolNo}
|
|
|]
|
|
}
|
|
where
|
|
boolParser [] = Right Nothing
|
|
boolParser (x:_) = case x of
|
|
"" -> Right Nothing
|
|
"none" -> Right Nothing
|
|
"yes" -> Right $ Just True
|
|
"no" -> Right $ Just False
|
|
t -> Left $ MsgInvalidBool t
|
|
showVal = either (\_ -> False)
|
|
|
|
multiSelectFieldHelper :: (Show a, Eq a, Monad monad)
|
|
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
|
|
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
|
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage [a]
|
|
multiSelectFieldHelper outside inside opts = Field
|
|
{ fieldParse = selectParser
|
|
, fieldView = \theId name vals _ ->
|
|
outside theId name $ do
|
|
flip mapM_ pairs $ \pair -> inside
|
|
theId
|
|
name
|
|
(pack $ show $ fst pair)
|
|
((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values
|
|
(fst $ snd pair)
|
|
}
|
|
where
|
|
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
|
|
rpairs = zip (map snd opts) [1 :: Int ..]
|
|
selectedVals vals = map snd $ filter (\y -> fst y `elem` vals) rpairs
|
|
selectParser [] = Right Nothing
|
|
selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing
|
|
| otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs
|
|
|
|
selectFieldHelper :: (Eq a, Monad monad)
|
|
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
|
|
-> (Text -> Text -> Bool -> GGWidget master monad ())
|
|
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
|
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
|
|
selectFieldHelper outside onOpt inside opts = Field
|
|
{ fieldParse = selectParser
|
|
, fieldView = \theId name val isReq ->
|
|
outside theId name $ do
|
|
unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs
|
|
flip mapM_ pairs $ \pair -> inside
|
|
theId
|
|
name
|
|
(pack $ show $ fst pair)
|
|
((render val) == pack (show $ fst pair))
|
|
(fst $ snd pair)
|
|
}
|
|
where
|
|
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
|
|
rpairs = zip (map snd opts) [1 :: Int ..]
|
|
render (Left _) = ""
|
|
render (Right a) = maybe "" (pack . show) $ lookup a rpairs
|
|
selectParser [] = Right Nothing
|
|
selectParser (s:_) = case s of
|
|
"" -> Right Nothing
|
|
"none" -> Right Nothing
|
|
x -> case Data.Text.Read.decimal x of
|
|
Right (a, "") ->
|
|
case lookup a pairs of
|
|
Nothing -> Left $ MsgInvalidEntry x
|
|
Just y -> Right $ Just $ snd y
|
|
_ -> Left $ MsgInvalidNumber x
|