Beginning of serious refactor
This commit is contained in:
Michael Snoyman
parent
713304e7ef
commit
010cb4863b
@ -1,444 +1,251 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Form.Fields
|
||||
( -- * Fields
|
||||
-- ** Required
|
||||
stringField
|
||||
( textField
|
||||
, passwordField
|
||||
, textareaField
|
||||
, hiddenField
|
||||
, intField
|
||||
, doubleField
|
||||
, dayField
|
||||
, timeField
|
||||
, htmlField
|
||||
, selectField
|
||||
, radioField
|
||||
, boolField
|
||||
, emailField
|
||||
, searchField
|
||||
, AutoFocus
|
||||
, urlField
|
||||
, fileField
|
||||
-- ** Optional
|
||||
, maybeStringField
|
||||
, maybePasswordField
|
||||
, maybeTextareaField
|
||||
, maybeHiddenField
|
||||
, maybeIntField
|
||||
, maybeDoubleField
|
||||
, maybeDayField
|
||||
, maybeTimeField
|
||||
, maybeHtmlField
|
||||
, maybeSelectField
|
||||
, maybeRadioField
|
||||
, maybeEmailField
|
||||
, maybeSearchField
|
||||
, maybeUrlField
|
||||
, maybeFileField
|
||||
{- FIXME
|
||||
-- * Inputs
|
||||
-- ** Required
|
||||
, stringInput
|
||||
, intInput
|
||||
, boolInput
|
||||
, dayInput
|
||||
, emailInput
|
||||
, urlInput
|
||||
-- ** Optional
|
||||
, maybeStringInput
|
||||
, maybeDayInput
|
||||
, maybeIntInput
|
||||
-}
|
||||
, doubleField
|
||||
, parseDate
|
||||
, parseTime
|
||||
, Textarea (..)
|
||||
) where
|
||||
|
||||
import Yesod.Form.Core
|
||||
import Yesod.Form.Profiles
|
||||
import Yesod.Request (FileInfo)
|
||||
import Yesod.Widget (GWidget)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Reader (ask)
|
||||
import Data.Time (Day, TimeOfDay)
|
||||
import Text.Hamlet
|
||||
import Data.Monoid
|
||||
import Control.Monad (join)
|
||||
import Data.Maybe (fromMaybe, isNothing)
|
||||
import Data.Text (Text, unpack)
|
||||
import qualified Data.Text as T
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Widget
|
||||
import Text.Hamlet hiding (renderHtml)
|
||||
import Text.Blaze (ToHtml (..))
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define HAMLET hamlet
|
||||
#define CASSIUS cassius
|
||||
#define JULIUS julius
|
||||
#else
|
||||
#define HAMLET $hamlet
|
||||
#define CASSIUS $cassius
|
||||
#define JULIUS $julius
|
||||
#endif
|
||||
|
||||
stringField = requiredFieldHelper stringFieldProfile
|
||||
|
||||
maybeStringField = optionalFieldHelper stringFieldProfile
|
||||
|
||||
passwordField = requiredFieldHelper passwordFieldProfile
|
||||
|
||||
maybePasswordField = optionalFieldHelper passwordFieldProfile
|
||||
|
||||
{- FIXME
|
||||
intInput n =
|
||||
mapFormXml fieldsToInput $
|
||||
requiredFieldHelper intFieldProfile (nameSettings n) Nothing
|
||||
|
||||
maybeIntInput n =
|
||||
mapFormXml fieldsToInput $
|
||||
optionalFieldHelper intFieldProfile (nameSettings n) Nothing
|
||||
-}
|
||||
|
||||
intField = requiredFieldHelper intFieldProfile
|
||||
|
||||
maybeIntField = optionalFieldHelper intFieldProfile
|
||||
|
||||
doubleField = requiredFieldHelper doubleFieldProfile
|
||||
|
||||
maybeDoubleField = optionalFieldHelper doubleFieldProfile
|
||||
|
||||
dayField = requiredFieldHelper dayFieldProfile
|
||||
|
||||
maybeDayField = optionalFieldHelper dayFieldProfile
|
||||
|
||||
timeField = requiredFieldHelper timeFieldProfile
|
||||
|
||||
maybeTimeField = optionalFieldHelper timeFieldProfile
|
||||
|
||||
boolField ffs orig = do
|
||||
env <- askParams
|
||||
let label = ffsLabel ffs
|
||||
tooltip = ffsTooltip ffs
|
||||
name <- maybe newFormIdent return $ ffsName ffs
|
||||
theId <- maybe newFormIdent return $ ffsId ffs
|
||||
let (res, val) =
|
||||
if null env
|
||||
then (FormMissing, fromMaybe False orig)
|
||||
else case lookup name env of
|
||||
Nothing -> (FormSuccess False, False)
|
||||
Just "" -> (FormSuccess False, False)
|
||||
Just "false" -> (FormSuccess False, False)
|
||||
Just _ -> (FormSuccess True, True)
|
||||
let fi = FieldInfo
|
||||
{ fiLabel = toHtml label
|
||||
, fiTooltip = tooltip
|
||||
, fiIdent = theId
|
||||
, fiInput = [HAMLET|
|
||||
<input id="#{theId}" type="checkbox" name="#{name}" :val:checked="">
|
||||
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) i
|
||||
intField = Field
|
||||
{ fieldParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read
|
||||
, fieldRender = pack . showI
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
, fiErrors = case res of
|
||||
FormFailure [x] -> Just $ toHtml x
|
||||
_ -> Nothing
|
||||
, fiRequired = True
|
||||
}
|
||||
return (res, fi, UrlEncoded)
|
||||
}
|
||||
where
|
||||
showI x = show (fromIntegral x :: Integer)
|
||||
readMayI s = case reads s of
|
||||
(x, _):_ -> Just $ fromInteger x
|
||||
[] -> Nothing
|
||||
|
||||
htmlField = requiredFieldHelper htmlFieldProfile
|
||||
|
||||
maybeHtmlField = optionalFieldHelper htmlFieldProfile
|
||||
|
||||
selectField pairs ffs initial = do
|
||||
env <- askParams
|
||||
let label = ffsLabel ffs
|
||||
tooltip = ffsTooltip ffs
|
||||
theId <- maybe newFormIdent return $ ffsId ffs
|
||||
name <- maybe newFormIdent return $ ffsName ffs
|
||||
let pairs' = zip [1 :: Int ..] pairs
|
||||
let res = case lookup name env of
|
||||
Nothing -> FormMissing
|
||||
Just "none" -> FormFailure ["Field is required"]
|
||||
Just x ->
|
||||
case reads $ unpack x of
|
||||
(x', _):_ ->
|
||||
case lookup x' pairs' of
|
||||
Nothing -> FormFailure ["Invalid entry"]
|
||||
Just (y, _) -> FormSuccess y
|
||||
[] -> FormFailure ["Invalid entry"]
|
||||
let isSelected x =
|
||||
case res of
|
||||
FormSuccess y -> x == y
|
||||
_ -> Just x == initial
|
||||
let input =
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<select id="#{theId}" name="#{name}">
|
||||
<option value="none">
|
||||
$forall pair <- pairs'
|
||||
<option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}
|
||||
doubleField :: Monad monad => Field (GGWidget master monad ()) Double
|
||||
doubleField = Field
|
||||
{ fieldParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read
|
||||
, fieldRender = pack . show
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
let fi = FieldInfo
|
||||
{ fiLabel = toHtml label
|
||||
, fiTooltip = tooltip
|
||||
, fiIdent = theId
|
||||
, fiInput = input
|
||||
, fiErrors = case res of
|
||||
FormFailure [x] -> Just $ toHtml x
|
||||
_ -> Nothing
|
||||
, fiRequired = True
|
||||
}
|
||||
return (res, fi, UrlEncoded)
|
||||
}
|
||||
|
||||
maybeSelectField pairs ffs initial' = do
|
||||
env <- askParams
|
||||
let initial = join initial'
|
||||
label = ffsLabel ffs
|
||||
tooltip = ffsTooltip ffs
|
||||
theId <- maybe newFormIdent return $ ffsId ffs
|
||||
name <- maybe newFormIdent return $ ffsName ffs
|
||||
let pairs' = zip [1 :: Int ..] pairs
|
||||
let res = case lookup name env of
|
||||
Nothing -> FormMissing
|
||||
Just "none" -> FormSuccess Nothing
|
||||
Just x ->
|
||||
case reads $ unpack x of
|
||||
(x', _):_ ->
|
||||
case lookup x' pairs' of
|
||||
Nothing -> FormFailure ["Invalid entry"]
|
||||
Just (y, _) -> FormSuccess $ Just y
|
||||
[] -> FormFailure ["Invalid entry"]
|
||||
let isSelected x =
|
||||
case res of
|
||||
FormSuccess y -> Just x == y
|
||||
_ -> Just x == initial
|
||||
let input =
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<select id="#{theId}" name="#{name}">
|
||||
<option value="none">
|
||||
$forall pair <- pairs'
|
||||
<option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}
|
||||
dayField :: Monad monad => Field (GGWidget master monad ()) Day
|
||||
dayField = Field
|
||||
{ fieldParse = parseDate . unpack
|
||||
, fieldRender = pack . show
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
let fi = FieldInfo
|
||||
{ fiLabel = toHtml label
|
||||
, fiTooltip = tooltip
|
||||
, fiIdent = theId
|
||||
, fiInput = input
|
||||
, fiErrors = case res of
|
||||
FormFailure [x] -> Just $ toHtml x
|
||||
_ -> Nothing
|
||||
, fiRequired = False
|
||||
}
|
||||
return (res, fi, UrlEncoded)
|
||||
}
|
||||
|
||||
{- FIXME
|
||||
stringInput :: Text -> FormInput sub master Text
|
||||
stringInput n =
|
||||
mapFormXml fieldsToInput $
|
||||
requiredFieldHelper stringFieldProfile (nameSettings n) Nothing
|
||||
|
||||
maybeStringInput :: Text -> FormInput sub master (Maybe Text)
|
||||
maybeStringInput n =
|
||||
mapFormXml fieldsToInput $
|
||||
optionalFieldHelper stringFieldProfile (nameSettings n) Nothing
|
||||
|
||||
boolInput :: Text -> FormInput sub master Bool
|
||||
boolInput n = GForm $ do
|
||||
env <- askParams
|
||||
let res = case lookup n env of
|
||||
Nothing -> FormSuccess False
|
||||
Just "" -> FormSuccess False
|
||||
Just "false" -> FormSuccess False
|
||||
Just _ -> FormSuccess True
|
||||
let xml = [HAMLET|
|
||||
<input id="#{n}" type="checkbox" name="#{n}">
|
||||
timeField :: Monad monad => Field (GGWidget master monad ()) TimeOfDay
|
||||
timeField = Field
|
||||
{ fieldParse = parseTime . unpack
|
||||
, fieldRender = pack . show . roundFullSeconds
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
return (res, [xml], UrlEncoded)
|
||||
}
|
||||
where
|
||||
roundFullSeconds tod =
|
||||
TimeOfDay (todHour tod) (todMin tod) fullSec
|
||||
where
|
||||
fullSec = fromInteger $ floor $ todSec tod
|
||||
|
||||
dayInput :: Text -> FormInput sub master Day
|
||||
dayInput n =
|
||||
mapFormXml fieldsToInput $
|
||||
requiredFieldHelper dayFieldProfile (nameSettings n) Nothing
|
||||
|
||||
maybeDayInput :: Text -> FormInput sub master (Maybe Day)
|
||||
maybeDayInput n =
|
||||
mapFormXml fieldsToInput $
|
||||
optionalFieldHelper dayFieldProfile (nameSettings n) Nothing
|
||||
-}
|
||||
|
||||
nameSettings :: Text -> FormFieldSettings
|
||||
nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
|
||||
|
||||
urlField = requiredFieldHelper urlFieldProfile
|
||||
|
||||
maybeUrlField = optionalFieldHelper urlFieldProfile
|
||||
|
||||
{- FIXME
|
||||
urlInput :: Text -> FormInput sub master Text
|
||||
urlInput n =
|
||||
mapFormXml fieldsToInput $
|
||||
requiredFieldHelper urlFieldProfile (nameSettings n) Nothing
|
||||
-}
|
||||
|
||||
emailField = requiredFieldHelper emailFieldProfile
|
||||
|
||||
maybeEmailField = optionalFieldHelper emailFieldProfile
|
||||
|
||||
{- FIXME
|
||||
emailInput :: Text -> FormInput sub master Text
|
||||
emailInput n =
|
||||
mapFormXml fieldsToInput $
|
||||
requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
|
||||
-}
|
||||
|
||||
searchField = requiredFieldHelper . searchFieldProfile
|
||||
|
||||
maybeSearchField = optionalFieldHelper . searchFieldProfile
|
||||
|
||||
textareaField = requiredFieldHelper textareaFieldProfile
|
||||
|
||||
maybeTextareaField = optionalFieldHelper textareaFieldProfile
|
||||
|
||||
hiddenField = requiredFieldHelper hiddenFieldProfile
|
||||
|
||||
maybeHiddenField = optionalFieldHelper hiddenFieldProfile
|
||||
|
||||
fileField ffs = do
|
||||
env <- lift ask
|
||||
fenv <- lift $ lift ask
|
||||
let (FormFieldSettings label tooltip theId' name') = ffs
|
||||
name <- maybe newFormIdent return name'
|
||||
theId <- maybe newFormIdent return theId'
|
||||
let res =
|
||||
if null env && null fenv
|
||||
then FormMissing
|
||||
else case lookup name fenv of
|
||||
Nothing -> FormFailure ["File is required"]
|
||||
Just x -> FormSuccess x
|
||||
let fi = FieldInfo
|
||||
{ fiLabel = toHtml label
|
||||
, fiTooltip = tooltip
|
||||
, fiIdent = theId
|
||||
, fiInput = fileWidget theId name True
|
||||
, fiErrors = case res of
|
||||
FormFailure [x] -> Just $ toHtml x
|
||||
_ -> Nothing
|
||||
, fiRequired = True
|
||||
}
|
||||
let res' = case res of
|
||||
FormFailure [e] -> FormFailure [T.concat [label, ": ", e]]
|
||||
_ -> res
|
||||
return (res', fi, Multipart)
|
||||
|
||||
maybeFileField ffs = do
|
||||
fenv <- lift $ lift ask
|
||||
let (FormFieldSettings label tooltip theId' name') = ffs
|
||||
name <- maybe newFormIdent return name'
|
||||
theId <- maybe newFormIdent return theId'
|
||||
let res = FormSuccess $ lookup name fenv
|
||||
let fi = FieldInfo
|
||||
{ fiLabel = toHtml label
|
||||
, fiTooltip = tooltip
|
||||
, fiIdent = theId
|
||||
, fiInput = fileWidget theId name False
|
||||
, fiErrors = Nothing
|
||||
, fiRequired = True
|
||||
}
|
||||
return (res, fi, Multipart)
|
||||
|
||||
fileWidget :: Text -> Text -> Bool -> GWidget s m ()
|
||||
fileWidget theId name isReq = [HAMLET|
|
||||
<input id="#{theId}" type="file" name="#{name}" :isReq:required="">
|
||||
htmlField :: Monad monad => Field (GGWidget master monad ()) Html
|
||||
htmlField = Field
|
||||
{ fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
|
||||
, fieldRender = pack . renderHtml
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<textarea id="#{theId}" name="#{name}" .html>#{val}
|
||||
|]
|
||||
}
|
||||
|
||||
radioField pairs ffs initial = do
|
||||
env <- askParams
|
||||
let label = ffsLabel ffs
|
||||
tooltip = ffsTooltip ffs
|
||||
theId <- maybe newFormIdent return $ ffsId ffs
|
||||
name <- maybe newFormIdent return $ ffsName ffs
|
||||
let pairs' = zip [1 :: Int ..] pairs
|
||||
let res = case lookup name env of
|
||||
Nothing -> FormMissing
|
||||
Just "none" -> FormFailure ["Field is required"]
|
||||
Just x ->
|
||||
case reads $ unpack x of
|
||||
(x', _):_ ->
|
||||
case lookup x' pairs' of
|
||||
Nothing -> FormFailure ["Invalid entry"]
|
||||
Just (y, _) -> FormSuccess y
|
||||
[] -> FormFailure ["Invalid entry"]
|
||||
let isSelected x =
|
||||
case res of
|
||||
FormSuccess y -> x == y
|
||||
_ -> Just x == initial
|
||||
let input = [HAMLET|
|
||||
<div id="#{theId}">
|
||||
$forall pair <- pairs'
|
||||
<div>
|
||||
<input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">
|
||||
<label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}
|
||||
|]
|
||||
let fi = FieldInfo
|
||||
{ fiLabel = toHtml label
|
||||
, fiTooltip = tooltip
|
||||
, fiIdent = theId
|
||||
, fiInput = input
|
||||
, fiErrors = case res of
|
||||
FormFailure [x] -> Just $ toHtml x
|
||||
_ -> Nothing
|
||||
, fiRequired = True
|
||||
}
|
||||
return (res, fi, UrlEncoded)
|
||||
-- | 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
|
||||
|
||||
maybeRadioField pairs ffs initial' = do
|
||||
env <- askParams
|
||||
let initial = join initial'
|
||||
label = ffsLabel ffs
|
||||
tooltip = ffsTooltip ffs
|
||||
theId <- maybe newFormIdent return $ ffsId ffs
|
||||
name <- maybe newFormIdent return $ ffsName ffs
|
||||
let pairs' = zip [1 :: Int ..] pairs
|
||||
let res = case lookup name env of
|
||||
Nothing -> FormMissing
|
||||
Just "none" -> FormSuccess Nothing
|
||||
Just x ->
|
||||
case reads $ unpack x of
|
||||
(x', _):_ ->
|
||||
case lookup x' pairs' of
|
||||
Nothing -> FormFailure ["Invalid entry"]
|
||||
Just (y, _) -> FormSuccess $ Just y
|
||||
[] -> FormFailure ["Invalid entry"]
|
||||
let isSelected x =
|
||||
case res of
|
||||
FormSuccess y -> Just x == y
|
||||
_ -> Just x == initial
|
||||
let isNone =
|
||||
case res of
|
||||
FormSuccess Nothing -> True
|
||||
FormSuccess Just{} -> False
|
||||
_ -> isNothing initial
|
||||
let input =
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<div id="#{theId}">
|
||||
$forall pair <- pairs'
|
||||
<div>
|
||||
<input id="#{theId}-none" type="radio" name="#{name}" value="none" :isNone:checked="">None
|
||||
<div>
|
||||
<input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">
|
||||
<label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}
|
||||
textareaField :: Monad monad => Field (GGWidget master monad ()) Textarea
|
||||
textareaField = Field
|
||||
{ fieldParse = Right . Textarea
|
||||
, fieldRender = unTextarea
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<textarea id="#{theId}" name="#{name}">#{val}
|
||||
|]
|
||||
let fi = FieldInfo
|
||||
{ fiLabel = toHtml label
|
||||
, fiTooltip = tooltip
|
||||
, fiIdent = theId
|
||||
, fiInput = input
|
||||
, fiErrors = case res of
|
||||
FormFailure [x] -> Just $ toHtml x
|
||||
_ -> Nothing
|
||||
, fiRequired = False
|
||||
}
|
||||
return (res, fi, UrlEncoded)
|
||||
}
|
||||
|
||||
hiddenField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
hiddenField = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
textField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
textField = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
passwordField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
passwordField = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
readMay :: Read a => String -> Maybe a
|
||||
readMay s = case reads s of
|
||||
(x, _):_ -> Just x
|
||||
[] -> Nothing
|
||||
|
||||
parseDate :: String -> Either Text Day
|
||||
parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
|
||||
. readMay . replace '/' '-'
|
||||
|
||||
-- | Replaces all instances of a value in a list by another value.
|
||||
-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
|
||||
replace :: Eq a => a -> a -> [a] -> [a]
|
||||
replace x y = map (\z -> if z == x then y else z)
|
||||
|
||||
parseTime :: String -> Either 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':[]) =
|
||||
parseTimeHelper (h1, h2, m1, m2, '0', '0')
|
||||
parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =
|
||||
let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12
|
||||
in parseTimeHelper (h1', h2', m1, m2, '0', '0')
|
||||
parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
|
||||
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
||||
parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"
|
||||
|
||||
parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
|
||||
-> Either Text TimeOfDay
|
||||
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
||||
| 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]
|
||||
|
||||
emailField :: Monad monad => Field (GGWidget master monad ()) Text
|
||||
emailField = Field
|
||||
{ fieldParse = \s -> if Email.isValid (unpack s)
|
||||
then Right s
|
||||
else Left "Invalid e-mail address"
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
type AutoFocus = Bool
|
||||
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) Text
|
||||
searchField autoFocus = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> do
|
||||
addHtml [HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">
|
||||
|]
|
||||
when autoFocus $ do
|
||||
addHtml $ [HAMLET|\<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 ()) Text
|
||||
urlField = Field
|
||||
{ fieldParse = \s -> case parseURI $ unpack s of
|
||||
Nothing -> Left "Invalid URL"
|
||||
Just _ -> Right s
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHtml
|
||||
[HAMLET|
|
||||
<input ##{theId} name=#{name} type=url :isReq:required value=#{val}>
|
||||
|]
|
||||
}
|
||||
|
||||
174
Yesod/Form/Functions.hs
Normal file
174
Yesod/Form/Functions.hs
Normal file
@ -0,0 +1,174 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Form.Functions
|
||||
( -- * Running in Form monad
|
||||
newFormIdent
|
||||
, askParams
|
||||
, askFiles
|
||||
-- * Applicative/Monadic conversion
|
||||
, formToAForm
|
||||
, aFormToForm
|
||||
-- * Fields to Forms
|
||||
, mreq
|
||||
, mopt
|
||||
, areq
|
||||
, aopt
|
||||
-- * Run a form
|
||||
, runFormPost
|
||||
, runFormPostNoNonce
|
||||
, runFormGet
|
||||
-- * Rendering
|
||||
, FormRender
|
||||
, renderTable
|
||||
, renderDivs
|
||||
) where
|
||||
|
||||
import Yesod.Form.Types
|
||||
import Data.Text (Text, pack)
|
||||
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad (liftM)
|
||||
import Text.Blaze (Html)
|
||||
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody)
|
||||
import Yesod.Widget (GGWidget, whamlet)
|
||||
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams)
|
||||
import Network.Wai (requestMethod)
|
||||
import Text.Hamlet.NonPoly (html)
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define WHAMLET whamlet
|
||||
#define HTML html
|
||||
#else
|
||||
#define HTML $html
|
||||
#define WHAMLET $whamlet
|
||||
#endif
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newFormIdent :: Monad m => Form m Text
|
||||
newFormIdent = do
|
||||
i <- get
|
||||
let i' = incrInts i
|
||||
put i'
|
||||
return $ pack $ 'f' : show i'
|
||||
where
|
||||
incrInts (IntSingle i) = IntSingle $ i + 1
|
||||
incrInts (IntCons i is) = (i + 1) `IntCons` is
|
||||
|
||||
formToAForm :: Monad m => Form m (FormResult a, xml) -> AForm ([xml] -> [xml]) m a
|
||||
formToAForm form = AForm $ \env ints -> do
|
||||
((a, xml), ints', enc) <- runRWST form env ints
|
||||
return (a, (:) xml, ints', enc)
|
||||
|
||||
aFormToForm :: Monad m => AForm xml m a -> Form m (FormResult a, xml)
|
||||
aFormToForm (AForm aform) = do
|
||||
ints <- get
|
||||
env <- ask
|
||||
(a, xml, ints', enc) <- lift $ aform env ints
|
||||
put ints'
|
||||
tell enc
|
||||
return (a, xml)
|
||||
|
||||
askParams :: Monad m => Form m (Maybe Env)
|
||||
askParams = liftM (liftM fst) ask
|
||||
|
||||
askFiles :: Monad m => Form m (Maybe FileEnv)
|
||||
askFiles = liftM (liftM snd) ask
|
||||
|
||||
mreq :: Monad m => Field xml a -> Maybe a -> Form m (FormResult a, xml)
|
||||
mreq = undefined
|
||||
|
||||
mopt :: Monad m => Field xml a -> Maybe (Maybe a) -> Form m (FormResult (Maybe a), xml)
|
||||
mopt = undefined
|
||||
|
||||
areq :: Monad m => Field xml a -> Maybe a -> AForm ([xml] -> [xml]) m a
|
||||
areq a b = formToAForm $ mreq a b
|
||||
|
||||
aopt :: Monad m => Field xml a -> Maybe (Maybe a) -> AForm ([xml] -> [xml]) m (Maybe a)
|
||||
aopt a b = formToAForm $ mopt a b
|
||||
|
||||
runFormGeneric :: Monad m => Form m a -> Maybe (Env, FileEnv) -> m (a, Enctype)
|
||||
runFormGeneric form env = evalRWST form env (IntSingle 1)
|
||||
|
||||
runFormPost :: (Html -> Form (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
|
||||
runFormPost form = do
|
||||
req <- getRequest
|
||||
let nonceKey = "_nonce"
|
||||
let nonce =
|
||||
case reqNonce req of
|
||||
Nothing -> mempty
|
||||
Just n -> [HTML|<input type=hidden name=#{nonceKey} value=#{n}>|]
|
||||
env <- if requestMethod (reqWaiRequest req) == "GET"
|
||||
then return Nothing
|
||||
else fmap Just runRequestBody
|
||||
((res, xml), enctype) <- runFormGeneric (form nonce) env
|
||||
let res' =
|
||||
case (res, env) of
|
||||
(FormSuccess{}, Just (params, _))
|
||||
| lookup nonceKey params /= reqNonce req ->
|
||||
FormFailure [csrfWarning]
|
||||
_ -> res
|
||||
return ((res', xml), enctype)
|
||||
|
||||
csrfWarning :: Text
|
||||
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 form = do
|
||||
req <- getRequest
|
||||
env <- if requestMethod (reqWaiRequest req) == "GET"
|
||||
then return Nothing
|
||||
else fmap Just runRequestBody
|
||||
runFormGeneric (form mempty) env
|
||||
|
||||
runFormGet :: Monad m => (Html -> Form (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype)
|
||||
runFormGet form = do
|
||||
let key = "_hasdata"
|
||||
let fragment = [HTML|<input type=hidden name=#{key}>|]
|
||||
gets <- liftM reqGetParams getRequest
|
||||
let env =
|
||||
case lookup key gets of
|
||||
Nothing -> Nothing
|
||||
Just _ -> Just (gets, [])
|
||||
runFormGeneric (form fragment) env
|
||||
|
||||
type FormRender master m a =
|
||||
AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) m a
|
||||
-> Html
|
||||
-> Form m (FormResult a, GGWidget master m ())
|
||||
|
||||
renderTable, renderDivs :: Monad m => FormRender master m a
|
||||
renderTable aform fragment = do
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
-- FIXME non-valid HTML
|
||||
let widget = [WHAMLET|
|
||||
\#{fragment}
|
||||
$forall view <- views
|
||||
<tr :fvRequired view:.required :not $ fvRequired view:.optional>
|
||||
<td>
|
||||
<label for=#{fvId view}>#{fvLabel view}
|
||||
$maybe tt <- fvTooltip view
|
||||
<div .tooltip>#{tt}
|
||||
<td>^{fvInput view}
|
||||
$maybe err <- fvErrors view
|
||||
<td .errors>#{err}
|
||||
|]
|
||||
return (res, widget)
|
||||
|
||||
renderDivs aform fragment = do
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
let widget = [WHAMLET|
|
||||
\#{fragment}
|
||||
$forall view <- views
|
||||
<div :fvRequired view:.required :not $ fvRequired view:.optional>
|
||||
<label for=#{fvId view}>#{fvLabel view}
|
||||
$maybe tt <- fvTooltip view
|
||||
<div .tooltip>#{tt}
|
||||
^{fvInput view}
|
||||
$maybe err <- fvErrors view
|
||||
<div .errors>#{err}
|
||||
|]
|
||||
return (res, widget)
|
||||
@ -1,251 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Form.Profiles
|
||||
( stringFieldProfile
|
||||
, passwordFieldProfile
|
||||
, textareaFieldProfile
|
||||
, hiddenFieldProfile
|
||||
, intFieldProfile
|
||||
, dayFieldProfile
|
||||
, timeFieldProfile
|
||||
, htmlFieldProfile
|
||||
, emailFieldProfile
|
||||
, searchFieldProfile
|
||||
, AutoFocus
|
||||
, urlFieldProfile
|
||||
, doubleFieldProfile
|
||||
, parseDate
|
||||
, parseTime
|
||||
, Textarea (..)
|
||||
) where
|
||||
|
||||
import Yesod.Form.Core
|
||||
import Yesod.Widget
|
||||
import Text.Hamlet hiding (renderHtml)
|
||||
import Text.Blaze (ToHtml (..))
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define HAMLET hamlet
|
||||
#define CASSIUS cassius
|
||||
#define JULIUS julius
|
||||
#else
|
||||
#define HAMLET $hamlet
|
||||
#define CASSIUS $cassius
|
||||
#define JULIUS $julius
|
||||
#endif
|
||||
|
||||
intFieldProfile :: (Monad monad, Integral i) => FieldProfile (GGWidget master monad ()) i
|
||||
intFieldProfile = FieldProfile
|
||||
{ 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}">
|
||||
|]
|
||||
}
|
||||
where
|
||||
showI x = show (fromIntegral x :: Integer)
|
||||
readMayI s = case reads s of
|
||||
(x, _):_ -> Just $ fromInteger x
|
||||
[] -> Nothing
|
||||
|
||||
doubleFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Double
|
||||
doubleFieldProfile = FieldProfile
|
||||
{ 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}">
|
||||
|]
|
||||
}
|
||||
|
||||
dayFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Day
|
||||
dayFieldProfile = FieldProfile
|
||||
{ fpParse = parseDate . unpack
|
||||
, fpRender = pack . show
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
timeFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) TimeOfDay
|
||||
timeFieldProfile = FieldProfile
|
||||
{ fpParse = parseTime . unpack
|
||||
, fpRender = pack . show . roundFullSeconds
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
}
|
||||
where
|
||||
roundFullSeconds tod =
|
||||
TimeOfDay (todHour tod) (todMin tod) fullSec
|
||||
where
|
||||
fullSec = fromInteger $ floor $ todSec tod
|
||||
|
||||
htmlFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Html
|
||||
htmlFieldProfile = FieldProfile
|
||||
{ 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}
|
||||
|]
|
||||
}
|
||||
|
||||
-- | 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
|
||||
|
||||
textareaFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Textarea
|
||||
textareaFieldProfile = FieldProfile
|
||||
{ fpParse = Right . Textarea
|
||||
, fpRender = unTextarea
|
||||
, fpWidget = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<textarea id="#{theId}" name="#{name}">#{val}
|
||||
|]
|
||||
}
|
||||
|
||||
hiddenFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text
|
||||
hiddenFieldProfile = FieldProfile
|
||||
{ fpParse = Right
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
stringFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text
|
||||
stringFieldProfile = FieldProfile
|
||||
{ fpParse = Right
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
passwordFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text
|
||||
passwordFieldProfile = FieldProfile
|
||||
{ fpParse = Right
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
readMay :: Read a => String -> Maybe a
|
||||
readMay s = case reads s of
|
||||
(x, _):_ -> Just x
|
||||
[] -> Nothing
|
||||
|
||||
parseDate :: String -> Either Text Day
|
||||
parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
|
||||
. readMay . replace '/' '-'
|
||||
|
||||
-- | Replaces all instances of a value in a list by another value.
|
||||
-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
|
||||
replace :: Eq a => a -> a -> [a] -> [a]
|
||||
replace x y = map (\z -> if z == x then y else z)
|
||||
|
||||
parseTime :: String -> Either 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':[]) =
|
||||
parseTimeHelper (h1, h2, m1, m2, '0', '0')
|
||||
parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =
|
||||
let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12
|
||||
in parseTimeHelper (h1', h2', m1, m2, '0', '0')
|
||||
parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
|
||||
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
||||
parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"
|
||||
|
||||
parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
|
||||
-> Either Text TimeOfDay
|
||||
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
||||
| 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 :: Monad monad => FieldProfile (GGWidget master monad ()) Text
|
||||
emailFieldProfile = FieldProfile
|
||||
{ fpParse = \s -> if Email.isValid (unpack s)
|
||||
then Right s
|
||||
else Left "Invalid e-mail address"
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">
|
||||
|]
|
||||
}
|
||||
|
||||
type AutoFocus = Bool
|
||||
searchFieldProfile :: Monad monad => AutoFocus -> FieldProfile (GGWidget master monad ()) Text
|
||||
searchFieldProfile autoFocus = FieldProfile
|
||||
{ fpParse = Right
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> do
|
||||
addHtml [HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">
|
||||
|]
|
||||
when autoFocus $ do
|
||||
addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script>
|
||||
|]
|
||||
addCassius [CASSIUS|
|
||||
#{theId}
|
||||
-webkit-appearance: textfield
|
||||
|]
|
||||
}
|
||||
|
||||
urlFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text
|
||||
urlFieldProfile = FieldProfile
|
||||
{ fpParse = \s -> case parseURI $ unpack s of
|
||||
Nothing -> Left "Invalid URL"
|
||||
Just _ -> Right s
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> addHtml
|
||||
[HAMLET|
|
||||
<input ##{theId} name=#{name} type=url :isReq:required value=#{val}>
|
||||
|]
|
||||
}
|
||||
123
Yesod/Form/Types.hs
Normal file
123
Yesod/Form/Types.hs
Normal file
@ -0,0 +1,123 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Form.Types
|
||||
( -- * Helpers
|
||||
Enctype (..)
|
||||
, FormResult (..)
|
||||
, Env
|
||||
, FileEnv
|
||||
, Ints (..)
|
||||
-- * Form
|
||||
, Form
|
||||
, AForm (..)
|
||||
-- * Build forms
|
||||
, Field (..)
|
||||
, FieldSettings (..)
|
||||
, FieldView (..)
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
import Yesod.Request (FileInfo)
|
||||
import Data.Text (Text)
|
||||
import Data.Monoid (Monoid (..))
|
||||
import Text.Blaze (Html, ToHtml (toHtml))
|
||||
import Control.Applicative ((<$>), Applicative (..))
|
||||
import Control.Monad (liftM)
|
||||
import Data.String (IsString (..))
|
||||
import Control.Monad.Trans.Class (MonadTrans (..))
|
||||
|
||||
-- | A form can produce three different results: there was no data available,
|
||||
-- the data was invalid, or there was a successful parse.
|
||||
--
|
||||
-- The 'Applicative' instance will concatenate the failure messages in two
|
||||
-- 'FormResult's.
|
||||
data FormResult a = FormMissing
|
||||
| FormFailure [Text]
|
||||
| FormSuccess a
|
||||
deriving Show
|
||||
instance Functor FormResult where
|
||||
fmap _ FormMissing = FormMissing
|
||||
fmap _ (FormFailure errs) = FormFailure errs
|
||||
fmap f (FormSuccess a) = FormSuccess $ f a
|
||||
instance Applicative FormResult where
|
||||
pure = FormSuccess
|
||||
(FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
|
||||
(FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
|
||||
(FormFailure x) <*> _ = FormFailure x
|
||||
_ <*> (FormFailure y) = FormFailure y
|
||||
_ <*> _ = FormMissing
|
||||
instance Monoid m => Monoid (FormResult m) where
|
||||
mempty = pure mempty
|
||||
mappend x y = mappend <$> x <*> y
|
||||
|
||||
-- | The encoding type required by a form. The 'ToHtml' instance produces values
|
||||
-- that can be inserted directly into HTML.
|
||||
data Enctype = UrlEncoded | Multipart
|
||||
deriving (Eq, Enum, Bounded)
|
||||
instance ToHtml Enctype where
|
||||
toHtml UrlEncoded = "application/x-www-form-urlencoded"
|
||||
toHtml Multipart = "multipart/form-data"
|
||||
instance Monoid Enctype where
|
||||
mempty = UrlEncoded
|
||||
mappend UrlEncoded UrlEncoded = UrlEncoded
|
||||
mappend _ _ = Multipart
|
||||
|
||||
data Ints = IntCons Int Ints | IntSingle Int
|
||||
instance Show Ints where
|
||||
show (IntSingle i) = show i
|
||||
show (IntCons i is) = show i ++ ('-' : show is)
|
||||
|
||||
type Env = [(Text, Text)]
|
||||
type FileEnv = [(Text, FileInfo)]
|
||||
|
||||
type Form m a = RWST (Maybe (Env, FileEnv)) Enctype Ints m a
|
||||
|
||||
newtype AForm xml m a = AForm
|
||||
{ unAForm :: Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)
|
||||
}
|
||||
instance Monad m => Functor (AForm xml m) where
|
||||
fmap f (AForm a) =
|
||||
AForm $ \x y -> liftM go $ a x y
|
||||
where
|
||||
go (w, x, y, z) = (fmap f w, x, y, z)
|
||||
instance (Monad m, Monoid xml) => Applicative (AForm xml m) where
|
||||
pure x = AForm $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
|
||||
(AForm f) <*> (AForm g) = AForm $ \env ints -> do
|
||||
(a, b, ints', c) <- f env ints
|
||||
(x, y, ints'', z) <- g env ints'
|
||||
return (a <*> x, b `mappend` y, ints'', c `mappend` z)
|
||||
instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml m a) where
|
||||
mempty = pure mempty
|
||||
mappend a b = mappend <$> a <*> b
|
||||
instance Monoid xml => MonadTrans (AForm xml) where
|
||||
lift mx = AForm $ const $ \ints -> do
|
||||
x <- mx
|
||||
return (pure x, mempty, ints, mempty)
|
||||
|
||||
data FieldSettings = FieldSettings
|
||||
{ fsLabel :: Html -- FIXME do we need Text?
|
||||
, fsTooltip :: Maybe Html
|
||||
, fsId :: Maybe Text
|
||||
, fsName :: Maybe Text
|
||||
}
|
||||
|
||||
instance IsString FieldSettings where
|
||||
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing
|
||||
|
||||
data FieldView xml = FieldView
|
||||
{ fvLabel :: Html
|
||||
, fvTooltip :: Maybe Html
|
||||
, fvId :: Text
|
||||
, fvInput :: xml
|
||||
, fvErrors :: Maybe Html
|
||||
, fvRequired :: Bool
|
||||
}
|
||||
|
||||
data Field xml a = Field
|
||||
{ fieldParse :: Text -> Either Text a -- FIXME probably want to make this more sophisticated, handle no form, no field
|
||||
, fieldRender :: a -> Text
|
||||
, fieldView :: Text -- ^ ID
|
||||
-> Text -- ^ name
|
||||
-> Text -- ^ value
|
||||
-> Bool -- ^ required?
|
||||
-> xml
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user