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