From 522203f81277c92d61f463f8e95ca26d2deddf8f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 16 Dec 2010 22:05:54 +0200 Subject: [PATCH] Removed Yesod.Form hierarchy All of this code will be included in a separate yesod-form package to allow for more flexibility in API changes, plus to make it more natural to swap in other packages such as digestive-functors. --- Yesod.hs | 2 - Yesod/Form.hs | 341 ---------------------------------- Yesod/Form/Class.hs | 61 ------ Yesod/Form/Core.hs | 369 ------------------------------------- Yesod/Form/Fields.hs | 409 ----------------------------------------- Yesod/Form/Jquery.hs | 235 ----------------------- Yesod/Form/Nic.hs | 61 ------ Yesod/Form/Profiles.hs | 235 ----------------------- Yesod/Helpers/Crud.hs | 208 --------------------- Yesod/Widget.hs | 4 +- hellowidget.hs | 161 ---------------- yesod.cabal | 10 +- 12 files changed, 2 insertions(+), 2094 deletions(-) delete mode 100644 Yesod/Form.hs delete mode 100644 Yesod/Form/Class.hs delete mode 100644 Yesod/Form/Core.hs delete mode 100644 Yesod/Form/Fields.hs delete mode 100644 Yesod/Form/Jquery.hs delete mode 100644 Yesod/Form/Nic.hs delete mode 100644 Yesod/Form/Profiles.hs delete mode 100644 Yesod/Helpers/Crud.hs delete mode 100644 hellowidget.hs 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