Code import
This commit is contained in:
Michael Snoyman
parent
eb37939b2a
commit
7945718290
25
LICENSE
Normal file
25
LICENSE
Normal file
@ -0,0 +1,25 @@
|
|||||||
|
The following license covers this documentation, and the source code, except
|
||||||
|
where otherwise indicated.
|
||||||
|
|
||||||
|
Copyright 2010, Michael Snoyman. All rights reserved.
|
||||||
|
|
||||||
|
Redistribution and use in source and binary forms, with or without
|
||||||
|
modification, are permitted provided that the following conditions are met:
|
||||||
|
|
||||||
|
* Redistributions of source code must retain the above copyright notice, this
|
||||||
|
list of conditions and the following disclaimer.
|
||||||
|
|
||||||
|
* Redistributions in binary form must reproduce the above copyright notice,
|
||||||
|
this list of conditions and the following disclaimer in the documentation
|
||||||
|
and/or other materials provided with the distribution.
|
||||||
|
|
||||||
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
|
||||||
|
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
||||||
|
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
|
||||||
|
EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||||
|
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||||
|
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
|
||||||
|
OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
|
||||||
|
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
|
||||||
|
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||||
|
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
7
Setup.lhs
Executable file
7
Setup.lhs
Executable file
@ -0,0 +1,7 @@
|
|||||||
|
#!/usr/bin/env runhaskell
|
||||||
|
|
||||||
|
> module Main where
|
||||||
|
> import Distribution.Simple
|
||||||
|
|
||||||
|
> main :: IO ()
|
||||||
|
> main = defaultMain
|
||||||
341
Yesod/Form.hs
Normal file
341
Yesod/Form.hs
Normal file
@ -0,0 +1,341 @@
|
|||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE PackageImports #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
-- | Parse forms (and query strings).
|
||||||
|
module Yesod.Form
|
||||||
|
( -- * Data types
|
||||||
|
GForm
|
||||||
|
, FormResult (..)
|
||||||
|
, Enctype (..)
|
||||||
|
, FormFieldSettings (..)
|
||||||
|
, Textarea (..)
|
||||||
|
, FieldInfo (..)
|
||||||
|
-- ** Utilities
|
||||||
|
, formFailures
|
||||||
|
-- * Type synonyms
|
||||||
|
, Form
|
||||||
|
, Formlet
|
||||||
|
, FormField
|
||||||
|
, FormletField
|
||||||
|
, FormInput
|
||||||
|
-- * Unwrapping functions
|
||||||
|
, generateForm
|
||||||
|
, runFormGet
|
||||||
|
, runFormMonadGet
|
||||||
|
, runFormPost
|
||||||
|
, runFormPostNoNonce
|
||||||
|
, runFormMonadPost
|
||||||
|
, runFormGet'
|
||||||
|
, runFormPost'
|
||||||
|
-- ** High-level form post unwrappers
|
||||||
|
, runFormTable
|
||||||
|
, runFormDivs
|
||||||
|
-- * Field/form helpers
|
||||||
|
, fieldsToTable
|
||||||
|
, fieldsToDivs
|
||||||
|
, fieldsToPlain
|
||||||
|
, checkForm
|
||||||
|
-- * Type classes
|
||||||
|
, module Yesod.Form.Class
|
||||||
|
-- * Template Haskell
|
||||||
|
, mkToForm
|
||||||
|
, module Yesod.Form.Fields
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Yesod.Form.Core
|
||||||
|
import Yesod.Form.Fields
|
||||||
|
import Yesod.Form.Class
|
||||||
|
import Yesod.Form.Profiles (Textarea (..))
|
||||||
|
import Yesod.Widget (GWidget)
|
||||||
|
|
||||||
|
import Text.Hamlet
|
||||||
|
import Yesod.Request
|
||||||
|
import Yesod.Handler
|
||||||
|
import Control.Applicative hiding (optional)
|
||||||
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
|
import "transformers" Control.Monad.IO.Class
|
||||||
|
import Control.Monad ((<=<))
|
||||||
|
import Language.Haskell.TH.Syntax
|
||||||
|
import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))
|
||||||
|
import Data.Char (toUpper, isUpper)
|
||||||
|
import Control.Arrow ((&&&))
|
||||||
|
import Data.List (group, sort)
|
||||||
|
|
||||||
|
-- | Display only the actual input widget code, without any decoration.
|
||||||
|
fieldsToPlain :: FormField sub y a -> Form sub y a
|
||||||
|
fieldsToPlain = mapFormXml $ mapM_ fiInput
|
||||||
|
|
||||||
|
-- | Display the label, tooltip, input code and errors in a single row of a
|
||||||
|
-- table.
|
||||||
|
fieldsToTable :: FormField sub y a -> Form sub y a
|
||||||
|
fieldsToTable = mapFormXml $ mapM_ go
|
||||||
|
where
|
||||||
|
go fi =
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%tr.$clazz.fi$
|
||||||
|
%td
|
||||||
|
%label!for=$fiIdent.fi$ $fiLabel.fi$
|
||||||
|
.tooltip $fiTooltip.fi$
|
||||||
|
%td
|
||||||
|
^fiInput.fi^
|
||||||
|
$maybe fiErrors.fi err
|
||||||
|
%td.errors $err$
|
||||||
|
|]
|
||||||
|
clazz fi = if fiRequired fi then "required" else "optional"
|
||||||
|
|
||||||
|
-- | Display the label, tooltip, input code and errors in a single div.
|
||||||
|
fieldsToDivs :: FormField sub y a -> Form sub y a
|
||||||
|
fieldsToDivs = mapFormXml $ mapM_ go
|
||||||
|
where
|
||||||
|
go fi =
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
.$clazz.fi$
|
||||||
|
%label!for=$fiIdent.fi$ $fiLabel.fi$
|
||||||
|
.tooltip $fiTooltip.fi$
|
||||||
|
^fiInput.fi^
|
||||||
|
$maybe fiErrors.fi err
|
||||||
|
%div.errors $err$
|
||||||
|
|]
|
||||||
|
clazz fi = if fiRequired fi then "required" else "optional"
|
||||||
|
|
||||||
|
-- | Run a form against POST parameters, without CSRF protection.
|
||||||
|
runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
|
||||||
|
runFormPostNoNonce f = do
|
||||||
|
rr <- getRequest
|
||||||
|
(pp, files) <- liftIO $ reqRequestBody rr
|
||||||
|
runFormGeneric pp files f
|
||||||
|
|
||||||
|
-- | Run a form against POST parameters.
|
||||||
|
--
|
||||||
|
-- This function includes CSRF protection by checking a nonce value. You must
|
||||||
|
-- therefore embed this nonce in the form as a hidden field; that is the
|
||||||
|
-- meaning of the fourth element in the tuple.
|
||||||
|
runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html)
|
||||||
|
runFormPost f = do
|
||||||
|
rr <- getRequest
|
||||||
|
(pp, files) <- liftIO $ reqRequestBody rr
|
||||||
|
nonce <- fmap reqNonce getRequest
|
||||||
|
(res, xml, enctype) <- runFormGeneric pp files f
|
||||||
|
let res' =
|
||||||
|
case res of
|
||||||
|
FormSuccess x ->
|
||||||
|
if lookup nonceName pp == Just nonce
|
||||||
|
then FormSuccess x
|
||||||
|
else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."]
|
||||||
|
_ -> res
|
||||||
|
return (res', xml, enctype, hidden nonce)
|
||||||
|
where
|
||||||
|
hidden nonce =
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%input!type=hidden!name=$nonceName$!value=$nonce$
|
||||||
|
|]
|
||||||
|
|
||||||
|
nonceName :: String
|
||||||
|
nonceName = "_nonce"
|
||||||
|
|
||||||
|
-- | Run a form against POST parameters. Please note that this does not provide
|
||||||
|
-- CSRF protection.
|
||||||
|
runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)
|
||||||
|
runFormMonadPost 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. Note: this does /not/ perform
|
||||||
|
-- CSRF protection.
|
||||||
|
runFormPost' :: GForm sub y xml a -> GHandler sub y a
|
||||||
|
runFormPost' f = do
|
||||||
|
rr <- getRequest
|
||||||
|
(pp, files) <- liftIO $ reqRequestBody rr
|
||||||
|
x <- runFormGeneric pp files f
|
||||||
|
helper x
|
||||||
|
|
||||||
|
-- | Create a table-styled form.
|
||||||
|
--
|
||||||
|
-- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of
|
||||||
|
-- some of the boiler-plate in creating forms. In particular, is automatically
|
||||||
|
-- creates the form element, sets the method, action and enctype attributes,
|
||||||
|
-- adds the CSRF-protection nonce hidden field and inserts a submit button.
|
||||||
|
runFormTable :: Route m -> String -> FormField s m a
|
||||||
|
-> GHandler s m (FormResult a, GWidget s m ())
|
||||||
|
runFormTable dest inputLabel form = do
|
||||||
|
(res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form
|
||||||
|
let widget' =
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%form!method=post!action=@dest@!enctype=$enctype$
|
||||||
|
%table
|
||||||
|
^widget^
|
||||||
|
%tr
|
||||||
|
%td!colspan=2
|
||||||
|
$nonce$
|
||||||
|
%input!type=submit!value=$inputLabel$
|
||||||
|
|]
|
||||||
|
return (res, widget')
|
||||||
|
|
||||||
|
-- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling.
|
||||||
|
runFormDivs :: Route m -> String -> FormField s m a
|
||||||
|
-> GHandler s m (FormResult a, GWidget s m ())
|
||||||
|
runFormDivs dest inputLabel form = do
|
||||||
|
(res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form
|
||||||
|
let widget' =
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%form!method=post!action=@dest@!enctype=$enctype$
|
||||||
|
^widget^
|
||||||
|
%div
|
||||||
|
$nonce$
|
||||||
|
%input!type=submit!value=$inputLabel$
|
||||||
|
|]
|
||||||
|
return (res, widget')
|
||||||
|
|
||||||
|
-- | 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"]
|
||||||
|
|
||||||
|
-- | Generate a form, feeding it no data. The third element in the result tuple
|
||||||
|
-- is a nonce hidden field.
|
||||||
|
generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html)
|
||||||
|
generateForm f = do
|
||||||
|
(_, b, c) <- runFormGeneric [] [] f
|
||||||
|
nonce <- fmap reqNonce getRequest
|
||||||
|
return (b, c,
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%input!type=hidden!name=$nonceName$!value=$nonce$
|
||||||
|
|])
|
||||||
|
|
||||||
|
-- | Run a form against GET parameters.
|
||||||
|
runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
|
||||||
|
runFormGet f = do
|
||||||
|
gs <- reqGetParams `fmap` getRequest
|
||||||
|
runFormGeneric gs [] f
|
||||||
|
|
||||||
|
runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype)
|
||||||
|
runFormMonadGet f = do
|
||||||
|
gs <- reqGetParams `fmap` getRequest
|
||||||
|
runFormGeneric gs [] f
|
||||||
|
|
||||||
|
-- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.
|
||||||
|
mkToForm :: PersistEntity v => v -> Q [Dec]
|
||||||
|
mkToForm =
|
||||||
|
fmap return . derive . entityDef
|
||||||
|
where
|
||||||
|
afterPeriod s =
|
||||||
|
case dropWhile (/= '.') s of
|
||||||
|
('.':t) -> t
|
||||||
|
_ -> s
|
||||||
|
beforePeriod s =
|
||||||
|
case break (== '.') s of
|
||||||
|
(t, '.':_) -> Just t
|
||||||
|
_ -> Nothing
|
||||||
|
getSuperclass (_, _, z) = getTFF' z >>= beforePeriod
|
||||||
|
getTFF (_, _, z) = maybe "toFormField" afterPeriod $ 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
|
||||||
|
getId (_, _, z) = fromMaybe "" $ getId' z
|
||||||
|
getId' (('i':'d':'=':x):_) = Just x
|
||||||
|
getId' (_:x) = getId' x
|
||||||
|
getId' [] = Nothing
|
||||||
|
getName (_, _, z) = fromMaybe "" $ getName' z
|
||||||
|
getName' (('n':'a':'m':'e':'=':x):_) = Just x
|
||||||
|
getName' (_:x) = getName' x
|
||||||
|
getName' [] = Nothing
|
||||||
|
derive :: EntityDef -> Q Dec
|
||||||
|
derive t = do
|
||||||
|
let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t
|
||||||
|
ap <- [|(<*>)|]
|
||||||
|
just <- [|pure|]
|
||||||
|
nothing <- [|Nothing|]
|
||||||
|
let just' = just `AppE` ConE (mkName $ entityName t)
|
||||||
|
string' <- [|string|]
|
||||||
|
ftt <- [|fieldsToTable|]
|
||||||
|
ffs' <- [|FormFieldSettings|]
|
||||||
|
let stm "" = nothing
|
||||||
|
stm x = just `AppE` LitE (StringL x)
|
||||||
|
let go_ = go ap just' ffs' stm string' 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')
|
||||||
|
[]
|
||||||
|
let y = mkName "y"
|
||||||
|
let ctx = map (\x -> ClassP (mkName x) [VarT y])
|
||||||
|
$ map head $ group $ sort
|
||||||
|
$ mapMaybe getSuperclass
|
||||||
|
$ entityColumns t
|
||||||
|
return $ InstanceD ctx ( ConT ''ToForm
|
||||||
|
`AppT` ConT (mkName $ entityName t)
|
||||||
|
`AppT` VarT y)
|
||||||
|
[FunD (mkName "toForm") [c1, c2]]
|
||||||
|
go ap just' ffs' stm string' ftt a =
|
||||||
|
let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a
|
||||||
|
in ftt `AppE` x
|
||||||
|
go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) =
|
||||||
|
let label' = LitE $ StringL label
|
||||||
|
tooltip' = string' `AppE` LitE (StringL tooltip)
|
||||||
|
ffs = ffs' `AppE`
|
||||||
|
label' `AppE`
|
||||||
|
tooltip' `AppE`
|
||||||
|
(stm theId) `AppE`
|
||||||
|
(stm name)
|
||||||
|
in VarE (mkName tff) `AppE` ffs `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
|
||||||
|
|
||||||
|
formFailures :: FormResult a -> Maybe [String]
|
||||||
|
formFailures (FormFailure x) = Just x
|
||||||
|
formFailures _ = Nothing
|
||||||
61
Yesod/Form/Class.hs
Normal file
61
Yesod/Form/Class.hs
Normal file
@ -0,0 +1,61 @@
|
|||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
|
module Yesod.Form.Class
|
||||||
|
( ToForm (..)
|
||||||
|
, ToFormField (..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Text.Hamlet
|
||||||
|
import Yesod.Form.Fields
|
||||||
|
import Yesod.Form.Core
|
||||||
|
import Yesod.Form.Profiles (Textarea)
|
||||||
|
import Data.Int (Int64)
|
||||||
|
import Data.Time (Day, TimeOfDay)
|
||||||
|
|
||||||
|
class ToForm a y where
|
||||||
|
toForm :: Formlet sub y a
|
||||||
|
class ToFormField a y where
|
||||||
|
toFormField :: FormFieldSettings -> FormletField sub y a
|
||||||
|
|
||||||
|
instance ToFormField String y where
|
||||||
|
toFormField = stringField
|
||||||
|
instance ToFormField (Maybe String) y where
|
||||||
|
toFormField = maybeStringField
|
||||||
|
|
||||||
|
instance ToFormField Int y where
|
||||||
|
toFormField = intField
|
||||||
|
instance ToFormField (Maybe Int) y where
|
||||||
|
toFormField = maybeIntField
|
||||||
|
instance ToFormField Int64 y where
|
||||||
|
toFormField = intField
|
||||||
|
instance ToFormField (Maybe Int64) y where
|
||||||
|
toFormField = maybeIntField
|
||||||
|
|
||||||
|
instance ToFormField Double y where
|
||||||
|
toFormField = doubleField
|
||||||
|
instance ToFormField (Maybe Double) y where
|
||||||
|
toFormField = maybeDoubleField
|
||||||
|
|
||||||
|
instance ToFormField Day y where
|
||||||
|
toFormField = dayField
|
||||||
|
instance ToFormField (Maybe Day) y where
|
||||||
|
toFormField = maybeDayField
|
||||||
|
|
||||||
|
instance ToFormField TimeOfDay y where
|
||||||
|
toFormField = timeField
|
||||||
|
instance ToFormField (Maybe TimeOfDay) y where
|
||||||
|
toFormField = maybeTimeField
|
||||||
|
|
||||||
|
instance ToFormField Bool y where
|
||||||
|
toFormField = boolField
|
||||||
|
|
||||||
|
instance ToFormField Html y where
|
||||||
|
toFormField = htmlField
|
||||||
|
instance ToFormField (Maybe Html) y where
|
||||||
|
toFormField = maybeHtmlField
|
||||||
|
|
||||||
|
instance ToFormField Textarea y where
|
||||||
|
toFormField = textareaField
|
||||||
|
instance ToFormField (Maybe Textarea) y where
|
||||||
|
toFormField = maybeTextareaField
|
||||||
369
Yesod/Form/Core.hs
Normal file
369
Yesod/Form/Core.hs
Normal file
@ -0,0 +1,369 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
|
-- | Users of the forms library should not need to use this module in general.
|
||||||
|
-- It is intended only for writing custom forms and form fields.
|
||||||
|
module Yesod.Form.Core
|
||||||
|
( FormResult (..)
|
||||||
|
, GForm (..)
|
||||||
|
, newFormIdent
|
||||||
|
, deeperFormIdent
|
||||||
|
, shallowerFormIdent
|
||||||
|
, Env
|
||||||
|
, FileEnv
|
||||||
|
, Enctype (..)
|
||||||
|
, Ints (..)
|
||||||
|
, requiredFieldHelper
|
||||||
|
, optionalFieldHelper
|
||||||
|
, fieldsToInput
|
||||||
|
, mapFormXml
|
||||||
|
, checkForm
|
||||||
|
, checkField
|
||||||
|
, askParams
|
||||||
|
, askFiles
|
||||||
|
, liftForm
|
||||||
|
, IsForm (..)
|
||||||
|
, RunForm (..)
|
||||||
|
, GFormMonad
|
||||||
|
-- * Data types
|
||||||
|
, FieldInfo (..)
|
||||||
|
, FormFieldSettings (..)
|
||||||
|
, FieldProfile (..)
|
||||||
|
-- * Type synonyms
|
||||||
|
, Form
|
||||||
|
, Formlet
|
||||||
|
, FormField
|
||||||
|
, FormletField
|
||||||
|
, FormInput
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Trans.State
|
||||||
|
import Control.Monad.Trans.Reader
|
||||||
|
import Control.Monad.Trans.Writer
|
||||||
|
import Control.Monad.Trans.Class (lift)
|
||||||
|
import Yesod.Handler
|
||||||
|
import Yesod.Widget
|
||||||
|
import Data.Monoid (Monoid (..))
|
||||||
|
import Control.Applicative
|
||||||
|
import Yesod.Request
|
||||||
|
import Control.Monad (liftM)
|
||||||
|
import Text.Hamlet
|
||||||
|
import Data.String
|
||||||
|
import Control.Monad (join)
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
instance Monoid m => Monoid (FormResult m) where
|
||||||
|
mempty = pure mempty
|
||||||
|
mappend x y = mappend <$> x <*> y
|
||||||
|
|
||||||
|
-- | The encoding type required by a form. The 'Show' instance produces values
|
||||||
|
-- that can be inserted directly into HTML.
|
||||||
|
data Enctype = UrlEncoded | Multipart
|
||||||
|
deriving (Eq, Enum, Bounded)
|
||||||
|
instance ToHtml Enctype where
|
||||||
|
toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded"
|
||||||
|
toHtml Multipart = unsafeByteString "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
|
||||||
|
|
||||||
|
incrInts :: Ints -> Ints
|
||||||
|
incrInts (IntSingle i) = IntSingle $ i + 1
|
||||||
|
incrInts (IntCons i is) = (i + 1) `IntCons` is
|
||||||
|
|
||||||
|
-- | 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 s m xml a = GForm
|
||||||
|
{ deform :: FormInner s m (FormResult a, xml, Enctype)
|
||||||
|
}
|
||||||
|
|
||||||
|
type GFormMonad s m a = WriterT Enctype (FormInner s m) a
|
||||||
|
|
||||||
|
type FormInner s m =
|
||||||
|
StateT Ints (
|
||||||
|
ReaderT Env (
|
||||||
|
ReaderT FileEnv (
|
||||||
|
GHandler s m
|
||||||
|
)))
|
||||||
|
|
||||||
|
type Env = [(String, String)]
|
||||||
|
type FileEnv = [(String, FileInfo)]
|
||||||
|
|
||||||
|
-- | Get a unique identifier.
|
||||||
|
newFormIdent :: Monad m => StateT Ints m String
|
||||||
|
newFormIdent = do
|
||||||
|
i <- get
|
||||||
|
let i' = incrInts i
|
||||||
|
put i'
|
||||||
|
return $ 'f' : show i'
|
||||||
|
|
||||||
|
deeperFormIdent :: Monad m => StateT Ints m ()
|
||||||
|
deeperFormIdent = do
|
||||||
|
i <- get
|
||||||
|
let i' = 1 `IntCons` incrInts i
|
||||||
|
put i'
|
||||||
|
|
||||||
|
shallowerFormIdent :: Monad m => StateT Ints m ()
|
||||||
|
shallowerFormIdent = do
|
||||||
|
IntCons _ i <- get
|
||||||
|
put i
|
||||||
|
|
||||||
|
instance Monoid xml => Functor (GForm sub url xml) where
|
||||||
|
fmap f (GForm g) =
|
||||||
|
GForm $ liftM (first3 $ fmap f) g
|
||||||
|
where
|
||||||
|
first3 f' (x, y, z) = (f' x, y, z)
|
||||||
|
|
||||||
|
instance Monoid xml => Applicative (GForm sub url xml) where
|
||||||
|
pure a = GForm $ return (pure a, mempty, mempty)
|
||||||
|
(GForm f) <*> (GForm g) = GForm $ do
|
||||||
|
(f1, f2, f3) <- f
|
||||||
|
(g1, g2, g3) <- g
|
||||||
|
return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)
|
||||||
|
|
||||||
|
-- | Create a required field (ie, one that cannot be blank) from a
|
||||||
|
-- 'FieldProfile'.
|
||||||
|
requiredFieldHelper
|
||||||
|
:: IsForm f
|
||||||
|
=> FieldProfile (FormSub f) (FormMaster f) (FormType f)
|
||||||
|
-> FormFieldSettings
|
||||||
|
-> Maybe (FormType f)
|
||||||
|
-> f
|
||||||
|
requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do
|
||||||
|
env <- lift ask
|
||||||
|
let (FormFieldSettings label tooltip theId' name') = ffs
|
||||||
|
name <- maybe newFormIdent return name'
|
||||||
|
theId <- maybe newFormIdent return theId'
|
||||||
|
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 = string label
|
||||||
|
, fiTooltip = tooltip
|
||||||
|
, fiIdent = theId
|
||||||
|
, fiInput = mkWidget theId name val True
|
||||||
|
, fiErrors = case res of
|
||||||
|
FormFailure [x] -> Just $ string x
|
||||||
|
_ -> Nothing
|
||||||
|
, fiRequired = True
|
||||||
|
}
|
||||||
|
let res' = case res of
|
||||||
|
FormFailure [e] -> FormFailure [label ++ ": " ++ e]
|
||||||
|
_ -> res
|
||||||
|
return (res', fi, UrlEncoded)
|
||||||
|
|
||||||
|
class IsForm f where
|
||||||
|
type FormSub f
|
||||||
|
type FormMaster f
|
||||||
|
type FormType f
|
||||||
|
toForm :: FormInner
|
||||||
|
(FormSub f)
|
||||||
|
(FormMaster f)
|
||||||
|
(FormResult (FormType f),
|
||||||
|
FieldInfo (FormSub f) (FormMaster f),
|
||||||
|
Enctype) -> f
|
||||||
|
instance IsForm (FormField s m a) where
|
||||||
|
type FormSub (FormField s m a) = s
|
||||||
|
type FormMaster (FormField s m a) = m
|
||||||
|
type FormType (FormField s m a) = a
|
||||||
|
toForm x = GForm $ do
|
||||||
|
(a, b, c) <- x
|
||||||
|
return (a, [b], c)
|
||||||
|
instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where
|
||||||
|
type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s
|
||||||
|
type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m
|
||||||
|
type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a
|
||||||
|
toForm x = do
|
||||||
|
(res, fi, enctype) <- lift x
|
||||||
|
tell enctype
|
||||||
|
return (res, fi)
|
||||||
|
|
||||||
|
class RunForm f where
|
||||||
|
type RunFormSub f
|
||||||
|
type RunFormMaster f
|
||||||
|
type RunFormType f
|
||||||
|
runFormGeneric :: Env -> FileEnv -> f
|
||||||
|
-> GHandler (RunFormSub f)
|
||||||
|
(RunFormMaster f)
|
||||||
|
(RunFormType f)
|
||||||
|
|
||||||
|
instance RunForm (GForm s m xml a) where
|
||||||
|
type RunFormSub (GForm s m xml a) = s
|
||||||
|
type RunFormMaster (GForm s m xml a) = m
|
||||||
|
type RunFormType (GForm s m xml a) =
|
||||||
|
(FormResult a, xml, Enctype)
|
||||||
|
runFormGeneric env fe (GForm f) =
|
||||||
|
runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe
|
||||||
|
|
||||||
|
instance RunForm (GFormMonad s m a) where
|
||||||
|
type RunFormSub (GFormMonad s m a) = s
|
||||||
|
type RunFormMaster (GFormMonad s m a) = m
|
||||||
|
type RunFormType (GFormMonad s m a) = (a, Enctype)
|
||||||
|
runFormGeneric e fe f =
|
||||||
|
runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe
|
||||||
|
|
||||||
|
-- | Create an optional field (ie, one that can be blank) from a
|
||||||
|
-- 'FieldProfile'.
|
||||||
|
optionalFieldHelper
|
||||||
|
:: (IsForm f, Maybe b ~ FormType f)
|
||||||
|
=> FieldProfile (FormSub f) (FormMaster f) b
|
||||||
|
-> FormFieldSettings
|
||||||
|
-> Maybe (Maybe b)
|
||||||
|
-> f
|
||||||
|
optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do
|
||||||
|
env <- lift ask
|
||||||
|
let (FormFieldSettings label tooltip theId' name') = ffs
|
||||||
|
let orig = join orig'
|
||||||
|
name <- maybe newFormIdent return name'
|
||||||
|
theId <- maybe newFormIdent return theId'
|
||||||
|
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 = string label
|
||||||
|
, fiTooltip = tooltip
|
||||||
|
, fiIdent = theId
|
||||||
|
, fiInput = mkWidget theId name val False
|
||||||
|
, fiErrors = case res of
|
||||||
|
FormFailure x -> Just $ string $ unlines x
|
||||||
|
_ -> Nothing
|
||||||
|
, fiRequired = False
|
||||||
|
}
|
||||||
|
let res' = case res of
|
||||||
|
FormFailure [e] -> FormFailure [label ++ ": " ++ e]
|
||||||
|
_ -> res
|
||||||
|
return (res', fi, UrlEncoded)
|
||||||
|
|
||||||
|
fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]
|
||||||
|
fieldsToInput = map fiInput
|
||||||
|
|
||||||
|
-- | Convert the XML in a 'GForm'.
|
||||||
|
mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
|
||||||
|
mapFormXml f (GForm g) = GForm $ do
|
||||||
|
(res, xml, enc) <- g
|
||||||
|
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
|
||||||
|
, fiRequired :: Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
data FormFieldSettings = FormFieldSettings
|
||||||
|
{ ffsLabel :: String
|
||||||
|
, ffsTooltip :: Html
|
||||||
|
, ffsId :: Maybe String
|
||||||
|
, ffsName :: Maybe String
|
||||||
|
}
|
||||||
|
instance IsString FormFieldSettings where
|
||||||
|
fromString s = FormFieldSettings s mempty Nothing Nothing
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
-- | ID, name, value, required
|
||||||
|
, fpWidget :: String -> String -> String -> Bool -> GWidget sub y ()
|
||||||
|
}
|
||||||
|
|
||||||
|
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 ()]
|
||||||
|
|
||||||
|
-- | Add a validation check to a form.
|
||||||
|
--
|
||||||
|
-- Note that if there is a validation error, this message will /not/
|
||||||
|
-- automatically appear on the form; for that, you need to use 'checkField'.
|
||||||
|
checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b
|
||||||
|
checkForm f (GForm form) = GForm $ do
|
||||||
|
(res, xml, enc) <- form
|
||||||
|
let res' = case res of
|
||||||
|
FormSuccess a -> f a
|
||||||
|
FormFailure e -> FormFailure e
|
||||||
|
FormMissing -> FormMissing
|
||||||
|
return (res', xml, enc)
|
||||||
|
|
||||||
|
-- | Add a validation check to a 'FormField'.
|
||||||
|
--
|
||||||
|
-- Unlike 'checkForm', the validation error will appear in the generated HTML
|
||||||
|
-- of the form.
|
||||||
|
checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b
|
||||||
|
checkField f (GForm form) = GForm $ do
|
||||||
|
(res, xml, enc) <- form
|
||||||
|
let (res', merr) =
|
||||||
|
case res of
|
||||||
|
FormSuccess a ->
|
||||||
|
case f a of
|
||||||
|
Left e -> (FormFailure [e], Just e)
|
||||||
|
Right x -> (FormSuccess x, Nothing)
|
||||||
|
FormFailure e -> (FormFailure e, Nothing)
|
||||||
|
FormMissing -> (FormMissing, Nothing)
|
||||||
|
let xml' =
|
||||||
|
case merr of
|
||||||
|
Nothing -> xml
|
||||||
|
Just err -> flip map xml $ \fi -> fi
|
||||||
|
{ fiErrors = Just $
|
||||||
|
case fiErrors fi of
|
||||||
|
Nothing -> string err
|
||||||
|
Just x -> x
|
||||||
|
}
|
||||||
|
return (res', xml', enc)
|
||||||
|
|
||||||
|
askParams :: Monad m => StateT Ints (ReaderT Env m) Env
|
||||||
|
askParams = lift ask
|
||||||
|
|
||||||
|
askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv
|
||||||
|
askFiles = lift $ lift ask
|
||||||
|
|
||||||
|
liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a
|
||||||
|
liftForm = lift . lift . lift
|
||||||
409
Yesod/Form/Fields.hs
Normal file
409
Yesod/Form/Fields.hs
Normal file
@ -0,0 +1,409 @@
|
|||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
module Yesod.Form.Fields
|
||||||
|
( -- * Fields
|
||||||
|
-- ** Required
|
||||||
|
stringField
|
||||||
|
, passwordField
|
||||||
|
, textareaField
|
||||||
|
, hiddenField
|
||||||
|
, intField
|
||||||
|
, doubleField
|
||||||
|
, dayField
|
||||||
|
, timeField
|
||||||
|
, htmlField
|
||||||
|
, selectField
|
||||||
|
, boolField
|
||||||
|
, emailField
|
||||||
|
, searchField
|
||||||
|
, urlField
|
||||||
|
, fileField
|
||||||
|
-- ** Optional
|
||||||
|
, maybeStringField
|
||||||
|
, maybePasswordField
|
||||||
|
, maybeTextareaField
|
||||||
|
, maybeHiddenField
|
||||||
|
, maybeIntField
|
||||||
|
, maybeDoubleField
|
||||||
|
, maybeDayField
|
||||||
|
, maybeTimeField
|
||||||
|
, maybeHtmlField
|
||||||
|
, maybeSelectField
|
||||||
|
, maybeEmailField
|
||||||
|
, maybeSearchField
|
||||||
|
, maybeUrlField
|
||||||
|
, maybeFileField
|
||||||
|
-- * Inputs
|
||||||
|
-- ** Required
|
||||||
|
, stringInput
|
||||||
|
, intInput
|
||||||
|
, boolInput
|
||||||
|
, dayInput
|
||||||
|
, emailInput
|
||||||
|
, urlInput
|
||||||
|
-- ** Optional
|
||||||
|
, maybeStringInput
|
||||||
|
, maybeDayInput
|
||||||
|
, maybeIntInput
|
||||||
|
) 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)
|
||||||
|
|
||||||
|
stringField :: (IsForm f, FormType f ~ String)
|
||||||
|
=> FormFieldSettings -> Maybe String -> f
|
||||||
|
stringField = requiredFieldHelper stringFieldProfile
|
||||||
|
|
||||||
|
maybeStringField :: (IsForm f, FormType f ~ Maybe String)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe String) -> f
|
||||||
|
maybeStringField = optionalFieldHelper stringFieldProfile
|
||||||
|
|
||||||
|
passwordField :: (IsForm f, FormType f ~ String)
|
||||||
|
=> FormFieldSettings -> Maybe String -> f
|
||||||
|
passwordField = requiredFieldHelper passwordFieldProfile
|
||||||
|
|
||||||
|
maybePasswordField :: (IsForm f, FormType f ~ Maybe String)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe String) -> f
|
||||||
|
maybePasswordField = optionalFieldHelper passwordFieldProfile
|
||||||
|
|
||||||
|
intInput :: Integral i => String -> FormInput sub master i
|
||||||
|
intInput n =
|
||||||
|
mapFormXml fieldsToInput $
|
||||||
|
requiredFieldHelper intFieldProfile (nameSettings n) Nothing
|
||||||
|
|
||||||
|
maybeIntInput :: Integral i => String -> FormInput sub master (Maybe i)
|
||||||
|
maybeIntInput n =
|
||||||
|
mapFormXml fieldsToInput $
|
||||||
|
optionalFieldHelper intFieldProfile (nameSettings n) Nothing
|
||||||
|
|
||||||
|
intField :: (Integral (FormType f), IsForm f)
|
||||||
|
=> FormFieldSettings -> Maybe (FormType f) -> f
|
||||||
|
intField = requiredFieldHelper intFieldProfile
|
||||||
|
|
||||||
|
maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f)
|
||||||
|
=> FormFieldSettings -> Maybe (FormType f) -> f
|
||||||
|
maybeIntField = optionalFieldHelper intFieldProfile
|
||||||
|
|
||||||
|
doubleField :: (IsForm f, FormType f ~ Double)
|
||||||
|
=> FormFieldSettings -> Maybe Double -> f
|
||||||
|
doubleField = requiredFieldHelper doubleFieldProfile
|
||||||
|
|
||||||
|
maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe Double) -> f
|
||||||
|
maybeDoubleField = optionalFieldHelper doubleFieldProfile
|
||||||
|
|
||||||
|
dayField :: (IsForm f, FormType f ~ Day)
|
||||||
|
=> FormFieldSettings -> Maybe Day -> f
|
||||||
|
dayField = requiredFieldHelper dayFieldProfile
|
||||||
|
|
||||||
|
maybeDayField :: (IsForm f, FormType f ~ Maybe Day)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe Day) -> f
|
||||||
|
maybeDayField = optionalFieldHelper dayFieldProfile
|
||||||
|
|
||||||
|
timeField :: (IsForm f, FormType f ~ TimeOfDay)
|
||||||
|
=> FormFieldSettings -> Maybe TimeOfDay -> f
|
||||||
|
timeField = requiredFieldHelper timeFieldProfile
|
||||||
|
|
||||||
|
maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f
|
||||||
|
maybeTimeField = optionalFieldHelper timeFieldProfile
|
||||||
|
|
||||||
|
boolField :: (IsForm f, FormType f ~ Bool)
|
||||||
|
=> FormFieldSettings -> Maybe Bool -> f
|
||||||
|
boolField ffs orig = toForm $ 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 = string label
|
||||||
|
, fiTooltip = tooltip
|
||||||
|
, fiIdent = theId
|
||||||
|
, fiInput =
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%input#$theId$!type=checkbox!name=$name$!:val:checked
|
||||||
|
|]
|
||||||
|
, fiErrors = case res of
|
||||||
|
FormFailure [x] -> Just $ string x
|
||||||
|
_ -> Nothing
|
||||||
|
, fiRequired = True
|
||||||
|
}
|
||||||
|
return (res, fi, UrlEncoded)
|
||||||
|
|
||||||
|
htmlField :: (IsForm f, FormType f ~ Html)
|
||||||
|
=> FormFieldSettings -> Maybe Html -> f
|
||||||
|
htmlField = requiredFieldHelper htmlFieldProfile
|
||||||
|
|
||||||
|
maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe Html) -> f
|
||||||
|
maybeHtmlField = optionalFieldHelper htmlFieldProfile
|
||||||
|
|
||||||
|
selectField :: (Eq x, IsForm f, FormType f ~ x)
|
||||||
|
=> [(x, String)]
|
||||||
|
-> FormFieldSettings
|
||||||
|
-> Maybe x
|
||||||
|
-> f
|
||||||
|
selectField pairs ffs initial = toForm $ 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 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#$theId$!name=$name$
|
||||||
|
%option!value=none
|
||||||
|
$forall pairs' pair
|
||||||
|
%option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
|
||||||
|
|]
|
||||||
|
let fi = FieldInfo
|
||||||
|
{ fiLabel = string label
|
||||||
|
, fiTooltip = tooltip
|
||||||
|
, fiIdent = theId
|
||||||
|
, fiInput = input
|
||||||
|
, fiErrors = case res of
|
||||||
|
FormFailure [x] -> Just $ string x
|
||||||
|
_ -> Nothing
|
||||||
|
, fiRequired = True
|
||||||
|
}
|
||||||
|
return (res, fi, UrlEncoded)
|
||||||
|
|
||||||
|
maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)
|
||||||
|
=> [(x, String)]
|
||||||
|
-> FormFieldSettings
|
||||||
|
-> Maybe (FormType f)
|
||||||
|
-> f
|
||||||
|
maybeSelectField pairs ffs initial' = toForm $ 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 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#$theId$!name=$name$
|
||||||
|
%option!value=none
|
||||||
|
$forall pairs' pair
|
||||||
|
%option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
|
||||||
|
|]
|
||||||
|
let fi = FieldInfo
|
||||||
|
{ fiLabel = string label
|
||||||
|
, fiTooltip = tooltip
|
||||||
|
, fiIdent = theId
|
||||||
|
, fiInput = input
|
||||||
|
, fiErrors = case res of
|
||||||
|
FormFailure [x] -> Just $ string x
|
||||||
|
_ -> Nothing
|
||||||
|
, fiRequired = False
|
||||||
|
}
|
||||||
|
return (res, fi, UrlEncoded)
|
||||||
|
|
||||||
|
stringInput :: String -> FormInput sub master String
|
||||||
|
stringInput n =
|
||||||
|
mapFormXml fieldsToInput $
|
||||||
|
requiredFieldHelper stringFieldProfile (nameSettings n) Nothing
|
||||||
|
|
||||||
|
maybeStringInput :: String -> FormInput sub master (Maybe String)
|
||||||
|
maybeStringInput n =
|
||||||
|
mapFormXml fieldsToInput $
|
||||||
|
optionalFieldHelper stringFieldProfile (nameSettings n) Nothing
|
||||||
|
|
||||||
|
boolInput :: String -> 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 =
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%input#$n$!type=checkbox!name=$n$
|
||||||
|
|]
|
||||||
|
return (res, [xml], UrlEncoded)
|
||||||
|
|
||||||
|
dayInput :: String -> FormInput sub master Day
|
||||||
|
dayInput n =
|
||||||
|
mapFormXml fieldsToInput $
|
||||||
|
requiredFieldHelper dayFieldProfile (nameSettings n) Nothing
|
||||||
|
|
||||||
|
maybeDayInput :: String -> FormInput sub master (Maybe Day)
|
||||||
|
maybeDayInput n =
|
||||||
|
mapFormXml fieldsToInput $
|
||||||
|
optionalFieldHelper dayFieldProfile (nameSettings n) Nothing
|
||||||
|
|
||||||
|
nameSettings :: String -> FormFieldSettings
|
||||||
|
nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
|
||||||
|
|
||||||
|
urlField :: (IsForm f, FormType f ~ String)
|
||||||
|
=> FormFieldSettings -> Maybe String -> f
|
||||||
|
urlField = requiredFieldHelper urlFieldProfile
|
||||||
|
|
||||||
|
maybeUrlField :: (IsForm f, FormType f ~ Maybe String)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe String) -> f
|
||||||
|
maybeUrlField = optionalFieldHelper urlFieldProfile
|
||||||
|
|
||||||
|
urlInput :: String -> FormInput sub master String
|
||||||
|
urlInput n =
|
||||||
|
mapFormXml fieldsToInput $
|
||||||
|
requiredFieldHelper urlFieldProfile (nameSettings n) Nothing
|
||||||
|
|
||||||
|
emailField :: (IsForm f, FormType f ~ String)
|
||||||
|
=> FormFieldSettings -> Maybe String -> f
|
||||||
|
emailField = requiredFieldHelper emailFieldProfile
|
||||||
|
|
||||||
|
maybeEmailField :: (IsForm f, FormType f ~ Maybe String)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe String) -> f
|
||||||
|
maybeEmailField = optionalFieldHelper emailFieldProfile
|
||||||
|
|
||||||
|
emailInput :: String -> FormInput sub master String
|
||||||
|
emailInput n =
|
||||||
|
mapFormXml fieldsToInput $
|
||||||
|
requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
|
||||||
|
|
||||||
|
searchField :: (IsForm f, FormType f ~ String)
|
||||||
|
=> AutoFocus -> FormFieldSettings -> Maybe String -> f
|
||||||
|
searchField = requiredFieldHelper . searchFieldProfile
|
||||||
|
|
||||||
|
maybeSearchField :: (IsForm f, FormType f ~ Maybe String)
|
||||||
|
=> AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> f
|
||||||
|
maybeSearchField = optionalFieldHelper . searchFieldProfile
|
||||||
|
|
||||||
|
textareaField :: (IsForm f, FormType f ~ Textarea)
|
||||||
|
=> FormFieldSettings -> Maybe Textarea -> f
|
||||||
|
textareaField = requiredFieldHelper textareaFieldProfile
|
||||||
|
|
||||||
|
maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)
|
||||||
|
maybeTextareaField = optionalFieldHelper textareaFieldProfile
|
||||||
|
|
||||||
|
hiddenField :: (IsForm f, FormType f ~ String)
|
||||||
|
=> FormFieldSettings -> Maybe String -> f
|
||||||
|
hiddenField = requiredFieldHelper hiddenFieldProfile
|
||||||
|
|
||||||
|
maybeHiddenField :: (IsForm f, FormType f ~ Maybe String)
|
||||||
|
=> FormFieldSettings -> Maybe (Maybe String) -> f
|
||||||
|
maybeHiddenField = optionalFieldHelper hiddenFieldProfile
|
||||||
|
|
||||||
|
fileField :: (IsForm f, FormType f ~ FileInfo)
|
||||||
|
=> FormFieldSettings -> f
|
||||||
|
fileField ffs = toForm $ 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 = string label
|
||||||
|
, fiTooltip = tooltip
|
||||||
|
, fiIdent = theId
|
||||||
|
, fiInput = fileWidget theId name True
|
||||||
|
, fiErrors = case res of
|
||||||
|
FormFailure [x] -> Just $ string x
|
||||||
|
_ -> Nothing
|
||||||
|
, fiRequired = True
|
||||||
|
}
|
||||||
|
let res' = case res of
|
||||||
|
FormFailure [e] -> FormFailure [label ++ ": " ++ e]
|
||||||
|
_ -> res
|
||||||
|
return (res', fi, Multipart)
|
||||||
|
|
||||||
|
maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo)
|
||||||
|
=> FormFieldSettings -> f
|
||||||
|
maybeFileField ffs = toForm $ 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 = string label
|
||||||
|
, fiTooltip = tooltip
|
||||||
|
, fiIdent = theId
|
||||||
|
, fiInput = fileWidget theId name False
|
||||||
|
, fiErrors = Nothing
|
||||||
|
, fiRequired = True
|
||||||
|
}
|
||||||
|
return (res, fi, Multipart)
|
||||||
|
|
||||||
|
fileWidget :: String -> String -> Bool -> GWidget s m ()
|
||||||
|
fileWidget theId name isReq =
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%input#$theId$!type=file!name=$name$!:isReq:required
|
||||||
|
|]
|
||||||
236
Yesod/Form/Jquery.hs
Normal file
236
Yesod/Form/Jquery.hs
Normal file
@ -0,0 +1,236 @@
|
|||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
-- | Some fields spiced up with jQuery UI.
|
||||||
|
module Yesod.Form.Jquery
|
||||||
|
( YesodJquery (..)
|
||||||
|
, jqueryDayField
|
||||||
|
, maybeJqueryDayField
|
||||||
|
, jqueryDayTimeField
|
||||||
|
, jqueryDayTimeFieldProfile
|
||||||
|
, jqueryAutocompleteField
|
||||||
|
, maybeJqueryAutocompleteField
|
||||||
|
, jqueryDayFieldProfile
|
||||||
|
, googleHostedJqueryUiCss
|
||||||
|
, JqueryDaySettings (..)
|
||||||
|
, Default (..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Yesod.Handler
|
||||||
|
import Yesod.Form.Core
|
||||||
|
import Yesod.Form.Profiles
|
||||||
|
import Yesod.Widget
|
||||||
|
import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
|
||||||
|
timeToTimeOfDay)
|
||||||
|
import Data.Char (isSpace)
|
||||||
|
import Data.Default
|
||||||
|
import Text.Hamlet (hamlet)
|
||||||
|
import Text.Julius (julius)
|
||||||
|
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
#define HAMLET hamlet
|
||||||
|
#define CASSIUS cassius
|
||||||
|
#define JULIUS julius
|
||||||
|
#else
|
||||||
|
#define HAMLET $hamlet
|
||||||
|
#define CASSIUS $cassius
|
||||||
|
#define JULIUS $julius
|
||||||
|
#endif
|
||||||
|
|
||||||
|
-- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme.
|
||||||
|
googleHostedJqueryUiCss :: String -> String
|
||||||
|
googleHostedJqueryUiCss theme = concat
|
||||||
|
[ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/"
|
||||||
|
, theme
|
||||||
|
, "/jquery-ui.css"
|
||||||
|
]
|
||||||
|
|
||||||
|
class YesodJquery a where
|
||||||
|
-- | The jQuery 1.4 Javascript file.
|
||||||
|
urlJqueryJs :: a -> Either (Route a) String
|
||||||
|
urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js"
|
||||||
|
|
||||||
|
-- | The jQuery UI 1.8 Javascript file.
|
||||||
|
urlJqueryUiJs :: a -> Either (Route a) String
|
||||||
|
urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js"
|
||||||
|
|
||||||
|
-- | The jQuery UI 1.8 CSS file; defaults to cupertino theme.
|
||||||
|
urlJqueryUiCss :: a -> Either (Route a) String
|
||||||
|
urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino"
|
||||||
|
|
||||||
|
-- | jQuery UI time picker add-on.
|
||||||
|
urlJqueryUiDateTimePicker :: a -> Either (Route a) String
|
||||||
|
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
|
||||||
|
|
||||||
|
jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f))
|
||||||
|
=> JqueryDaySettings
|
||||||
|
-> FormFieldSettings
|
||||||
|
-> Maybe (FormType f)
|
||||||
|
-> f
|
||||||
|
jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile
|
||||||
|
|
||||||
|
maybeJqueryDayField
|
||||||
|
:: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f))
|
||||||
|
=> JqueryDaySettings
|
||||||
|
-> FormFieldSettings
|
||||||
|
-> Maybe (FormType f)
|
||||||
|
-> f
|
||||||
|
maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile
|
||||||
|
|
||||||
|
jqueryDayFieldProfile :: YesodJquery y
|
||||||
|
=> JqueryDaySettings -> FieldProfile sub y Day
|
||||||
|
jqueryDayFieldProfile jds = FieldProfile
|
||||||
|
{ fpParse = maybe
|
||||||
|
(Left "Invalid day, must be in YYYY-MM-DD format")
|
||||||
|
Right
|
||||||
|
. readMay
|
||||||
|
, fpRender = show
|
||||||
|
, fpWidget = \theId name val isReq -> do
|
||||||
|
addHtml [HAMLET|
|
||||||
|
%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
addScript' urlJqueryJs
|
||||||
|
addScript' urlJqueryUiJs
|
||||||
|
addStylesheet' urlJqueryUiCss
|
||||||
|
addJulius [JULIUS|
|
||||||
|
$(function(){$("#%theId%").datepicker({
|
||||||
|
dateFormat:'yy-mm-dd',
|
||||||
|
changeMonth:%jsBool.jdsChangeMonth.jds%,
|
||||||
|
changeYear:%jsBool.jdsChangeYear.jds%,
|
||||||
|
numberOfMonths:%mos.jdsNumberOfMonths.jds%,
|
||||||
|
yearRange:"%jdsYearRange.jds%"
|
||||||
|
})});
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
where
|
||||||
|
jsBool True = "true"
|
||||||
|
jsBool False = "false"
|
||||||
|
mos (Left i) = show i
|
||||||
|
mos (Right (x, y)) = concat
|
||||||
|
[ "["
|
||||||
|
, show x
|
||||||
|
, ","
|
||||||
|
, show y
|
||||||
|
, "]"
|
||||||
|
]
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
jqueryDayTimeField
|
||||||
|
:: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f))
|
||||||
|
=> FormFieldSettings
|
||||||
|
-> Maybe (FormType f)
|
||||||
|
-> f
|
||||||
|
jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile
|
||||||
|
|
||||||
|
-- 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 :: YesodJquery y => FieldProfile sub y UTCTime
|
||||||
|
jqueryDayTimeFieldProfile = FieldProfile
|
||||||
|
{ fpParse = parseUTCTime
|
||||||
|
, fpRender = jqueryDayTimeUTCTime
|
||||||
|
, fpWidget = \theId name val isReq -> do
|
||||||
|
addHtml [HAMLET|
|
||||||
|
%input#$theId$!name=$name$!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
addScript' urlJqueryJs
|
||||||
|
addScript' urlJqueryUiJs
|
||||||
|
addScript' urlJqueryUiDateTimePicker
|
||||||
|
addStylesheet' urlJqueryUiCss
|
||||||
|
addJulius [JULIUS|
|
||||||
|
$(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
parseUTCTime :: String -> Either String UTCTime
|
||||||
|
parseUTCTime s =
|
||||||
|
let (dateS, timeS) = break isSpace (dropWhile isSpace s)
|
||||||
|
dateE = parseDate dateS
|
||||||
|
in case dateE of
|
||||||
|
Left l -> Left l
|
||||||
|
Right date ->
|
||||||
|
ifRight (parseTime timeS)
|
||||||
|
(UTCTime date . timeOfDayToTime)
|
||||||
|
|
||||||
|
jqueryAutocompleteField
|
||||||
|
:: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f))
|
||||||
|
=> Route (FormMaster f)
|
||||||
|
-> FormFieldSettings
|
||||||
|
-> Maybe (FormType f)
|
||||||
|
-> f
|
||||||
|
jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile
|
||||||
|
|
||||||
|
maybeJqueryAutocompleteField
|
||||||
|
:: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f))
|
||||||
|
=> Route (FormMaster f)
|
||||||
|
-> FormFieldSettings
|
||||||
|
-> Maybe (FormType f)
|
||||||
|
-> f
|
||||||
|
maybeJqueryAutocompleteField src =
|
||||||
|
optionalFieldHelper $ jqueryAutocompleteFieldProfile src
|
||||||
|
|
||||||
|
jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String
|
||||||
|
jqueryAutocompleteFieldProfile src = FieldProfile
|
||||||
|
{ fpParse = Right
|
||||||
|
, fpRender = id
|
||||||
|
, fpWidget = \theId name val isReq -> do
|
||||||
|
addHtml [HAMLET|
|
||||||
|
%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
addScript' urlJqueryJs
|
||||||
|
addScript' urlJqueryUiJs
|
||||||
|
addStylesheet' urlJqueryUiCss
|
||||||
|
addJulius [JULIUS|
|
||||||
|
$(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})});
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
readMay :: Read a => String -> Maybe a
|
||||||
|
readMay s = case reads s of
|
||||||
|
(x, _):_ -> Just x
|
||||||
|
[] -> Nothing
|
||||||
|
|
||||||
|
-- | 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)
|
||||||
|
|
||||||
|
data JqueryDaySettings = JqueryDaySettings
|
||||||
|
{ jdsChangeMonth :: Bool
|
||||||
|
, jdsChangeYear :: Bool
|
||||||
|
, jdsYearRange :: String
|
||||||
|
, jdsNumberOfMonths :: Either Int (Int, Int)
|
||||||
|
}
|
||||||
|
|
||||||
|
instance Default JqueryDaySettings where
|
||||||
|
def = JqueryDaySettings
|
||||||
|
{ jdsChangeMonth = False
|
||||||
|
, jdsChangeYear = False
|
||||||
|
, jdsYearRange = "c-10:c+10"
|
||||||
|
, jdsNumberOfMonths = Left 1
|
||||||
|
}
|
||||||
62
Yesod/Form/Nic.hs
Normal file
62
Yesod/Form/Nic.hs
Normal file
@ -0,0 +1,62 @@
|
|||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
-- | Provide the user with a rich text editor.
|
||||||
|
module Yesod.Form.Nic
|
||||||
|
( YesodNic (..)
|
||||||
|
, nicHtmlField
|
||||||
|
, maybeNicHtmlField
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Yesod.Handler
|
||||||
|
import Yesod.Form.Core
|
||||||
|
import Yesod.Widget
|
||||||
|
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
||||||
|
import Text.Hamlet (Html, hamlet)
|
||||||
|
import Text.Julius (julius)
|
||||||
|
import Text.Blaze.Renderer.String (renderHtml)
|
||||||
|
import Text.Blaze (preEscapedString)
|
||||||
|
|
||||||
|
class YesodNic a where
|
||||||
|
-- | NIC Editor Javascript file.
|
||||||
|
urlNicEdit :: a -> Either (Route a) String
|
||||||
|
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
|
||||||
|
|
||||||
|
nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f))
|
||||||
|
=> FormFieldSettings -> Maybe Html -> f
|
||||||
|
nicHtmlField = requiredFieldHelper nicHtmlFieldProfile
|
||||||
|
|
||||||
|
maybeNicHtmlField
|
||||||
|
:: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f))
|
||||||
|
=> FormFieldSettings -> Maybe (FormType f) -> f
|
||||||
|
maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile
|
||||||
|
|
||||||
|
nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html
|
||||||
|
nicHtmlFieldProfile = FieldProfile
|
||||||
|
{ fpParse = Right . preEscapedString . sanitizeBalance
|
||||||
|
, fpRender = renderHtml
|
||||||
|
, fpWidget = \theId name val _isReq -> do
|
||||||
|
addHtml
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%textarea.html#$theId$!name=$name$ $val$
|
||||||
|
|]
|
||||||
|
addScript' urlNicEdit
|
||||||
|
addJulius
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[julius|
|
||||||
|
#else
|
||||||
|
[$julius|
|
||||||
|
#endif
|
||||||
|
bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
|
||||||
|
addScript' f = do
|
||||||
|
y <- liftHandler getYesod
|
||||||
|
addScriptEither $ f y
|
||||||
242
Yesod/Form/Profiles.hs
Normal file
242
Yesod/Form/Profiles.hs
Normal file
@ -0,0 +1,242 @@
|
|||||||
|
{-# 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.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
|
||||||
|
|
||||||
|
#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 :: Integral i => FieldProfile sub y i
|
||||||
|
intFieldProfile = FieldProfile
|
||||||
|
{ fpParse = maybe (Left "Invalid integer") Right . readMayI
|
||||||
|
, fpRender = showI
|
||||||
|
, fpWidget = \theId name val isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input#$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 :: FieldProfile sub y Double
|
||||||
|
doubleFieldProfile = FieldProfile
|
||||||
|
{ fpParse = maybe (Left "Invalid number") Right . readMay
|
||||||
|
, fpRender = show
|
||||||
|
, fpWidget = \theId name val isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
dayFieldProfile :: FieldProfile sub y Day
|
||||||
|
dayFieldProfile = FieldProfile
|
||||||
|
{ fpParse = parseDate
|
||||||
|
, fpRender = show
|
||||||
|
, fpWidget = \theId name val isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
timeFieldProfile :: FieldProfile sub y TimeOfDay
|
||||||
|
timeFieldProfile = FieldProfile
|
||||||
|
{ fpParse = parseTime
|
||||||
|
, fpRender = show
|
||||||
|
, fpWidget = \theId name val isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input#$theId$!name=$name$!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
htmlFieldProfile :: FieldProfile sub y Html
|
||||||
|
htmlFieldProfile = FieldProfile
|
||||||
|
{ fpParse = Right . preEscapedString . sanitizeBalance
|
||||||
|
, fpRender = renderHtml
|
||||||
|
, fpWidget = \theId name val _isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%textarea.html#$theId$!name=$name$ $val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | A newtype wrapper around a 'String' that converts newlines to HTML
|
||||||
|
-- br-tags.
|
||||||
|
newtype Textarea = Textarea { unTextarea :: String }
|
||||||
|
deriving (Show, Read, Eq, PersistField)
|
||||||
|
instance ToHtml Textarea where
|
||||||
|
toHtml =
|
||||||
|
unsafeByteString
|
||||||
|
. S.concat
|
||||||
|
. L.toChunks
|
||||||
|
. toLazyByteString
|
||||||
|
. fromWriteList writeHtmlEscapedChar
|
||||||
|
. unTextarea
|
||||||
|
where
|
||||||
|
-- Taken from blaze-builder and modified with newline handling.
|
||||||
|
writeHtmlEscapedChar '\n' = writeByteString "<br>"
|
||||||
|
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
|
||||||
|
|
||||||
|
textareaFieldProfile :: FieldProfile sub y Textarea
|
||||||
|
textareaFieldProfile = FieldProfile
|
||||||
|
{ fpParse = Right . Textarea
|
||||||
|
, fpRender = unTextarea
|
||||||
|
, fpWidget = \theId name val _isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%textarea#$theId$!name=$name$ $val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
hiddenFieldProfile :: FieldProfile sub y String
|
||||||
|
hiddenFieldProfile = FieldProfile
|
||||||
|
{ fpParse = Right
|
||||||
|
, fpRender = id
|
||||||
|
, fpWidget = \theId name val _isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input!type=hidden#$theId$!name=$name$!value=$val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
stringFieldProfile :: FieldProfile sub y String
|
||||||
|
stringFieldProfile = FieldProfile
|
||||||
|
{ fpParse = Right
|
||||||
|
, fpRender = id
|
||||||
|
, fpWidget = \theId name val isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
passwordFieldProfile :: FieldProfile s m String
|
||||||
|
passwordFieldProfile = FieldProfile
|
||||||
|
{ fpParse = Right
|
||||||
|
, fpRender = id
|
||||||
|
, fpWidget = \theId name val isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input#$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 String 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 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]
|
||||||
|
|
||||||
|
emailFieldProfile :: FieldProfile s y String
|
||||||
|
emailFieldProfile = FieldProfile
|
||||||
|
{ fpParse = \s -> if Email.isValid s
|
||||||
|
then Right s
|
||||||
|
else Left "Invalid e-mail address"
|
||||||
|
, fpRender = id
|
||||||
|
, fpWidget = \theId name val isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
|
|
||||||
|
type AutoFocus = Bool
|
||||||
|
searchFieldProfile :: AutoFocus -> FieldProfile s y String
|
||||||
|
searchFieldProfile autoFocus = FieldProfile
|
||||||
|
{ fpParse = Right
|
||||||
|
, fpRender = id
|
||||||
|
, fpWidget = \theId name val isReq -> do
|
||||||
|
addHtml [HAMLET|
|
||||||
|
%input#$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 :: FieldProfile s y String
|
||||||
|
urlFieldProfile = FieldProfile
|
||||||
|
{ fpParse = \s -> case parseURI s of
|
||||||
|
Nothing -> Left "Invalid URL"
|
||||||
|
Just _ -> Right s
|
||||||
|
, fpRender = id
|
||||||
|
, fpWidget = \theId name val isReq -> addHamlet
|
||||||
|
[HAMLET|
|
||||||
|
%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$
|
||||||
|
|]
|
||||||
|
}
|
||||||
208
Yesod/Helpers/Crud.hs
Normal file
208
Yesod/Helpers/Crud.hs
Normal file
@ -0,0 +1,208 @@
|
|||||||
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE Rank2Types #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
module Yesod.Helpers.Crud
|
||||||
|
( Item (..)
|
||||||
|
, Crud (..)
|
||||||
|
, CrudRoute (..)
|
||||||
|
, defaultCrud
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Yesod.Yesod
|
||||||
|
import Yesod.Widget
|
||||||
|
import Yesod.Dispatch
|
||||||
|
import Yesod.Content
|
||||||
|
import Yesod.Handler
|
||||||
|
import Text.Hamlet
|
||||||
|
import Yesod.Form
|
||||||
|
import Language.Haskell.TH.Syntax
|
||||||
|
|
||||||
|
-- | An entity which can be displayed by the Crud subsite.
|
||||||
|
class Item a where
|
||||||
|
-- | The title of an entity, to be displayed in the list of all entities.
|
||||||
|
itemTitle :: a -> String
|
||||||
|
|
||||||
|
-- | Defines all of the CRUD operations (Create, Read, Update, Delete)
|
||||||
|
-- necessary to implement this subsite. When using the "Yesod.Form" module and
|
||||||
|
-- 'ToForm' typeclass, you can probably just use 'defaultCrud'.
|
||||||
|
data Crud master item = Crud
|
||||||
|
{ crudSelect :: GHandler (Crud master item) master [(Key item, item)]
|
||||||
|
, crudReplace :: Key item -> item -> GHandler (Crud master item) master ()
|
||||||
|
, crudInsert :: item -> GHandler (Crud master item) master (Key item)
|
||||||
|
, crudGet :: Key item -> GHandler (Crud master item) master (Maybe item)
|
||||||
|
, crudDelete :: Key item -> GHandler (Crud master item) master ()
|
||||||
|
}
|
||||||
|
|
||||||
|
mkYesodSub "Crud master item"
|
||||||
|
[ ClassP ''Yesod [VarT $ mkName "master"]
|
||||||
|
, ClassP ''Item [VarT $ mkName "item"]
|
||||||
|
, ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]
|
||||||
|
, ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]
|
||||||
|
]
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[parseRoutes|
|
||||||
|
#else
|
||||||
|
[$parseRoutes|
|
||||||
|
#endif
|
||||||
|
/ CrudListR GET
|
||||||
|
/add CrudAddR GET POST
|
||||||
|
/edit/#String CrudEditR GET POST
|
||||||
|
/delete/#String CrudDeleteR GET POST
|
||||||
|
|]
|
||||||
|
|
||||||
|
getCrudListR :: (Yesod master, Item item, SinglePiece (Key item))
|
||||||
|
=> GHandler (Crud master item) master RepHtml
|
||||||
|
getCrudListR = do
|
||||||
|
items <- getYesodSub >>= crudSelect
|
||||||
|
toMaster <- getRouteToMaster
|
||||||
|
defaultLayout $ do
|
||||||
|
setTitle "Items"
|
||||||
|
addWidget
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%h1 Items
|
||||||
|
%ul
|
||||||
|
$forall items item
|
||||||
|
%li
|
||||||
|
%a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@
|
||||||
|
$itemTitle.snd.item$
|
||||||
|
%p
|
||||||
|
%a!href=@toMaster.CrudAddR@ Add new item
|
||||||
|
|]
|
||||||
|
|
||||||
|
getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
|
||||||
|
ToForm item master)
|
||||||
|
=> GHandler (Crud master item) master RepHtml
|
||||||
|
getCrudAddR = crudHelper
|
||||||
|
"Add new"
|
||||||
|
(Nothing :: Maybe (Key item, item))
|
||||||
|
False
|
||||||
|
|
||||||
|
postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
|
||||||
|
ToForm item master)
|
||||||
|
=> GHandler (Crud master item) master RepHtml
|
||||||
|
postCrudAddR = crudHelper
|
||||||
|
"Add new"
|
||||||
|
(Nothing :: Maybe (Key item, item))
|
||||||
|
True
|
||||||
|
|
||||||
|
getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
|
||||||
|
ToForm item master)
|
||||||
|
=> String -> GHandler (Crud master item) master RepHtml
|
||||||
|
getCrudEditR s = do
|
||||||
|
itemId <- maybe notFound return $ itemReadId s
|
||||||
|
crud <- getYesodSub
|
||||||
|
item <- crudGet crud itemId >>= maybe notFound return
|
||||||
|
crudHelper
|
||||||
|
"Edit item"
|
||||||
|
(Just (itemId, item))
|
||||||
|
False
|
||||||
|
|
||||||
|
postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
|
||||||
|
ToForm item master)
|
||||||
|
=> String -> GHandler (Crud master item) master RepHtml
|
||||||
|
postCrudEditR s = do
|
||||||
|
itemId <- maybe notFound return $ itemReadId s
|
||||||
|
crud <- getYesodSub
|
||||||
|
item <- crudGet crud itemId >>= maybe notFound return
|
||||||
|
crudHelper
|
||||||
|
"Edit item"
|
||||||
|
(Just (itemId, item))
|
||||||
|
True
|
||||||
|
|
||||||
|
getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
|
||||||
|
=> String -> GHandler (Crud master item) master RepHtml
|
||||||
|
getCrudDeleteR s = do
|
||||||
|
itemId <- maybe notFound return $ itemReadId s
|
||||||
|
crud <- getYesodSub
|
||||||
|
item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists
|
||||||
|
toMaster <- getRouteToMaster
|
||||||
|
defaultLayout $ do
|
||||||
|
setTitle "Confirm delete"
|
||||||
|
addWidget
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%form!method=post!action=@toMaster.CrudDeleteR.s@
|
||||||
|
%h1 Really delete?
|
||||||
|
%p Do you really want to delete $itemTitle.item$?
|
||||||
|
%p
|
||||||
|
%input!type=submit!value=Yes
|
||||||
|
\ $
|
||||||
|
%a!href=@toMaster.CrudListR@ No
|
||||||
|
|]
|
||||||
|
|
||||||
|
postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
|
||||||
|
=> String -> GHandler (Crud master item) master RepHtml
|
||||||
|
postCrudDeleteR s = do
|
||||||
|
itemId <- maybe notFound return $ itemReadId s
|
||||||
|
crud <- getYesodSub
|
||||||
|
toMaster <- getRouteToMaster
|
||||||
|
crudDelete crud itemId
|
||||||
|
redirect RedirectTemporary $ toMaster CrudListR
|
||||||
|
|
||||||
|
itemReadId :: SinglePiece x => String -> Maybe x
|
||||||
|
itemReadId = either (const Nothing) Just . fromSinglePiece
|
||||||
|
|
||||||
|
crudHelper
|
||||||
|
:: (Item a, Yesod master, SinglePiece (Key a), ToForm a master)
|
||||||
|
=> String -> Maybe (Key a, a) -> Bool
|
||||||
|
-> GHandler (Crud master a) master RepHtml
|
||||||
|
crudHelper title me isPost = do
|
||||||
|
crud <- getYesodSub
|
||||||
|
(errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me
|
||||||
|
toMaster <- getRouteToMaster
|
||||||
|
case (isPost, errs) of
|
||||||
|
(True, FormSuccess a) -> do
|
||||||
|
eid <- case me of
|
||||||
|
Just (eid, _) -> do
|
||||||
|
crudReplace crud eid a
|
||||||
|
return eid
|
||||||
|
Nothing -> crudInsert crud a
|
||||||
|
redirect RedirectTemporary $ toMaster $ CrudEditR
|
||||||
|
$ toSinglePiece eid
|
||||||
|
_ -> return ()
|
||||||
|
defaultLayout $ do
|
||||||
|
setTitle $ string title
|
||||||
|
addWidget
|
||||||
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
[hamlet|
|
||||||
|
#else
|
||||||
|
[$hamlet|
|
||||||
|
#endif
|
||||||
|
%p
|
||||||
|
%a!href=@toMaster.CrudListR@ Return to list
|
||||||
|
%h1 $title$
|
||||||
|
%form!method=post!enctype=$enctype$
|
||||||
|
%table
|
||||||
|
^form^
|
||||||
|
%tr
|
||||||
|
%td!colspan=2
|
||||||
|
$hidden$
|
||||||
|
%input!type=submit
|
||||||
|
$maybe me e
|
||||||
|
\ $
|
||||||
|
%a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete
|
||||||
|
|]
|
||||||
|
|
||||||
|
-- | A default 'Crud' value which relies about persistent and "Yesod.Form".
|
||||||
|
defaultCrud
|
||||||
|
:: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)),
|
||||||
|
YesodPersist a)
|
||||||
|
=> a -> Crud a i
|
||||||
|
defaultCrud = const Crud
|
||||||
|
{ crudSelect = runDB $ selectList [] [] 0 0
|
||||||
|
, crudReplace = \a -> runDB . replace a
|
||||||
|
, crudInsert = runDB . insert
|
||||||
|
, crudGet = runDB . get
|
||||||
|
, crudDelete = runDB . delete
|
||||||
|
}
|
||||||
173
hellowidget.hs
Normal file
173
hellowidget.hs
Normal file
@ -0,0 +1,173 @@
|
|||||||
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-}
|
||||||
|
import Yesod.Dispatch (mkYesod, parseRoutes, toWaiApp)
|
||||||
|
import Yesod.Widget
|
||||||
|
import Yesod.Helpers.Static
|
||||||
|
import Yesod.Form.Jquery
|
||||||
|
import Yesod.Form.Core
|
||||||
|
import Yesod.Form
|
||||||
|
import Yesod.Json
|
||||||
|
import Yesod.Handler (GHandler)
|
||||||
|
import Yesod.Content (RepJson, typeByExt)
|
||||||
|
import Text.Hamlet (hamlet)
|
||||||
|
import Text.Cassius (cassius)
|
||||||
|
import Yesod.Core (Yesod (approot, addStaticContent, defaultLayout), YesodSite (..))
|
||||||
|
import Text.Blaze (string)
|
||||||
|
import Data.Monoid
|
||||||
|
import Yesod.Form.Nic
|
||||||
|
import Control.Applicative
|
||||||
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
import System.Directory
|
||||||
|
import Control.Monad.Trans.Class
|
||||||
|
import Data.Default
|
||||||
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
import Network.Wai.Handler.Warp (run)
|
||||||
|
import Data.JSON.Types
|
||||||
|
import Data.Text.Lazy (pack)
|
||||||
|
|
||||||
|
data HW = HW { hwStatic :: Static }
|
||||||
|
mkYesod "HW" [$parseRoutes|
|
||||||
|
/ RootR GET
|
||||||
|
/form FormR
|
||||||
|
/static StaticR Static hwStatic
|
||||||
|
/autocomplete AutoCompleteR GET
|
||||||
|
/customform CustomFormR GET
|
||||||
|
|]
|
||||||
|
instance Yesod HW where
|
||||||
|
approot _ = ""
|
||||||
|
addStaticContent ext _ content = do
|
||||||
|
let fn = (base64md5 content) ++ '.' : ext
|
||||||
|
liftIO $ createDirectoryIfMissing True "static/tmp"
|
||||||
|
liftIO $ L.writeFile ("static/tmp/" ++ fn) content
|
||||||
|
return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])
|
||||||
|
|
||||||
|
type Handler = GHandler HW HW
|
||||||
|
|
||||||
|
instance YesodNic HW
|
||||||
|
instance YesodJquery HW where
|
||||||
|
urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "ui-darkness"
|
||||||
|
wrapper h = [$hamlet|
|
||||||
|
#wrapper ^h^
|
||||||
|
%footer Brought to you by Yesod Widgets™
|
||||||
|
|]
|
||||||
|
getRootR = defaultLayout $ wrapper $ do
|
||||||
|
i <- newIdent
|
||||||
|
setTitle $ string "Hello Widgets"
|
||||||
|
addCassius [$cassius|
|
||||||
|
#$i$
|
||||||
|
color: red
|
||||||
|
|]
|
||||||
|
addStylesheet $ StaticR $ StaticRoute ["style.css"] []
|
||||||
|
addStylesheetRemote "http://localhost:3000/static/style2.css"
|
||||||
|
addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
|
||||||
|
addScript $ StaticR $ StaticRoute ["script.js"] []
|
||||||
|
addHamlet [$hamlet|
|
||||||
|
%h1#$i$ Welcome to my first widget!!!
|
||||||
|
%p
|
||||||
|
%a!href=@RootR@ Recursive link.
|
||||||
|
%p
|
||||||
|
%a!href=@FormR@ Check out the form.
|
||||||
|
%p
|
||||||
|
%a!href=@CustomFormR@ Custom form arrangement.
|
||||||
|
%p.noscript Your script did not load. :(
|
||||||
|
|]
|
||||||
|
addHtmlHead [$hamlet|%meta!keywords=haskell|]
|
||||||
|
|
||||||
|
handleFormR = do
|
||||||
|
(res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,,)
|
||||||
|
<$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing
|
||||||
|
<*> stringField ("Another field") (Just "some default text")
|
||||||
|
<*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5)
|
||||||
|
<*> jqueryDayField def
|
||||||
|
{ jdsChangeMonth = True
|
||||||
|
, jdsChangeYear = True
|
||||||
|
, jdsYearRange = "1900:c+10"
|
||||||
|
, jdsNumberOfMonths = Right (2, 3)
|
||||||
|
} ("A day field") Nothing
|
||||||
|
<*> timeField ("A time field") Nothing
|
||||||
|
<*> boolField FormFieldSettings
|
||||||
|
{ ffsLabel = "A checkbox"
|
||||||
|
, ffsTooltip = ""
|
||||||
|
, ffsId = Nothing
|
||||||
|
, ffsName = Nothing
|
||||||
|
} (Just False)
|
||||||
|
<*> jqueryAutocompleteField AutoCompleteR
|
||||||
|
(FormFieldSettings "Autocomplete" "Try it!" Nothing Nothing) Nothing
|
||||||
|
<*> nicHtmlField ("HTML")
|
||||||
|
(Just $ string "You can put rich text here")
|
||||||
|
<*> maybeEmailField ("An e-mail addres") Nothing
|
||||||
|
<*> maybeTextareaField "A text area" Nothing
|
||||||
|
<*> maybeFileField "Any file"
|
||||||
|
<*> maybePasswordField "Enter a password" Nothing
|
||||||
|
let (mhtml, mfile) = case res of
|
||||||
|
FormSuccess (_, _, _, _, _, _, _, x, _, _, y, _) -> (Just x, y)
|
||||||
|
_ -> (Nothing, Nothing)
|
||||||
|
let txt = case res of
|
||||||
|
FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _, _) -> Just x
|
||||||
|
_ -> Nothing
|
||||||
|
defaultLayout $ do
|
||||||
|
addCassius [$cassius|
|
||||||
|
.tooltip
|
||||||
|
color: #666
|
||||||
|
font-style: italic
|
||||||
|
|]
|
||||||
|
addCassius [$cassius|
|
||||||
|
textarea.html
|
||||||
|
width: 300px
|
||||||
|
height: 150px
|
||||||
|
|]
|
||||||
|
addWidget [$hamlet|
|
||||||
|
$maybe formFailures.res failures
|
||||||
|
%ul.errors
|
||||||
|
$forall failures f
|
||||||
|
%li $f$
|
||||||
|
%form!method=post!enctype=$enctype$
|
||||||
|
$hidden$
|
||||||
|
%table
|
||||||
|
^form^
|
||||||
|
%tr
|
||||||
|
%td!colspan=2
|
||||||
|
%input!type=submit
|
||||||
|
$maybe mhtml html
|
||||||
|
$html$
|
||||||
|
$maybe txt t
|
||||||
|
$t$
|
||||||
|
$maybe mfile f
|
||||||
|
$show.f$
|
||||||
|
|]
|
||||||
|
setTitle $ string "Form"
|
||||||
|
|
||||||
|
main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= run 3000
|
||||||
|
|
||||||
|
getAutoCompleteR :: Handler RepJson
|
||||||
|
getAutoCompleteR = do
|
||||||
|
term <- runFormGet' $ stringInput "term"
|
||||||
|
jsonToRepJson $ ValueArray
|
||||||
|
[ ValueAtom $ AtomText $ pack $ term ++ "foo"
|
||||||
|
, ValueAtom $ AtomText $ pack $ term ++ "bar"
|
||||||
|
, ValueAtom $ AtomText $ pack $ term ++ "baz"
|
||||||
|
]
|
||||||
|
|
||||||
|
data Person = Person String Int
|
||||||
|
getCustomFormR = do
|
||||||
|
let customForm = GForm $ do
|
||||||
|
(a1, [b1], c1) <- deform $ stringInput "name"
|
||||||
|
(a2, [b2], c2) <- deform $ intInput "age"
|
||||||
|
let b = do
|
||||||
|
b1' <- extractBody b1
|
||||||
|
b2' <- extractBody b2
|
||||||
|
addHamlet [$hamlet|
|
||||||
|
%p This is a custom layout.
|
||||||
|
%h1 Name Follows!
|
||||||
|
%p ^b1'^
|
||||||
|
%p Age: ^b2'^
|
||||||
|
|]
|
||||||
|
return (Person <$> a1 <*> a2, b , c1 `mappend` c2)
|
||||||
|
(_, wform, enctype) <- runFormGet customForm
|
||||||
|
defaultLayout $ do
|
||||||
|
form <- extractBody wform
|
||||||
|
addHamlet [$hamlet|
|
||||||
|
%form
|
||||||
|
^form^
|
||||||
|
%div
|
||||||
|
%input!type=submit
|
||||||
|
|]
|
||||||
40
yesod-form.cabal
Normal file
40
yesod-form.cabal
Normal file
@ -0,0 +1,40 @@
|
|||||||
|
name: yesod-form
|
||||||
|
version: 0.7.0
|
||||||
|
license: BSD3
|
||||||
|
license-file: LICENSE
|
||||||
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
|
maintainer: Michael Snoyman <michael@snoyman.com>
|
||||||
|
synopsis: Form handling support for Yesod Web Framework
|
||||||
|
category: Web, Yesod
|
||||||
|
stability: Stable
|
||||||
|
cabal-version: >= 1.6
|
||||||
|
build-type: Simple
|
||||||
|
homepage: http://docs.yesodweb.com/
|
||||||
|
|
||||||
|
library
|
||||||
|
build-depends: base >= 4 && < 5
|
||||||
|
, yesod-core >= 0.7 && < 0.8
|
||||||
|
, time >= 1.1.4 && < 1.3
|
||||||
|
, hamlet >= 0.7 && < 0.8
|
||||||
|
, persistent >= 0.4 && < 0.5
|
||||||
|
, template-haskell
|
||||||
|
, transformers >= 0.2.2 && < 0.3
|
||||||
|
, data-default >= 0.2 && < 0.3
|
||||||
|
, xss-sanitize >= 0.2.4 && < 0.3
|
||||||
|
, blaze-builder >= 0.2.1 && < 0.3
|
||||||
|
, network >= 2.2 && < 2.4
|
||||||
|
, email-validate >= 0.2.6 && < 0.3
|
||||||
|
, blaze-html >= 0.3.0.4 && < 0.4
|
||||||
|
, bytestring >= 0.9 && < 0.10
|
||||||
|
exposed-modules: Yesod.Form
|
||||||
|
Yesod.Form.Class
|
||||||
|
Yesod.Form.Core
|
||||||
|
Yesod.Form.Fields
|
||||||
|
Yesod.Form.Jquery
|
||||||
|
Yesod.Form.Nic
|
||||||
|
Yesod.Form.Profiles
|
||||||
|
ghc-options: -Wall
|
||||||
|
|
||||||
|
source-repository head
|
||||||
|
type: git
|
||||||
|
location: git://github.com/snoyberg/yesod-form.git
|
||||||
Loading…
Reference in New Issue
Block a user