616 lines
21 KiB
Haskell
616 lines
21 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE CPP #-}
|
|
module Yesod.Form.Fields
|
|
( -- * i18n
|
|
FormMessage (..)
|
|
, defaultFormMessage
|
|
-- * Fields
|
|
, textField
|
|
, passwordField
|
|
, textareaField
|
|
, hiddenField
|
|
, intField
|
|
, dayField
|
|
, timeField
|
|
, htmlField
|
|
, emailField
|
|
, searchField
|
|
, AutoFocus
|
|
, urlField
|
|
, doubleField
|
|
, parseDate
|
|
, parseTime
|
|
, Textarea (..)
|
|
, boolField
|
|
, checkBoxField
|
|
, fileField
|
|
-- * File 'AForm's
|
|
, fileAFormReq
|
|
, fileAFormOpt
|
|
-- * Options
|
|
, selectField
|
|
, selectFieldList
|
|
, radioField
|
|
, radioFieldList
|
|
, multiSelectField
|
|
, multiSelectFieldList
|
|
, Option (..)
|
|
, OptionList (..)
|
|
, mkOptionList
|
|
, optionsPersist
|
|
, optionsPairs
|
|
, optionsEnum
|
|
) where
|
|
|
|
import Yesod.Form.Types
|
|
import Yesod.Form.I18n.English
|
|
import Yesod.Form.Functions (parseHelper)
|
|
import Yesod.Core
|
|
import Text.Hamlet
|
|
import Text.Blaze (ToMarkup (toMarkup), preEscapedToMarkup, unsafeByteString)
|
|
#define ToHtml ToMarkup
|
|
#define toHtml toMarkup
|
|
#define preEscapedText preEscapedToMarkup
|
|
import Text.Cassius
|
|
import Data.Time (Day, TimeOfDay(..))
|
|
import qualified Text.Email.Validate as Email
|
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
|
|
import Data.Text.Encoding.Error (lenientDecode)
|
|
import Network.URI (parseURI)
|
|
import Database.Persist (PersistField)
|
|
import Database.Persist.Store (Entity (..))
|
|
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
|
import Control.Monad (when, unless)
|
|
import Data.Maybe (listToMaybe, fromMaybe)
|
|
|
|
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
|
|
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
|
|
import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
|
|
import Database.Persist.Store (PersistEntityBackend)
|
|
import Database.Persist.Store (PersistMonadBackend)
|
|
|
|
import Text.Blaze.Html.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 qualified Data.Map as Map
|
|
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)
|
|
import Control.Arrow ((&&&))
|
|
|
|
import Control.Applicative ((<$>), (<|>))
|
|
|
|
import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly)
|
|
|
|
defaultFormMessage :: FormMessage -> Text
|
|
defaultFormMessage = englishFormMessage
|
|
|
|
|
|
intField :: (Integral i, RenderMessage site FormMessage) => Field site i
|
|
intField = Field
|
|
{ fieldParse = parseHelper $ \s ->
|
|
case Data.Text.Read.signed Data.Text.Read.decimal s of
|
|
Right (a, "") -> Right a
|
|
_ -> Left $ MsgInvalidInteger s
|
|
|
|
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where
|
|
showVal = either id (pack . showI)
|
|
showI x = show (fromIntegral x :: Integer)
|
|
|
|
doubleField :: RenderMessage site FormMessage => Field site Double
|
|
doubleField = Field
|
|
{ fieldParse = parseHelper $ \s ->
|
|
case Data.Text.Read.double s of
|
|
Right (a, "") -> Right a
|
|
_ -> Left $ MsgInvalidNumber s
|
|
|
|
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where showVal = either id (pack . show)
|
|
|
|
dayField :: RenderMessage site FormMessage => Field site Day
|
|
dayField = Field
|
|
{ fieldParse = parseHelper $ parseDate . unpack
|
|
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where showVal = either id (pack . show)
|
|
|
|
timeField :: RenderMessage site FormMessage => Field site TimeOfDay
|
|
timeField = Field
|
|
{ fieldParse = parseHelper parseTime
|
|
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where
|
|
showVal = either id (pack . show . roundFullSeconds)
|
|
roundFullSeconds tod =
|
|
TimeOfDay (todHour tod) (todMin tod) fullSec
|
|
where
|
|
fullSec = fromInteger $ floor $ todSec tod
|
|
|
|
htmlField :: RenderMessage site FormMessage => Field site Html
|
|
htmlField = Field
|
|
{ fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
|
|
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val}
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where showVal = either id (pack . renderHtml)
|
|
|
|
-- | A newtype wrapper around a 'Text' that converts newlines to HTML
|
|
-- br-tags.
|
|
newtype Textarea = Textarea { unTextarea :: Text }
|
|
deriving (Show, Read, Eq, PersistField, Ord)
|
|
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 :: RenderMessage site FormMessage => Field site Textarea
|
|
textareaField = Field
|
|
{ fieldParse = parseHelper $ Right . Textarea
|
|
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val}
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
hiddenField :: (PathPiece p, RenderMessage site FormMessage)
|
|
=> Field site p
|
|
hiddenField = Field
|
|
{ fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
|
|
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
textField :: RenderMessage site FormMessage => Field site Text
|
|
textField = Field
|
|
{ fieldParse = parseHelper $ Right
|
|
, fieldView = \theId name attrs val isReq ->
|
|
[whamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
passwordField :: RenderMessage site FormMessage => Field site Text
|
|
passwordField = Field
|
|
{ fieldParse = parseHelper $ Right
|
|
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
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 :: Text -> Either FormMessage TimeOfDay
|
|
parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
|
|
|
|
timeParser :: Parser TimeOfDay
|
|
timeParser = do
|
|
skipSpace
|
|
h <- hour
|
|
_ <- char ':'
|
|
m <- minsec MsgInvalidMinute
|
|
hasSec <- (char ':' >> return True) <|> return False
|
|
s <- if hasSec then minsec MsgInvalidSecond else return 0
|
|
skipSpace
|
|
isPM <-
|
|
(string "am" >> return (Just False)) <|>
|
|
(string "AM" >> return (Just False)) <|>
|
|
(string "pm" >> return (Just True)) <|>
|
|
(string "PM" >> return (Just True)) <|>
|
|
return Nothing
|
|
h' <-
|
|
case isPM of
|
|
Nothing -> return h
|
|
Just x
|
|
| h <= 0 || h > 12 -> fail $ show $ MsgInvalidHour $ pack $ show h
|
|
| h == 12 -> return $ if x then 12 else 0
|
|
| otherwise -> return $ h + (if x then 12 else 0)
|
|
skipSpace
|
|
endOfInput
|
|
return $ TimeOfDay h' m s
|
|
where
|
|
hour = do
|
|
x <- digit
|
|
y <- (return <$> digit) <|> return []
|
|
let xy = x : y
|
|
let i = read xy
|
|
if i < 0 || i >= 24
|
|
then fail $ show $ MsgInvalidHour $ pack xy
|
|
else return i
|
|
minsec :: Num a => (Text -> FormMessage) -> Parser a
|
|
minsec msg = do
|
|
x <- digit
|
|
y <- digit <|> fail (show $ msg $ pack [x])
|
|
let xy = [x, y]
|
|
let i = read xy
|
|
if i < 0 || i >= 60
|
|
then fail $ show $ msg $ pack xy
|
|
else return $ fromIntegral (i :: Int)
|
|
|
|
emailField :: RenderMessage site FormMessage => Field site Text
|
|
emailField = Field
|
|
{ fieldParse = parseHelper $
|
|
\s ->
|
|
case Email.canonicalizeEmail $ encodeUtf8 s of
|
|
Just e -> Right $ decodeUtf8With lenientDecode e
|
|
Nothing -> Left $ MsgInvalidEmail s
|
|
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
type AutoFocus = Bool
|
|
searchField :: RenderMessage site FormMessage => AutoFocus -> Field site Text
|
|
searchField autoFocus = Field
|
|
{ fieldParse = parseHelper Right
|
|
, fieldView = \theId name attrs val isReq -> do
|
|
[whamlet|\
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|
|
|]
|
|
when autoFocus $ do
|
|
-- we want this javascript to be placed immediately after the field
|
|
[whamlet|
|
|
$newline never
|
|
<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}
|
|
|]
|
|
toWidget [cassius|
|
|
##{theId}
|
|
-webkit-appearance: textfield
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
urlField :: RenderMessage site FormMessage => Field site Text
|
|
urlField = Field
|
|
{ fieldParse = parseHelper $ \s ->
|
|
case parseURI $ unpack s of
|
|
Nothing -> Left $ MsgInvalidUrl s
|
|
Just _ -> Right s
|
|
, fieldView = \theId name attrs val isReq ->
|
|
[whamlet|
|
|
$newline never
|
|
<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site a
|
|
selectFieldList = selectField . optionsPairs
|
|
|
|
selectField :: (Eq a, RenderMessage site FormMessage) => GHandler site (OptionList a) -> Field site a
|
|
selectField = selectFieldHelper
|
|
(\theId name attrs inside -> [whamlet|
|
|
$newline never
|
|
<select ##{theId} name=#{name} *{attrs}>^{inside}
|
|
|]) -- outside
|
|
(\_theId _name isSel -> [whamlet|
|
|
$newline never
|
|
<option value=none :isSel:selected>_{MsgSelectNone}
|
|
|]) -- onOpt
|
|
(\_theId _name _attrs value isSel text -> [whamlet|
|
|
$newline never
|
|
<option value=#{value} :isSel:selected>#{text}
|
|
|]) -- inside
|
|
|
|
multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site [a]
|
|
multiSelectFieldList = multiSelectField . optionsPairs
|
|
|
|
multiSelectField :: (Eq a, RenderMessage site FormMessage)
|
|
=> GHandler site (OptionList a)
|
|
-> Field site [a]
|
|
multiSelectField ioptlist =
|
|
Field parse view UrlEncoded
|
|
where
|
|
parse [] _ = return $ Right Nothing
|
|
parse optlist _ = do
|
|
mapopt <- olReadExternal <$> ioptlist
|
|
case mapM mapopt optlist of
|
|
Nothing -> return $ Left "Error parsing values"
|
|
Just res -> return $ Right $ Just res
|
|
|
|
view theId name attrs val isReq = do
|
|
opts <- fmap olOptions $ lift ioptlist
|
|
let selOpts = map (id &&& (optselected val)) opts
|
|
[whamlet|
|
|
$newline never
|
|
<select ##{theId} name=#{name} :isReq:required multiple *{attrs}>
|
|
$forall (opt, optsel) <- selOpts
|
|
<option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}
|
|
|]
|
|
where
|
|
optselected (Left _) _ = False
|
|
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
|
|
|
|
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site a
|
|
radioFieldList = radioField . optionsPairs
|
|
|
|
radioField :: (Eq a, RenderMessage site FormMessage) => GHandler site (OptionList a) -> Field site a
|
|
radioField = selectFieldHelper
|
|
(\theId _name _attrs inside -> [whamlet|
|
|
$newline never
|
|
<div ##{theId}>^{inside}
|
|
|])
|
|
(\theId name isSel -> [whamlet|
|
|
$newline never
|
|
<label .radio for=#{theId}-none>
|
|
<div>
|
|
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
|
|
_{MsgSelectNone}
|
|
|])
|
|
(\theId name attrs value isSel text -> [whamlet|
|
|
$newline never
|
|
<label .radio for=#{theId}-#{value}>
|
|
<div>
|
|
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
|
|
\#{text}
|
|
|])
|
|
|
|
boolField :: RenderMessage site FormMessage => Field site Bool
|
|
boolField = Field
|
|
{ fieldParse = \e _ -> return $ boolParser e
|
|
, fieldView = \theId name attrs val isReq -> [whamlet|
|
|
$newline never
|
|
$if not isReq
|
|
<input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>
|
|
<label for=#{theId}-none>_{MsgSelectNone}
|
|
|
|
|
|
<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked>
|
|
<label for=#{theId}-yes>_{MsgBoolYes}
|
|
|
|
<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked>
|
|
<label for=#{theId}-no>_{MsgBoolNo}
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where
|
|
boolParser [] = Right Nothing
|
|
boolParser (x:_) = case x of
|
|
"" -> Right Nothing
|
|
"none" -> Right Nothing
|
|
"yes" -> Right $ Just True
|
|
"on" -> Right $ Just True
|
|
"no" -> Right $ Just False
|
|
t -> Left $ SomeMessage $ MsgInvalidBool t
|
|
showVal = either (\_ -> False)
|
|
|
|
-- | While the default @'boolField'@ implements a radio button so you
|
|
-- can differentiate between an empty response (Nothing) and a no
|
|
-- response (Just False), this simpler checkbox field returns an empty
|
|
-- response as Just False.
|
|
--
|
|
-- Note that this makes the field always optional.
|
|
--
|
|
checkBoxField :: RenderMessage site FormMessage => Field site Bool
|
|
checkBoxField = Field
|
|
{ fieldParse = \e _ -> return $ checkBoxParser e
|
|
, fieldView = \theId name attrs val _ -> [whamlet|
|
|
$newline never
|
|
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked>
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
where
|
|
checkBoxParser [] = Right $ Just False
|
|
checkBoxParser (x:_) = case x of
|
|
"yes" -> Right $ Just True
|
|
"on" -> Right $ Just True
|
|
_ -> Right $ Just False
|
|
|
|
showVal = either (\_ -> False)
|
|
|
|
data OptionList a = OptionList
|
|
{ olOptions :: [Option a]
|
|
, olReadExternal :: Text -> Maybe a
|
|
}
|
|
|
|
mkOptionList :: [Option a] -> OptionList a
|
|
mkOptionList os = OptionList
|
|
{ olOptions = os
|
|
, olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os
|
|
}
|
|
|
|
data Option a = Option
|
|
{ optionDisplay :: Text
|
|
, optionInternalValue :: a
|
|
, optionExternalValue :: Text
|
|
}
|
|
|
|
optionsPairs :: RenderMessage site msg => [(msg, a)] -> GHandler site (OptionList a)
|
|
optionsPairs opts = do
|
|
mr <- getMessageRender
|
|
let mkOption external (display, internal) =
|
|
Option { optionDisplay = mr display
|
|
, optionInternalValue = internal
|
|
, optionExternalValue = pack $ show external
|
|
}
|
|
return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
|
|
|
|
optionsEnum :: (Show a, Enum a, Bounded a) => GHandler site (OptionList a)
|
|
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
|
|
|
|
optionsPersist :: ( YesodPersist site, PersistEntity a
|
|
, PersistQuery (YesodPersistBackend site (GHandler site))
|
|
, PathPiece (Key a)
|
|
, PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (GHandler site))
|
|
, RenderMessage site msg
|
|
)
|
|
=> [Filter a] -> [SelectOpt a] -> (a -> msg) -> GHandler site (OptionList (Entity a))
|
|
optionsPersist filts ords toDisplay = fmap mkOptionList $ do
|
|
mr <- getMessageRender
|
|
pairs <- runDB $ selectList filts ords
|
|
return $ map (\(Entity key value) -> Option
|
|
{ optionDisplay = mr (toDisplay value)
|
|
, optionInternalValue = Entity key value
|
|
, optionExternalValue = toPathPiece key
|
|
}) pairs
|
|
|
|
selectFieldHelper
|
|
:: (Eq a, RenderMessage site FormMessage)
|
|
=> (Text -> Text -> [(Text, Text)] -> GWidget site () -> GWidget site ())
|
|
-> (Text -> Text -> Bool -> GWidget site ())
|
|
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget site ())
|
|
-> GHandler site (OptionList a) -> Field site a
|
|
selectFieldHelper outside onOpt inside opts' = Field
|
|
{ fieldParse = \x _ -> do
|
|
opts <- opts'
|
|
return $ selectParser opts x
|
|
, fieldView = \theId name attrs val isReq -> do
|
|
opts <- fmap olOptions $ lift opts'
|
|
outside theId name attrs $ do
|
|
unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
|
|
flip mapM_ opts $ \opt -> inside
|
|
theId
|
|
name
|
|
attrs
|
|
(optionExternalValue opt)
|
|
((render opts val) == optionExternalValue opt)
|
|
(optionDisplay opt)
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where
|
|
render _ (Left _) = ""
|
|
render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
|
|
selectParser _ [] = Right Nothing
|
|
selectParser opts (s:_) = case s of
|
|
"" -> Right Nothing
|
|
"none" -> Right Nothing
|
|
x -> case olReadExternal opts x of
|
|
Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
|
|
Just y -> Right $ Just y
|
|
|
|
fileField :: RenderMessage site FormMessage => Field site FileInfo
|
|
fileField = Field
|
|
{ fieldParse = \_ files -> return $
|
|
case files of
|
|
[] -> Right Nothing
|
|
file:_ -> Right $ Just file
|
|
, fieldView = \id' name attrs _ isReq -> toWidget [hamlet|
|
|
<input id=#{id'} name=#{name} *{attrs} type=file :isReq:required>
|
|
|]
|
|
, fieldEnctype = Multipart
|
|
}
|
|
|
|
fileAFormReq :: RenderMessage site FormMessage => FieldSettings site -> AForm site FileInfo
|
|
fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
|
|
let (name, ints') =
|
|
case fsName fs of
|
|
Just x -> (x, ints)
|
|
Nothing ->
|
|
let i' = incrInts ints
|
|
in (pack $ 'f' : show i', i')
|
|
id' <- maybe newIdent return $ fsId fs
|
|
let (res, errs) =
|
|
case menvs of
|
|
Nothing -> (FormMissing, Nothing)
|
|
Just (_, fenv) ->
|
|
case Map.lookup name fenv of
|
|
Just (fi:_) -> (FormSuccess fi, Nothing)
|
|
_ ->
|
|
let t = renderMessage site langs MsgValueRequired
|
|
in (FormFailure [t], Just $ toHtml t)
|
|
let fv = FieldView
|
|
{ fvLabel = toHtml $ renderMessage site langs $ fsLabel fs
|
|
, fvTooltip = fmap (toHtml . renderMessage site langs) $ fsTooltip fs
|
|
, fvId = id'
|
|
, fvInput = [whamlet|
|
|
$newline never
|
|
<input type=file name=#{name} ##{id'} *{fsAttrs fs}>
|
|
|]
|
|
, fvErrors = errs
|
|
, fvRequired = True
|
|
}
|
|
return (res, (fv :), ints', Multipart)
|
|
|
|
fileAFormOpt :: RenderMessage site FormMessage => FieldSettings site -> AForm site (Maybe FileInfo)
|
|
fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
|
|
let (name, ints') =
|
|
case fsName fs of
|
|
Just x -> (x, ints)
|
|
Nothing ->
|
|
let i' = incrInts ints
|
|
in (pack $ 'f' : show i', i')
|
|
id' <- maybe newIdent return $ fsId fs
|
|
let (res, errs) =
|
|
case menvs of
|
|
Nothing -> (FormMissing, Nothing)
|
|
Just (_, fenv) ->
|
|
case Map.lookup name fenv of
|
|
Just (fi:_) -> (FormSuccess $ Just fi, Nothing)
|
|
_ -> (FormSuccess Nothing, Nothing)
|
|
let fv = FieldView
|
|
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
|
|
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
|
|
, fvId = id'
|
|
, fvInput = [whamlet|
|
|
$newline never
|
|
<input type=file name=#{name} ##{id'} *{fsAttrs fs}>
|
|
|]
|
|
, fvErrors = errs
|
|
, fvRequired = False
|
|
}
|
|
return (res, (fv :), ints', Multipart)
|
|
|
|
incrInts :: Ints -> Ints
|
|
incrInts (IntSingle i) = IntSingle $ i + 1
|
|
incrInts (IntCons i is) = (i + 1) `IntCons` is
|