diff --git a/yesod-form/LICENSE b/yesod-form/LICENSE new file mode 100644 index 00000000..8643e5d8 --- /dev/null +++ b/yesod-form/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/yesod-form/README b/yesod-form/README new file mode 100644 index 00000000..e69de29b diff --git a/yesod-form/Setup.lhs b/yesod-form/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/yesod-form/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/Yesod/Form.hs b/yesod-form/Yesod/Form.hs new file mode 100644 index 00000000..4345e7da --- /dev/null +++ b/yesod-form/Yesod/Form.hs @@ -0,0 +1,14 @@ +-- | Parse forms (and query strings). +module Yesod.Form + ( module Yesod.Form.Types + , module Yesod.Form.Functions + , module Yesod.Form.Fields + , module Yesod.Form.Class + , module Yesod.Form.Input + ) where + +import Yesod.Form.Types +import Yesod.Form.Functions +import Yesod.Form.Fields +import Yesod.Form.Class +import Yesod.Form.Input diff --git a/yesod-form/Yesod/Form/Class.hs b/yesod-form/Yesod/Form/Class.hs new file mode 100644 index 00000000..cdac8dc7 --- /dev/null +++ b/yesod-form/Yesod/Form/Class.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Yesod.Form.Class + ( ToForm (..) + , ToField (..) + ) where + +import Text.Hamlet +import Yesod.Widget (GGWidget) +import Yesod.Form.Fields +import Yesod.Form.Types +import Yesod.Form.Functions (areq, aopt) +import Data.Int (Int64) +import Data.Time (Day, TimeOfDay) +import Data.Text (Text) +import Yesod.Handler (GGHandler) +import Yesod.Message (RenderMessage) + +class ToForm a master monad where + toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a + +class ToField a master monad where + toField :: RenderMessage master msg => FieldSettings msg -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a + +{- FIXME +instance ToFormField String y where + toFormField = stringField +instance ToFormField (Maybe String) y where + toFormField = maybeStringField +-} + +instance (Monad m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where + toField = areq textField +instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where + toField = aopt textField + +instance (Monad m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where + toField = areq intField +instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where + toField = aopt intField + +instance (Monad m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where + toField = areq intField +instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where + toField = aopt intField + +instance (Monad m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where + toField = areq doubleField +instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where + toField = aopt doubleField + +instance (Monad m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where + toField = areq dayField +instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where + toField = aopt dayField + +instance (Monad m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where + toField = areq timeField +instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where + toField = aopt timeField + +instance (Monad m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where + toField = areq htmlField +instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where + toField = aopt htmlField + +instance (Monad m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where + toField = areq textareaField +instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where + toField = aopt textareaField + +{- FIXME +instance ToFormField Bool y where + toFormField = boolField +-} diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs new file mode 100644 index 00000000..3e9f6bc0 --- /dev/null +++ b/yesod-form/Yesod/Form/Fields.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +module Yesod.Form.Fields + ( FormMessage (..) + , defaultFormMessage + , textField + , passwordField + , textareaField + , hiddenField + , intField + , dayField + , timeField + , htmlField + , emailField + , searchField + , selectField + , multiSelectField + , AutoFocus + , urlField + , doubleField + , parseDate + , parseTime + , Textarea (..) + , radioField + , boolField + ) where + +import Yesod.Form.Types +import Yesod.Widget +import Yesod.Message (RenderMessage) +import Yesod.Handler (GGHandler) +import Text.Hamlet +import Text.Blaze (ToHtml (..), preEscapedString, unsafeByteString) +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, unless) +import Data.List (intersect, nub) +import Data.Either (rights) +import Data.Maybe (catMaybes) + +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 +import Data.Text (Text, unpack, pack) +import qualified Data.Text.Read +import Data.Monoid (mappend) +import Text.Hamlet (html) + +#if __GLASGOW_HASKELL__ >= 700 +#define WHAMLET whamlet +#define HAMLET hamlet +#define CASSIUS cassius +#define JULIUS julius +#define HTML html +#else +#define WHAMLET $whamlet +#define HAMLET $hamlet +#define CASSIUS $cassius +#define JULIUS $julius +#define HTML $html +#endif + +data FormMessage = MsgInvalidInteger Text + | MsgInvalidNumber Text + | MsgInvalidEntry Text + | MsgInvalidUrl Text + | MsgInvalidEmail Text + | MsgInvalidTimeFormat + | MsgInvalidHour Text + | MsgInvalidMinute Text + | MsgInvalidSecond Text + | MsgInvalidDay + | MsgCsrfWarning + | MsgValueRequired + | MsgInputNotFound Text + | MsgSelectNone + | MsgInvalidBool Text + | MsgBoolYes + | MsgBoolNo + +defaultFormMessage :: FormMessage -> Text +defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t +defaultFormMessage (MsgInvalidNumber t) = "Invalid number: " `mappend` t +defaultFormMessage (MsgInvalidEntry t) = "Invalid entry: " `mappend` t +defaultFormMessage MsgInvalidTimeFormat = "Invalid time, must be in HH:MM[:SS] format" +defaultFormMessage MsgInvalidDay = "Invalid day, must be in YYYY-MM-DD format" +defaultFormMessage (MsgInvalidUrl t) = "Invalid URL: " `mappend` t +defaultFormMessage (MsgInvalidEmail t) = "Invalid e-mail address: " `mappend` t +defaultFormMessage (MsgInvalidHour t) = "Invalid hour: " `mappend` t +defaultFormMessage (MsgInvalidMinute t) = "Invalid minute: " `mappend` t +defaultFormMessage (MsgInvalidSecond t) = "Invalid second: " `mappend` t +defaultFormMessage MsgCsrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission." +defaultFormMessage MsgValueRequired = "Value is required" +defaultFormMessage (MsgInputNotFound t) = "Input not found: " `mappend` t +defaultFormMessage MsgSelectNone = "" +defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t +defaultFormMessage MsgBoolYes = "Yes" +defaultFormMessage MsgBoolNo = "No" + +blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a) +blank _ [] = Right Nothing +blank _ ("":_) = Right Nothing +blank f (x:_) = either Left (Right . Just) $ f x + + + +intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i +intField = Field + { fieldParse = blank $ \s -> + case Data.Text.Read.signed Data.Text.Read.decimal s of + Right (a, "") -> Right a + _ -> Left $ MsgInvalidInteger s + + , fieldView = \theId name val isReq -> addHamlet + [HAMLET|\ + +|] + } + where + showVal = either id (pack . showI) + showI x = show (fromIntegral x :: Integer) + +doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double +doubleField = Field + { fieldParse = blank $ \s -> + case Data.Text.Read.double s of + Right (a, "") -> Right a + _ -> Left $ MsgInvalidNumber s + + , fieldView = \theId name val isReq -> addHamlet + [HAMLET|\ + +|] + } + where showVal = either id (pack . show) + +dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day +dayField = Field + { fieldParse = blank $ parseDate . unpack + , fieldView = \theId name val isReq -> addHamlet + [HAMLET|\ + +|] + } + where showVal = either id (pack . show) + +timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay +timeField = Field + { fieldParse = blank $ parseTime . unpack + , fieldView = \theId name val isReq -> addHamlet + [HAMLET|\ + +|] + } + where + showVal = either id (pack . show . roundFullSeconds) + roundFullSeconds tod = + TimeOfDay (todHour tod) (todMin tod) fullSec + where + fullSec = fromInteger $ floor $ todSec tod + +htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html +htmlField = Field + { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize + , fieldView = \theId name val _isReq -> addHamlet + [HAMLET|\ +