955 lines
31 KiB
Haskell
955 lines
31 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
-- | Parse forms (and query strings).
|
|
module Yesod.Form
|
|
( -- * Data types
|
|
GForm (..)
|
|
, Form
|
|
, Formlet
|
|
, FormField
|
|
, FormletField
|
|
, FormInput
|
|
, FormResult (..)
|
|
, Enctype (..)
|
|
, FieldInfo (..)
|
|
, Html'
|
|
-- * Unwrapping functions
|
|
, runFormGet
|
|
, runFormPost
|
|
, runFormGet'
|
|
, runFormPost'
|
|
-- * Type classes
|
|
, ToForm (..)
|
|
, ToFormField (..)
|
|
-- * Field/form helpers
|
|
, requiredFieldHelper
|
|
, optionalFieldHelper
|
|
, mapFormXml
|
|
, newFormIdent
|
|
, fieldsToTable
|
|
, fieldsToPlain
|
|
, fieldsToInput
|
|
-- * Field profiles
|
|
, FieldProfile (..)
|
|
, stringFieldProfile
|
|
, intFieldProfile
|
|
, dayFieldProfile
|
|
, jqueryDayFieldProfile
|
|
, timeFieldProfile
|
|
, htmlFieldProfile
|
|
, emailFieldProfile
|
|
-- * Pre-built fields
|
|
, stringField
|
|
, maybeStringField
|
|
, intField
|
|
, maybeIntField
|
|
, doubleField
|
|
, maybeDoubleField
|
|
, dayField
|
|
, maybeDayField
|
|
, jqueryDayField
|
|
, maybeJqueryDayField
|
|
, jqueryDayTimeField
|
|
, jqueryDayTimeFieldProfile
|
|
, timeField
|
|
, maybeTimeField
|
|
, htmlField
|
|
, maybeHtmlField
|
|
, nicHtmlField
|
|
, maybeNicHtmlField
|
|
, selectField
|
|
, maybeSelectField
|
|
, boolField
|
|
, jqueryAutocompleteField
|
|
, maybeJqueryAutocompleteField
|
|
, emailField
|
|
, maybeEmailField
|
|
-- * Pre-built inputs
|
|
, stringInput
|
|
, maybeStringInput
|
|
, intInput
|
|
, boolInput
|
|
, dayInput
|
|
, maybeDayInput
|
|
, emailInput
|
|
-- * Template Haskell
|
|
, share2
|
|
, mkToForm
|
|
) where
|
|
|
|
import Text.Hamlet
|
|
import Yesod.Request
|
|
import Yesod.Handler
|
|
import Control.Applicative hiding (optional)
|
|
import Data.Time (UTCTime(..), Day, TimeOfDay(..))
|
|
import Data.Time.LocalTime (timeOfDayToTime, timeToTimeOfDay)
|
|
import Data.Maybe (fromMaybe, isJust)
|
|
import "transformers" Control.Monad.IO.Class
|
|
import Control.Monad ((<=<), liftM, join)
|
|
import Data.Monoid (Monoid (..))
|
|
import Control.Monad.Trans.State
|
|
import Language.Haskell.TH.Syntax
|
|
import Database.Persist.Base (EntityDef (..))
|
|
import Data.Char (toUpper, isUpper)
|
|
import Data.Int (Int64)
|
|
import qualified Data.ByteString.Lazy.UTF8 as U
|
|
import Yesod.Widget
|
|
import Control.Arrow ((&&&))
|
|
import qualified Text.Email.Validate as Email
|
|
import Data.Char (isSpace)
|
|
import Yesod.Yesod (Yesod (..))
|
|
|
|
-- | 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 [String]
|
|
| 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
|
|
|
|
-- | The encoding type required by a form. The 'Show' instance produces values
|
|
-- that can be inserted directly into HTML.
|
|
data Enctype = UrlEncoded | Multipart
|
|
instance Show Enctype where
|
|
show UrlEncoded = "application/x-www-form-urlencoded"
|
|
show Multipart = "multipart/form-data"
|
|
instance Monoid Enctype where
|
|
mempty = UrlEncoded
|
|
mappend UrlEncoded UrlEncoded = UrlEncoded
|
|
mappend _ _ = Multipart
|
|
|
|
-- | A generic form, allowing you to specifying the subsite datatype, master
|
|
-- site datatype, a datatype for the form XML and the return type.
|
|
newtype GForm sub y xml a = GForm
|
|
{ deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype)
|
|
}
|
|
type Form sub y = GForm sub y (GWidget sub y ())
|
|
type Formlet sub y a = Maybe a -> Form sub y a
|
|
type FormField sub y = GForm sub y [FieldInfo sub y]
|
|
type FormletField sub y a = Maybe a -> FormField sub y a
|
|
type FormInput sub y = GForm sub y [GWidget sub y ()]
|
|
|
|
-- | Convert the XML in a 'GForm'.
|
|
mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
|
|
mapFormXml f (GForm g) = GForm $ \e fe -> do
|
|
(res, xml, enc) <- g e fe
|
|
return (res, f xml, enc)
|
|
|
|
-- | Using this as the intermediate XML representation for fields allows us to
|
|
-- write generic field functions and then different functions for producing
|
|
-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'.
|
|
data FieldInfo sub y = FieldInfo
|
|
{ fiLabel :: Html ()
|
|
, fiTooltip :: Html ()
|
|
, fiIdent :: String
|
|
, fiInput :: GWidget sub y ()
|
|
, fiErrors :: Maybe (Html ())
|
|
}
|
|
|
|
type Env = [(String, String)]
|
|
type FileEnv = [(String, FileInfo)]
|
|
|
|
instance Monoid xml => Functor (GForm sub url xml) where
|
|
fmap f (GForm g) =
|
|
GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe)
|
|
where
|
|
first3 f' (x, y, z) = (f' x, y, z)
|
|
|
|
instance Monoid xml => Applicative (GForm sub url xml) where
|
|
pure a = GForm $ const $ const $ return (pure a, mempty, mempty)
|
|
(GForm f) <*> (GForm g) = GForm $ \env fe -> do
|
|
(f1, f2, f3) <- f env fe
|
|
(g1, g2, g3) <- g env fe
|
|
return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)
|
|
|
|
-- | Display only the actual input widget code, without any decoration.
|
|
fieldsToPlain :: [FieldInfo sub y] -> GWidget sub y ()
|
|
fieldsToPlain = mapM_ fiInput
|
|
|
|
fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]
|
|
fieldsToInput = map fiInput
|
|
|
|
-- | Display the label, tooltip, input code and errors in a single row of a
|
|
-- table.
|
|
fieldsToTable :: [FieldInfo sub y] -> GWidget sub y ()
|
|
fieldsToTable = mapM_ go
|
|
where
|
|
go fi = do
|
|
wrapWidget (fiInput fi) $ \w -> [$hamlet|
|
|
%tr
|
|
%td
|
|
%label!for=$fiIdent.fi$ $fiLabel.fi$
|
|
.tooltip $fiTooltip.fi$
|
|
%td
|
|
^w^
|
|
$maybe fiErrors.fi err
|
|
%td.errors $err$
|
|
|]
|
|
|
|
class ToForm a where
|
|
toForm :: Maybe a -> Form sub y a
|
|
class ToFormField a where
|
|
toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a
|
|
|
|
-- | Create a required field (ie, one that cannot be blank) from a
|
|
-- 'FieldProfile'.
|
|
requiredFieldHelper :: FieldProfile sub y a -> Maybe a -> FormField sub y a
|
|
requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig =
|
|
GForm $ \env _ -> do
|
|
name <- maybe newFormIdent return name'
|
|
let (res, val) =
|
|
if null env
|
|
then (FormMissing, maybe "" render orig)
|
|
else case lookup name env of
|
|
Nothing -> (FormMissing, "")
|
|
Just "" -> (FormFailure ["Value is required"], "")
|
|
Just x ->
|
|
case parse x of
|
|
Left e -> (FormFailure [e], x)
|
|
Right y -> (FormSuccess y, x)
|
|
let fi = FieldInfo
|
|
{ fiLabel = label
|
|
, fiTooltip = tooltip
|
|
, fiIdent = name
|
|
, fiInput = w name >> addBody (mkXml (string name) (string val) True)
|
|
, fiErrors = case res of
|
|
FormFailure [x] -> Just $ string x
|
|
_ -> Nothing
|
|
}
|
|
return (res, [fi], UrlEncoded)
|
|
|
|
-- | Create an optional field (ie, one that can be blank) from a
|
|
-- 'FieldProfile'.
|
|
optionalFieldHelper :: FieldProfile sub y a -> Maybe (Maybe a)
|
|
-> FormField sub y (Maybe a)
|
|
optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig' =
|
|
GForm $ \env _ -> do
|
|
let orig = join orig'
|
|
name <- maybe newFormIdent return name'
|
|
let (res, val) =
|
|
if null env
|
|
then (FormSuccess Nothing, maybe "" render orig)
|
|
else case lookup name env of
|
|
Nothing -> (FormSuccess Nothing, "")
|
|
Just "" -> (FormSuccess Nothing, "")
|
|
Just x ->
|
|
case parse x of
|
|
Left e -> (FormFailure [e], x)
|
|
Right y -> (FormSuccess $ Just y, x)
|
|
let fi = FieldInfo
|
|
{ fiLabel = label
|
|
, fiTooltip = tooltip
|
|
, fiIdent = name
|
|
, fiInput = w name >> addBody (mkXml (string name) (string val) False)
|
|
, fiErrors = case res of
|
|
FormFailure [x] -> Just $ string x
|
|
_ -> Nothing
|
|
}
|
|
return (res, [fi], UrlEncoded)
|
|
|
|
-- | A generic definition of a form field that can be used for generating both
|
|
-- required and optional fields. See 'requiredFieldHelper and
|
|
-- 'optionalFieldHelper'.
|
|
data FieldProfile sub y a = FieldProfile
|
|
{ fpParse :: String -> Either String a
|
|
, fpRender :: a -> String
|
|
, fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Route y)
|
|
, fpWidget :: String -> GWidget sub y ()
|
|
, fpName :: Maybe String
|
|
, fpLabel :: Html ()
|
|
, fpTooltip :: Html ()
|
|
}
|
|
|
|
--------------------- Begin prebuilt forms
|
|
|
|
stringField :: Html () -> Html () -> FormletField sub y String
|
|
stringField label tooltip = requiredFieldHelper stringFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
maybeStringField :: Html () -> Html () -> FormletField sub y (Maybe String)
|
|
maybeStringField label tooltip = optionalFieldHelper stringFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
stringFieldProfile :: FieldProfile sub y String
|
|
stringFieldProfile = FieldProfile
|
|
{ fpParse = Right
|
|
, fpRender = id
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input#$name$!name=$name$!type=text!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = \_name -> return ()
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
instance ToFormField String where
|
|
toFormField = stringField
|
|
instance ToFormField (Maybe String) where
|
|
toFormField = maybeStringField
|
|
|
|
intInput :: Integral i => String -> FormInput sub master i
|
|
intInput n =
|
|
mapFormXml fieldsToInput $
|
|
requiredFieldHelper intFieldProfile
|
|
{ fpName = Just n
|
|
} Nothing
|
|
|
|
intField :: Integral i => Html () -> Html () -> FormletField sub y i
|
|
intField l t = requiredFieldHelper intFieldProfile
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
maybeIntField :: Integral i =>
|
|
Html () -> Html () -> FormletField sub y (Maybe i)
|
|
maybeIntField l t = optionalFieldHelper intFieldProfile
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
intFieldProfile :: Integral i => FieldProfile sub y i
|
|
intFieldProfile = FieldProfile
|
|
{ fpParse = maybe (Left "Invalid integer") Right . readMayI
|
|
, fpRender = showI
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input#$name$!name=$name$!type=number!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = \_name -> return ()
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
where
|
|
showI x = show (fromIntegral x :: Integer)
|
|
readMayI s = case reads s of
|
|
(x, _):_ -> Just $ fromInteger x
|
|
[] -> Nothing
|
|
instance ToFormField Int where
|
|
toFormField = intField
|
|
instance ToFormField (Maybe Int) where
|
|
toFormField = maybeIntField
|
|
instance ToFormField Int64 where
|
|
toFormField = intField
|
|
instance ToFormField (Maybe Int64) where
|
|
toFormField = maybeIntField
|
|
|
|
doubleField :: Html () -> Html () -> FormletField sub y Double
|
|
doubleField l t = requiredFieldHelper doubleFieldProfile
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
maybeDoubleField :: Html () -> Html () -> FormletField sub y (Maybe Double)
|
|
maybeDoubleField l t = optionalFieldHelper doubleFieldProfile
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
doubleFieldProfile :: FieldProfile sub y Double
|
|
doubleFieldProfile = FieldProfile
|
|
{ fpParse = maybe (Left "Invalid number") Right . readMay
|
|
, fpRender = show
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input#$name$!name=$name$!type=number!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = \_name -> return ()
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
instance ToFormField Double where
|
|
toFormField = doubleField
|
|
instance ToFormField (Maybe Double) where
|
|
toFormField = maybeDoubleField
|
|
|
|
dayField :: Html () -> Html () -> FormletField sub y Day
|
|
dayField l t = requiredFieldHelper dayFieldProfile
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
maybeDayField :: Html () -> Html () -> FormletField sub y (Maybe Day)
|
|
maybeDayField l t = optionalFieldHelper dayFieldProfile
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
dayFieldProfile :: FieldProfile sub y Day
|
|
dayFieldProfile = FieldProfile
|
|
{ fpParse = parseDate
|
|
, fpRender = show
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input#$name$!name=$name$!type=date!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = const $ return ()
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
instance ToFormField Day where
|
|
toFormField = dayField
|
|
instance ToFormField (Maybe Day) where
|
|
toFormField = maybeDayField
|
|
|
|
jqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y Day
|
|
jqueryDayField l t = requiredFieldHelper jqueryDayFieldProfile
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
maybeJqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y (Maybe Day)
|
|
maybeJqueryDayField l t = optionalFieldHelper jqueryDayFieldProfile
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
jqueryDayFieldProfile :: Yesod y => FieldProfile sub y Day
|
|
jqueryDayFieldProfile = FieldProfile
|
|
{ fpParse = maybe
|
|
(Left "Invalid day, must be in YYYY-MM-DD format")
|
|
Right
|
|
. readMay
|
|
, fpRender = show
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input#$name$!name=$name$!type=date!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = \name -> do
|
|
addScript' urlJqueryJs
|
|
addScript' urlJqueryUiJs
|
|
addStylesheet' urlJqueryUiCss
|
|
addJavaScript [$hamlet|
|
|
$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})});
|
|
|]
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
|
|
-- | 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)
|
|
|
|
ifRight :: Either a b -> (b -> c) -> Either a c
|
|
ifRight e f = case e of
|
|
Left l -> Left l
|
|
Right r -> Right $ f r
|
|
|
|
showLeadingZero :: (Show a) => a -> String
|
|
showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t
|
|
|
|
parseUTCTime :: String -> Either String UTCTime
|
|
parseUTCTime s =
|
|
let (dateS, timeS) = break isSpace (dropWhile isSpace s)
|
|
in let dateE = (parseDate dateS)
|
|
in case dateE of
|
|
Left l -> Left l
|
|
Right date -> ifRight (parseTime timeS)
|
|
(\time -> UTCTime date (timeOfDayToTime time))
|
|
|
|
jqueryDayTimeField :: Yesod y => Html () -> Html () -> FormletField sub y UTCTime
|
|
jqueryDayTimeField l t = requiredFieldHelper jqueryDayTimeFieldProfile
|
|
{ fpLabel = l , fpTooltip = t }
|
|
|
|
parseDate :: String -> Either String Day
|
|
parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
|
|
. readMay . replace '/' '-'
|
|
|
|
|
|
-- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)
|
|
jqueryDayTimeUTCTime :: UTCTime -> String
|
|
jqueryDayTimeUTCTime (UTCTime day utcTime) =
|
|
let timeOfDay = timeToTimeOfDay utcTime
|
|
in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay
|
|
where
|
|
showTimeOfDay (TimeOfDay hour minute _) =
|
|
let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")
|
|
in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
|
|
|
|
jqueryDayTimeFieldProfile :: Yesod y => FieldProfile sub y UTCTime
|
|
jqueryDayTimeFieldProfile = FieldProfile
|
|
{ fpParse = parseUTCTime
|
|
, fpRender = jqueryDayTimeUTCTime
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input#$name$!name=$name$!type=date!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = \name -> do
|
|
addScript' urlJqueryJs
|
|
addScript' urlJqueryUiJs
|
|
addScript' urlJqueryUiDateTimePicker
|
|
addStylesheet' urlJqueryUiCss
|
|
addJavaScript [$hamlet|
|
|
$$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
|
|
|]
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
|
|
parseTime :: String -> Either String 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 [Char] TimeOfDay
|
|
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
|
| h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h
|
|
| m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m
|
|
| s < 0 || s > 59 = Left $ "Invalid second: " ++ show s
|
|
| otherwise = Right $ TimeOfDay h m s
|
|
where
|
|
h = read [h1, h2]
|
|
m = read [m1, m2]
|
|
s = fromInteger $ read [s1, s2]
|
|
|
|
timeField :: Html () -> Html () -> FormletField sub y TimeOfDay
|
|
timeField label tooltip = requiredFieldHelper timeFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
maybeTimeField :: Html () -> Html () -> FormletField sub y (Maybe TimeOfDay)
|
|
maybeTimeField label tooltip = optionalFieldHelper timeFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
timeFieldProfile :: FieldProfile sub y TimeOfDay
|
|
timeFieldProfile = FieldProfile
|
|
{ fpParse = parseTime
|
|
, fpRender = show
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input#$name$!name=$name$!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = const $ return ()
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
instance ToFormField TimeOfDay where
|
|
toFormField = timeField
|
|
instance ToFormField (Maybe TimeOfDay) where
|
|
toFormField = maybeTimeField
|
|
|
|
boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
|
|
boolField label tooltip orig = GForm $ \env _ -> do
|
|
name <- newFormIdent
|
|
let (res, val) =
|
|
if null env
|
|
then (FormMissing, fromMaybe False orig)
|
|
else case lookup name env of
|
|
Nothing -> (FormSuccess False, False)
|
|
Just _ -> (FormSuccess True, True)
|
|
let fi = FieldInfo
|
|
{ fiLabel = label
|
|
, fiTooltip = tooltip
|
|
, fiIdent = name
|
|
, fiInput = addBody [$hamlet|
|
|
%input#$name$!type=checkbox!name=$name$!:val:checked
|
|
|]
|
|
, fiErrors = case res of
|
|
FormFailure [x] -> Just $ string x
|
|
_ -> Nothing
|
|
}
|
|
return (res, [fi], UrlEncoded)
|
|
instance ToFormField Bool where
|
|
toFormField = boolField
|
|
|
|
htmlField :: Html () -> Html () -> FormletField sub y (Html ())
|
|
htmlField label tooltip = requiredFieldHelper htmlFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ()))
|
|
maybeHtmlField label tooltip = optionalFieldHelper htmlFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
htmlFieldProfile :: FieldProfile sub y (Html ())
|
|
htmlFieldProfile = FieldProfile
|
|
{ fpParse = Right . preEscapedString
|
|
, fpRender = U.toString . renderHtml
|
|
, fpHamlet = \name val _isReq -> [$hamlet|
|
|
%textarea.html#$name$!name=$name$ $val$
|
|
|]
|
|
, fpWidget = const $ return ()
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
instance ToFormField (Html ()) where
|
|
toFormField = htmlField
|
|
instance ToFormField (Maybe (Html ())) where
|
|
toFormField = maybeHtmlField
|
|
|
|
type Html' = Html ()
|
|
|
|
nicHtmlField :: Yesod y => Html () -> Html () -> FormletField sub y (Html ())
|
|
nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
maybeNicHtmlField :: Yesod y => Html () -> Html () -> FormletField sub y (Maybe (Html ()))
|
|
maybeNicHtmlField label tooltip = optionalFieldHelper nicHtmlFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
nicHtmlFieldProfile :: Yesod y => FieldProfile sub y (Html ())
|
|
nicHtmlFieldProfile = FieldProfile
|
|
{ fpParse = Right . preEscapedString
|
|
, fpRender = U.toString . renderHtml
|
|
, fpHamlet = \name val _isReq -> [$hamlet|
|
|
%textarea.html#$name$!name=$name$ $val$
|
|
|]
|
|
, fpWidget = \name -> do
|
|
addScript' urlNicEdit
|
|
addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|]
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
|
|
readMay :: Read a => String -> Maybe a
|
|
readMay s = case reads s of
|
|
(x, _):_ -> Just x
|
|
[] -> Nothing
|
|
|
|
selectField :: Eq x => [(x, String)]
|
|
-> Html () -> Html ()
|
|
-> Maybe x -> FormField sub master x
|
|
selectField pairs label tooltip initial = GForm $ \env _ -> do
|
|
i <- newFormIdent
|
|
let pairs' = zip [1 :: Int ..] pairs
|
|
let res = case lookup i env of
|
|
Nothing -> FormMissing
|
|
Just "none" -> FormFailure ["Field is required"]
|
|
Just x ->
|
|
case reads 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|
|
|
%select#$i$!name=$i$
|
|
%option!value=none
|
|
$forall pairs' pair
|
|
%option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
|
|
|]
|
|
let fi = FieldInfo
|
|
{ fiLabel = label
|
|
, fiTooltip = tooltip
|
|
, fiIdent = i
|
|
, fiInput = addBody input
|
|
, fiErrors = case res of
|
|
FormFailure [x] -> Just $ string x
|
|
_ -> Nothing
|
|
}
|
|
return (res, [fi], UrlEncoded)
|
|
|
|
maybeSelectField :: Eq x => [(x, String)]
|
|
-> Html () -> Html ()
|
|
-> Maybe x -> FormField sub master (Maybe x)
|
|
maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do
|
|
i <- newFormIdent
|
|
let pairs' = zip [1 :: Int ..] pairs
|
|
let res = case lookup i env of
|
|
Nothing -> FormMissing
|
|
Just "none" -> FormSuccess Nothing
|
|
Just x ->
|
|
case reads 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 = [$hamlet|
|
|
%select#$i$!name=$i$
|
|
%option!value=none
|
|
$forall pairs' pair
|
|
%option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
|
|
|]
|
|
let fi = FieldInfo
|
|
{ fiLabel = label
|
|
, fiTooltip = tooltip
|
|
, fiIdent = i
|
|
, fiInput = addBody input
|
|
, fiErrors = case res of
|
|
FormFailure [x] -> Just $ string x
|
|
_ -> Nothing
|
|
}
|
|
return (res, [fi], UrlEncoded)
|
|
|
|
--------------------- End prebuilt forms
|
|
|
|
--------------------- Begin prebuilt inputs
|
|
|
|
stringInput :: String -> FormInput sub master String
|
|
stringInput n =
|
|
mapFormXml fieldsToInput $
|
|
requiredFieldHelper stringFieldProfile
|
|
{ fpName = Just n
|
|
} Nothing
|
|
|
|
maybeStringInput :: String -> FormInput sub master (Maybe String)
|
|
maybeStringInput n =
|
|
mapFormXml fieldsToInput $
|
|
optionalFieldHelper stringFieldProfile
|
|
{ fpName = Just n
|
|
} Nothing
|
|
|
|
boolInput :: String -> FormInput sub master Bool
|
|
boolInput n = GForm $ \env _ -> return
|
|
(FormSuccess $ isJust $ lookup n env, return $ addBody [$hamlet|
|
|
%input#$n$!type=checkbox!name=$n$
|
|
|], UrlEncoded)
|
|
|
|
dayInput :: String -> FormInput sub master Day
|
|
dayInput n =
|
|
mapFormXml fieldsToInput $
|
|
requiredFieldHelper dayFieldProfile
|
|
{ fpName = Just n
|
|
} Nothing
|
|
|
|
maybeDayInput :: String -> FormInput sub master (Maybe Day)
|
|
maybeDayInput n =
|
|
mapFormXml fieldsToInput $
|
|
optionalFieldHelper dayFieldProfile
|
|
{ fpName = Just n
|
|
} Nothing
|
|
|
|
--------------------- End prebuilt inputs
|
|
|
|
-- | Get a unique identifier.
|
|
newFormIdent :: Monad m => StateT Int m String
|
|
newFormIdent = do
|
|
i <- get
|
|
let i' = i + 1
|
|
put i'
|
|
return $ "f" ++ show i'
|
|
|
|
runFormGeneric :: Env
|
|
-> FileEnv
|
|
-> GForm sub y xml a
|
|
-> GHandler sub y (FormResult a, xml, Enctype)
|
|
runFormGeneric env fe f = evalStateT (deform f env fe) 1
|
|
|
|
-- | Run a form against POST parameters.
|
|
runFormPost :: GForm sub y xml a
|
|
-> GHandler sub y (FormResult a, xml, Enctype)
|
|
runFormPost f = do
|
|
rr <- getRequest
|
|
(pp, files) <- liftIO $ reqRequestBody rr
|
|
runFormGeneric pp files f
|
|
|
|
-- | Run a form against POST parameters, disregarding the resulting HTML and
|
|
-- returning an error response on invalid input.
|
|
runFormPost' :: GForm sub y xml a -> GHandler sub y a
|
|
runFormPost' = helper <=< runFormPost
|
|
|
|
-- | Run a form against GET parameters, disregarding the resulting HTML and
|
|
-- returning an error response on invalid input.
|
|
runFormGet' :: GForm sub y xml a -> GHandler sub y a
|
|
runFormGet' = helper <=< runFormGet
|
|
|
|
helper :: (FormResult a, b, c) -> GHandler sub y a
|
|
helper (FormSuccess a, _, _) = return a
|
|
helper (FormFailure e, _, _) = invalidArgs e
|
|
helper (FormMissing, _, _) = invalidArgs ["No input found"]
|
|
|
|
-- | Run a form against GET parameters.
|
|
runFormGet :: GForm sub y xml a
|
|
-> GHandler sub y (FormResult a, xml, Enctype)
|
|
runFormGet f = do
|
|
gs <- reqGetParams `fmap` getRequest
|
|
runFormGeneric gs [] f
|
|
|
|
-- | This function allows two different monadic functions to share the same
|
|
-- input and have their results concatenated. This is particularly useful for
|
|
-- allowing 'mkToForm' to share its input with mkPersist.
|
|
share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
|
|
share2 f g a = do
|
|
f' <- f a
|
|
g' <- g a
|
|
return $ f' ++ g'
|
|
|
|
-- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.
|
|
mkToForm :: [EntityDef] -> Q [Dec]
|
|
mkToForm = mapM derive
|
|
where
|
|
getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z
|
|
getTFF' [] = Nothing
|
|
getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x
|
|
getTFF' (_:x) = getTFF' x
|
|
getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z
|
|
getLabel' [] = Nothing
|
|
getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x
|
|
getLabel' (_:x) = getLabel' x
|
|
getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z
|
|
getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x
|
|
getTooltip' (_:x) = getTooltip' x
|
|
getTooltip' [] = Nothing
|
|
derive :: EntityDef -> Q Dec
|
|
derive t = do
|
|
let cols = map ((getLabel &&& getTooltip) &&& getTFF) $ entityColumns t
|
|
ap <- [|(<*>)|]
|
|
just <- [|pure|]
|
|
nothing <- [|Nothing|]
|
|
let just' = just `AppE` ConE (mkName $ entityName t)
|
|
string' <- [|string|]
|
|
mfx <- [|mapFormXml|]
|
|
ftt <- [|fieldsToTable|]
|
|
let go_ = go ap just' string' mfx ftt
|
|
let c1 = Clause [ ConP (mkName "Nothing") []
|
|
]
|
|
(NormalB $ go_ $ zip cols $ map (const nothing) cols)
|
|
[]
|
|
xs <- mapM (const $ newName "x") cols
|
|
let xs' = map (AppE just . VarE) xs
|
|
let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)
|
|
$ map VarP xs]]
|
|
(NormalB $ go_ $ zip cols xs')
|
|
[]
|
|
return $ InstanceD [] (ConT ''ToForm
|
|
`AppT` ConT (mkName $ entityName t))
|
|
[FunD (mkName "toForm") [c1, c2]]
|
|
go ap just' string' mfx ftt a =
|
|
let x = foldl (ap' ap) just' $ map (go' string') a
|
|
in mfx `AppE` ftt `AppE` x
|
|
go' string' (((label, tooltip), tff), ex) =
|
|
let label' = string' `AppE` LitE (StringL label)
|
|
tooltip' = string' `AppE` LitE (StringL tooltip)
|
|
in VarE (mkName tff) `AppE` label'
|
|
`AppE` tooltip' `AppE` ex
|
|
ap' ap x y = InfixE (Just x) ap (Just y)
|
|
|
|
toLabel :: String -> String
|
|
toLabel "" = ""
|
|
toLabel (x:rest) = toUpper x : go rest
|
|
where
|
|
go "" = ""
|
|
go (c:cs)
|
|
| isUpper c = ' ' : c : go cs
|
|
| otherwise = c : go cs
|
|
|
|
jqueryAutocompleteField :: Yesod y =>
|
|
Route y -> Html () -> Html () -> FormletField sub y String
|
|
jqueryAutocompleteField src l t =
|
|
requiredFieldHelper $ (jqueryAutocompleteFieldProfile src)
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
maybeJqueryAutocompleteField :: Yesod y =>
|
|
Route y -> Html () -> Html () -> FormletField sub y (Maybe String)
|
|
maybeJqueryAutocompleteField src l t =
|
|
optionalFieldHelper $ (jqueryAutocompleteFieldProfile src)
|
|
{ fpLabel = l
|
|
, fpTooltip = t
|
|
}
|
|
|
|
jqueryAutocompleteFieldProfile :: Yesod y => Route y -> FieldProfile sub y String
|
|
jqueryAutocompleteFieldProfile src = FieldProfile
|
|
{ fpParse = Right
|
|
, fpRender = id
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = \name -> do
|
|
addScript' urlJqueryJs
|
|
addScript' urlJqueryUiJs
|
|
addStylesheet' urlJqueryUiCss
|
|
addJavaScript [$hamlet|
|
|
$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});
|
|
|]
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
|
|
emailFieldProfile :: FieldProfile s y String
|
|
emailFieldProfile = FieldProfile
|
|
{ fpParse = \s -> if Email.isValid s
|
|
then Right s
|
|
else Left "Invalid e-mail address"
|
|
, fpRender = id
|
|
, fpHamlet = \name val isReq -> [$hamlet|
|
|
%input#$name$!name=$name$!type=email!:isReq:required!value=$val$
|
|
|]
|
|
, fpWidget = const $ return ()
|
|
, fpName = Nothing
|
|
, fpLabel = mempty
|
|
, fpTooltip = mempty
|
|
}
|
|
|
|
emailField :: Html () -> Html () -> FormletField sub y String
|
|
emailField label tooltip = requiredFieldHelper emailFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
maybeEmailField :: Html () -> Html () -> FormletField sub y (Maybe String)
|
|
maybeEmailField label tooltip = optionalFieldHelper emailFieldProfile
|
|
{ fpLabel = label
|
|
, fpTooltip = tooltip
|
|
}
|
|
|
|
emailInput :: String -> FormInput sub master String
|
|
emailInput n =
|
|
mapFormXml fieldsToInput $
|
|
requiredFieldHelper emailFieldProfile
|
|
{ fpName = Just n
|
|
} Nothing
|
|
|
|
addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
|
|
addScript' f = do
|
|
y <- liftHandler getYesod
|
|
addScriptEither $ f y
|
|
|
|
addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()
|
|
addStylesheet' f = do
|
|
y <- liftHandler getYesod
|
|
addStylesheetEither $ f y
|