diff --git a/LICENSE b/LICENSE
new file mode 100644
index 00000000..8643e5d8
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100755
index 00000000..06e2708f
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
diff --git a/Yesod/Form.hs b/Yesod/Form.hs
new file mode 100644
index 00000000..f5ebce8c
--- /dev/null
+++ b/Yesod/Form.hs
@@ -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
diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs
new file mode 100644
index 00000000..290b15d7
--- /dev/null
+++ b/Yesod/Form/Class.hs
@@ -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
diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs
new file mode 100644
index 00000000..be5fcbe0
--- /dev/null
+++ b/Yesod/Form/Core.hs
@@ -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
diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs
new file mode 100644
index 00000000..beb1c59f
--- /dev/null
+++ b/Yesod/Form/Fields.hs
@@ -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
+|]
diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs
new file mode 100644
index 00000000..e240cde0
--- /dev/null
+++ b/Yesod/Form/Jquery.hs
@@ -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
+ }
diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs
new file mode 100644
index 00000000..0d8d672c
--- /dev/null
+++ b/Yesod/Form/Nic.hs
@@ -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
diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs
new file mode 100644
index 00000000..7cbd8a79
--- /dev/null
+++ b/Yesod/Form/Profiles.hs
@@ -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 "
"
+ 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|\ |]
+ 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$
+|]
+ }
diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs
new file mode 100644
index 00000000..865fa735
--- /dev/null
+++ b/Yesod/Helpers/Crud.hs
@@ -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
+ }
diff --git a/hellowidget.hs b/hellowidget.hs
new file mode 100644
index 00000000..c579d3a9
--- /dev/null
+++ b/hellowidget.hs
@@ -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
+|]
diff --git a/yesod-form.cabal b/yesod-form.cabal
new file mode 100644
index 00000000..6a8cc22d
--- /dev/null
+++ b/yesod-form.cabal
@@ -0,0 +1,40 @@
+name: yesod-form
+version: 0.7.0
+license: BSD3
+license-file: LICENSE
+author: Michael Snoyman
+maintainer: Michael Snoyman
+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