diff --git a/Yesod.hs b/Yesod.hs
index 25b55099..f3be2aa7 100644
--- a/Yesod.hs
+++ b/Yesod.hs
@@ -6,7 +6,6 @@ module Yesod
, module Yesod.Yesod
, module Yesod.Handler
, module Yesod.Dispatch
- , module Yesod.Form
, module Yesod.Hamlet
, module Yesod.Json
, module Yesod.Widget
@@ -34,7 +33,6 @@ import Yesod.Handler hiding (runHandler)
#endif
import Yesod.Request
-import Yesod.Form
import Yesod.Widget
import Network.Wai (Application)
import Yesod.Hamlet
diff --git a/Yesod/Form.hs b/Yesod/Form.hs
deleted file mode 100644
index 9d9d054d..00000000
--- a/Yesod/Form.hs
+++ /dev/null
@@ -1,341 +0,0 @@
-{-# 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 GHC7
- [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 GHC7
- [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 GHC7
- [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 GHC7
- [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 GHC7
- [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 GHC7
- [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
deleted file mode 100644
index 290b15d7..00000000
--- a/Yesod/Form/Class.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# 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
deleted file mode 100644
index be5fcbe0..00000000
--- a/Yesod/Form/Core.hs
+++ /dev/null
@@ -1,369 +0,0 @@
-{-# 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
deleted file mode 100644
index ad3fb22a..00000000
--- a/Yesod/Form/Fields.hs
+++ /dev/null
@@ -1,409 +0,0 @@
-{-# 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 GHC7
- [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 GHC7
- [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 GHC7
- [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 GHC7
- [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 GHC7
- [hamlet|
-#else
- [$hamlet|
-#endif
-%input#$theId$!type=file!name=$name$!:isReq:required
-|]
diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs
deleted file mode 100644
index d527bcd0..00000000
--- a/Yesod/Form/Jquery.hs
+++ /dev/null
@@ -1,235 +0,0 @@
-{-# 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 Yesod.Hamlet
-import Data.Char (isSpace)
-import Data.Default
-
-#if GHC7
-#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
deleted file mode 100644
index 66447a4a..00000000
--- a/Yesod/Form/Nic.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# 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.Hamlet
-import Yesod.Widget
-import Text.HTML.SanitizeXSS (sanitizeBalance)
-
-import Yesod.Internal (lbsToChars)
-
-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 = lbsToChars . renderHtml
- , fpWidget = \theId name val _isReq -> do
- addHtml
-#if GHC7
- [hamlet|
-#else
- [$hamlet|
-#endif
- %textarea.html#$theId$!name=$name$ $val$
-|]
- addScript' urlNicEdit
- addJulius
-#if GHC7
- [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
deleted file mode 100644
index e224e50b..00000000
--- a/Yesod/Form/Profiles.hs
+++ /dev/null
@@ -1,235 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE CPP #-}
-module Yesod.Form.Profiles
- ( stringFieldProfile
- , passwordFieldProfile
- , textareaFieldProfile
- , hiddenFieldProfile
- , intFieldProfile
- , dayFieldProfile
- , timeFieldProfile
- , htmlFieldProfile
- , emailFieldProfile
- , searchFieldProfile
- , AutoFocus
- , urlFieldProfile
- , doubleFieldProfile
- , parseDate
- , parseTime
- , Textarea (..)
- ) where
-
-import Yesod.Form.Core
-import Yesod.Widget
-import Text.Hamlet
-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)
-import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
-
-import Yesod.Internal (lbsToChars)
-
-#if GHC7
-#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 = lbsToChars . 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 =
- Html . 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
deleted file mode 100644
index 7690da70..00000000
--- a/Yesod/Helpers/Crud.hs
+++ /dev/null
@@ -1,208 +0,0 @@
-{-# 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 GHC7
- [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 GHC7
- [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 GHC7
- [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 GHC7
- [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/Yesod/Widget.hs b/Yesod/Widget.hs
index 7be74bb9..8a4c4cb8 100644
--- a/Yesod/Widget.hs
+++ b/Yesod/Widget.hs
@@ -40,15 +40,13 @@ import Control.Monad.Trans.State
import Text.Hamlet
import Text.Cassius
import Text.Julius
-import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
+import Yesod.Handler (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import Yesod.Internal
import Control.Monad.IO.Peel (MonadPeelIO)
-import Control.Monad (liftM)
-import qualified Data.Map as Map
-- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. This is basically a large 'WriterT' stack keeping track of
diff --git a/hellowidget.hs b/hellowidget.hs
deleted file mode 100644
index 3c73e81a..00000000
--- a/hellowidget.hs
+++ /dev/null
@@ -1,161 +0,0 @@
-{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-}
-import Yesod
-import Yesod.Widget
-import Yesod.Helpers.Static
-import Yesod.Form.Jquery
-import Yesod.Form.Core
-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
-
-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 = basicHandler 3000 $ HW $ fileLookupDir "static" typeByExt
-
-getAutoCompleteR :: Handler RepJson
-getAutoCompleteR = do
- term <- runFormGet' $ stringInput "term"
- jsonToRepJson $ jsonList
- [ jsonScalar $ term ++ "foo"
- , jsonScalar $ term ++ "bar"
- , jsonScalar $ 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.cabal b/yesod.cabal
index 6276a1d3..fdff1e9b 100644
--- a/yesod.cabal
+++ b/yesod.cabal
@@ -59,10 +59,6 @@ library
exposed-modules: Yesod
Yesod.Content
Yesod.Dispatch
- Yesod.Form
- Yesod.Form.Core
- Yesod.Form.Jquery
- Yesod.Form.Nic
Yesod.Hamlet
Yesod.Handler
Yesod.Json
@@ -70,13 +66,9 @@ library
Yesod.Widget
Yesod.Yesod
Yesod.Helpers.AtomFeed
- Yesod.Helpers.Crud
Yesod.Helpers.Sitemap
Yesod.Helpers.Static
- other-modules: Yesod.Form.Class
- Yesod.Internal
- Yesod.Form.Fields
- Yesod.Form.Profiles
+ other-modules: Yesod.Internal
ghc-options: -Wall
executable yesod