Add 'yesod-form/' from commit '53b7c3b81015e7f244c6b8961ca2f07979f932e2'
git-subtree-dir: yesod-form git-subtree-mainline:41faf62094git-subtree-split:53b7c3b810
This commit is contained in:
Michael Snoyman
commit
6f5459f70f
25
yesod-form/LICENSE
Normal file
25
yesod-form/LICENSE
Normal file
@ -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.
|
||||
0
yesod-form/README
Normal file
0
yesod-form/README
Normal file
7
yesod-form/Setup.lhs
Executable file
7
yesod-form/Setup.lhs
Executable file
@ -0,0 +1,7 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
|
||||
> module Main where
|
||||
> import Distribution.Simple
|
||||
|
||||
> main :: IO ()
|
||||
> main = defaultMain
|
||||
14
yesod-form/Yesod/Form.hs
Normal file
14
yesod-form/Yesod/Form.hs
Normal file
@ -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
|
||||
77
yesod-form/Yesod/Form/Class.hs
Normal file
77
yesod-form/Yesod/Form/Class.hs
Normal file
@ -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
|
||||
-}
|
||||
421
yesod-form/Yesod/Form/Fields.hs
Normal file
421
yesod-form/Yesod/Form/Fields.hs
Normal file
@ -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 = "<None>"
|
||||
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|\
|
||||
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
}
|
||||
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|\
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
}
|
||||
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|\
|
||||
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
}
|
||||
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|\
|
||||
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
}
|
||||
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|\
|
||||
<textarea id="#{theId}" name="#{name}" .html>#{showVal val}
|
||||
|]
|
||||
}
|
||||
where showVal = either id (pack . renderHtml)
|
||||
|
||||
-- | A newtype wrapper around a 'String' that converts newlines to HTML
|
||||
-- br-tags.
|
||||
newtype Textarea = Textarea { unTextarea :: Text }
|
||||
deriving (Show, Read, Eq, PersistField)
|
||||
instance ToHtml Textarea where
|
||||
toHtml =
|
||||
unsafeByteString
|
||||
. S.concat
|
||||
. L.toChunks
|
||||
. toLazyByteString
|
||||
. fromWriteList writeHtmlEscapedChar
|
||||
. unpack
|
||||
. unTextarea
|
||||
where
|
||||
-- Taken from blaze-builder and modified with newline handling.
|
||||
writeHtmlEscapedChar '\n' = writeByteString "<br>"
|
||||
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
|
||||
|
||||
textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
|
||||
textareaField = Field
|
||||
{ fieldParse = blank $ Right . Textarea
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<textarea id="#{theId}" name="#{name}">#{either id unTextarea val}
|
||||
|]
|
||||
}
|
||||
|
||||
hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
hiddenField = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}">
|
||||
|]
|
||||
}
|
||||
|
||||
textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
textField = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val isReq ->
|
||||
[WHAMLET|
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}">
|
||||
|]
|
||||
}
|
||||
|
||||
passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
passwordField = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}">
|
||||
|]
|
||||
}
|
||||
|
||||
readMay :: Read a => String -> Maybe a
|
||||
readMay s = case reads s of
|
||||
(x, _):_ -> Just x
|
||||
[] -> Nothing
|
||||
|
||||
parseDate :: String -> Either FormMessage Day
|
||||
parseDate = maybe (Left MsgInvalidDay) 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 FormMessage 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 MsgInvalidTimeFormat
|
||||
|
||||
parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
|
||||
-> Either FormMessage TimeOfDay
|
||||
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
||||
| h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]
|
||||
| m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]
|
||||
| s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]
|
||||
| otherwise = Right $ TimeOfDay h m s
|
||||
where
|
||||
h = read [h1, h2] -- FIXME isn't this a really bad idea?
|
||||
m = read [m1, m2]
|
||||
s = fromInteger $ read [s1, s2]
|
||||
|
||||
emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
emailField = Field
|
||||
{ fieldParse = blank $
|
||||
\s -> if Email.isValid (unpack s)
|
||||
then Right s
|
||||
else Left $ MsgInvalidEmail s
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}">
|
||||
|]
|
||||
}
|
||||
|
||||
type AutoFocus = Bool
|
||||
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
|
||||
searchField autoFocus = Field
|
||||
{ fieldParse = blank Right
|
||||
, fieldView = \theId name val isReq -> do
|
||||
[WHAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|
||||
|]
|
||||
when autoFocus $ do
|
||||
[WHAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script>
|
||||
|]
|
||||
addCassius [CASSIUS|
|
||||
#{theId}
|
||||
-webkit-appearance: textfield
|
||||
|]
|
||||
}
|
||||
|
||||
urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
urlField = Field
|
||||
{ fieldParse = blank $ \s ->
|
||||
case parseURI $ unpack s of
|
||||
Nothing -> Left $ MsgInvalidUrl s
|
||||
Just _ -> Right s
|
||||
, fieldView = \theId name val isReq ->
|
||||
[WHAMLET|
|
||||
<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}>
|
||||
|]
|
||||
}
|
||||
|
||||
selectField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a
|
||||
selectField = selectFieldHelper
|
||||
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|])
|
||||
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])
|
||||
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
|
||||
|
||||
multiSelectField :: (Show a, Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage [a]
|
||||
multiSelectField = multiSelectFieldHelper
|
||||
(\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])
|
||||
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
|
||||
|
||||
radioField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a
|
||||
radioField = selectFieldHelper
|
||||
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
|
||||
(\theId name isSel -> [WHAMLET|
|
||||
<div>
|
||||
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
|
||||
<label for=#{theId}-none>_{MsgSelectNone}
|
||||
|])
|
||||
(\theId name value isSel text -> [WHAMLET|
|
||||
<div>
|
||||
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked>
|
||||
<label for=#{theId}-#{value}>#{text}
|
||||
|])
|
||||
|
||||
boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool
|
||||
boolField = Field
|
||||
{ fieldParse = boolParser
|
||||
, fieldView = \theId name val isReq -> [WHAMLET|
|
||||
$if not isReq
|
||||
<input id=#{theId}-none type=radio name=#{name} value=none checked>
|
||||
<label for=#{theId}-none>_{MsgSelectNone}
|
||||
|
||||
|
||||
<input id=#{theId}-yes type=radio name=#{name} value=yes :showVal id val:checked>
|
||||
<label for=#{theId}-yes>_{MsgBoolYes}
|
||||
|
||||
<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked>
|
||||
<label for=#{theId}-no>_{MsgBoolNo}
|
||||
|]
|
||||
}
|
||||
where
|
||||
boolParser [] = Right Nothing
|
||||
boolParser (x:_) = case x of
|
||||
"" -> Right Nothing
|
||||
"none" -> Right Nothing
|
||||
"yes" -> Right $ Just True
|
||||
"no" -> Right $ Just False
|
||||
t -> Left $ MsgInvalidBool t
|
||||
showVal = either (\_ -> False)
|
||||
|
||||
multiSelectFieldHelper :: (Show a, Eq a, Monad monad)
|
||||
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
||||
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage [a]
|
||||
multiSelectFieldHelper outside inside opts = Field
|
||||
{ fieldParse = selectParser
|
||||
, fieldView = \theId name vals _ ->
|
||||
outside theId name $ do
|
||||
flip mapM_ pairs $ \pair -> inside
|
||||
theId
|
||||
name
|
||||
(pack $ show $ fst pair)
|
||||
((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values
|
||||
(fst $ snd pair)
|
||||
}
|
||||
where
|
||||
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
|
||||
rpairs = zip (map snd opts) [1 :: Int ..]
|
||||
selectedVals vals = map snd $ filter (\y -> fst y `elem` vals) rpairs
|
||||
selectParser [] = Right Nothing
|
||||
selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing
|
||||
| otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs
|
||||
|
||||
selectFieldHelper :: (Eq a, Monad monad)
|
||||
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
|
||||
-> (Text -> Text -> Bool -> GGWidget master monad ())
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
||||
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
|
||||
selectFieldHelper outside onOpt inside opts = Field
|
||||
{ fieldParse = selectParser
|
||||
, fieldView = \theId name val isReq ->
|
||||
outside theId name $ do
|
||||
unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs
|
||||
flip mapM_ pairs $ \pair -> inside
|
||||
theId
|
||||
name
|
||||
(pack $ show $ fst pair)
|
||||
((render val) == pack (show $ fst pair))
|
||||
(fst $ snd pair)
|
||||
}
|
||||
where
|
||||
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
|
||||
rpairs = zip (map snd opts) [1 :: Int ..]
|
||||
render (Left _) = ""
|
||||
render (Right a) = maybe "" (pack . show) $ lookup a rpairs
|
||||
selectParser [] = Right Nothing
|
||||
selectParser (s:_) = case s of
|
||||
"" -> Right Nothing
|
||||
"none" -> Right Nothing
|
||||
x -> case Data.Text.Read.decimal x of
|
||||
Right (a, "") ->
|
||||
case lookup a pairs of
|
||||
Nothing -> Left $ MsgInvalidEntry x
|
||||
Just y -> Right $ Just $ snd y
|
||||
_ -> Left $ MsgInvalidNumber x
|
||||
234
yesod-form/Yesod/Form/Functions.hs
Normal file
234
yesod-form/Yesod/Form/Functions.hs
Normal file
@ -0,0 +1,234 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Form.Functions
|
||||
( -- * Running in Form monad
|
||||
newFormIdent
|
||||
, askParams
|
||||
, askFiles
|
||||
-- * Applicative/Monadic conversion
|
||||
, formToAForm
|
||||
, aFormToForm
|
||||
-- * Fields to Forms
|
||||
, mreq
|
||||
, mopt
|
||||
, areq
|
||||
, aopt
|
||||
-- * Run a form
|
||||
, runFormPost
|
||||
, runFormPostNoNonce
|
||||
, runFormGet
|
||||
-- * Rendering
|
||||
, FormRender
|
||||
, renderTable
|
||||
, renderDivs
|
||||
) where
|
||||
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Form.Fields (FormMessage (MsgCsrfWarning, MsgValueRequired))
|
||||
import Data.Text (Text, pack)
|
||||
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad (liftM, join)
|
||||
import Text.Blaze (Html, toHtml)
|
||||
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)
|
||||
import Yesod.Core (RenderMessage)
|
||||
import Yesod.Widget (GGWidget, whamlet)
|
||||
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
|
||||
import Network.Wai (requestMethod)
|
||||
import Text.Hamlet (html)
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define WHAMLET whamlet
|
||||
#define HTML html
|
||||
#else
|
||||
#define HTML $html
|
||||
#define WHAMLET $whamlet
|
||||
#endif
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newFormIdent :: Monad m => Form msg m Text
|
||||
newFormIdent = do
|
||||
i <- get
|
||||
let i' = incrInts i
|
||||
put i'
|
||||
return $ pack $ 'f' : show i'
|
||||
where
|
||||
incrInts (IntSingle i) = IntSingle $ i + 1
|
||||
incrInts (IntCons i is) = (i + 1) `IntCons` is
|
||||
|
||||
formToAForm :: Monad m => Form msg m (FormResult a, xml) -> AForm ([xml] -> [xml]) msg m a
|
||||
formToAForm form = AForm $ \(master, langs) env ints -> do
|
||||
((a, xml), ints', enc) <- runRWST form (env, master, langs) ints
|
||||
return (a, (:) xml, ints', enc)
|
||||
|
||||
aFormToForm :: Monad m => AForm xml msg m a -> Form msg m (FormResult a, xml)
|
||||
aFormToForm (AForm aform) = do
|
||||
ints <- get
|
||||
(env, master, langs) <- ask
|
||||
(a, xml, ints', enc) <- lift $ aform (master, langs) env ints
|
||||
put ints'
|
||||
tell enc
|
||||
return (a, xml)
|
||||
|
||||
askParams :: Monad m => Form msg m (Maybe Env)
|
||||
askParams = do
|
||||
(x, _, _) <- ask
|
||||
return $ liftM fst x
|
||||
|
||||
askFiles :: Monad m => Form msg m (Maybe FileEnv)
|
||||
askFiles = do
|
||||
(x, _, _) <- ask
|
||||
return $ liftM snd x
|
||||
|
||||
mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage)
|
||||
=> Field xml msg a -> FieldSettings msg2 -> Maybe a
|
||||
-> Form master (GGHandler sub master m) (FormResult a, FieldView xml)
|
||||
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
|
||||
|
||||
mopt :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)
|
||||
-> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)
|
||||
mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
|
||||
|
||||
mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a
|
||||
-> FieldSettings msg2
|
||||
-> Maybe a
|
||||
-> (master -> [Text] -> FormResult b) -- ^ on missing
|
||||
-> (a -> FormResult b) -- ^ on success
|
||||
-> Bool -- ^ is it required?
|
||||
-> Form master (GGHandler sub master m) (FormResult b, FieldView xml)
|
||||
|
||||
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
mp <- askParams
|
||||
name <- maybe newFormIdent return fsName
|
||||
theId <- lift $ maybe (liftM pack newIdent) return fsId
|
||||
(_, master, langs) <- ask
|
||||
let mr2 = renderMessage master langs
|
||||
let (res, val) =
|
||||
case mp of
|
||||
Nothing -> (FormMissing, maybe (Left "") Right mdef)
|
||||
Just p ->
|
||||
let mvals = map snd $ filter (\(n,_) -> n == name) p
|
||||
in case fieldParse mvals of
|
||||
Left e -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
|
||||
Right mx ->
|
||||
case mx of
|
||||
Nothing -> (onMissing master langs, Left "")
|
||||
Just x -> (onFound x, Right x)
|
||||
return (res, FieldView
|
||||
{ fvLabel = toHtml $ mr2 fsLabel
|
||||
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
|
||||
, fvId = theId
|
||||
, fvInput = fieldView theId name val isReq
|
||||
, fvErrors =
|
||||
case res of
|
||||
FormFailure [e] -> Just $ toHtml e
|
||||
_ -> Nothing
|
||||
, fvRequired = isReq
|
||||
})
|
||||
|
||||
areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage)
|
||||
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe a
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a
|
||||
areq a b = formToAForm . mreq a b
|
||||
|
||||
aopt :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
|
||||
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a)
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a)
|
||||
aopt a b = formToAForm . mopt a b
|
||||
|
||||
runFormGeneric :: Monad m => Form master m a -> master -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype)
|
||||
runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)
|
||||
|
||||
runFormPost :: RenderMessage master FormMessage
|
||||
=> (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
|
||||
runFormPost form = do
|
||||
req <- getRequest
|
||||
let nonceKey = "_nonce"
|
||||
let nonce =
|
||||
case reqNonce req of
|
||||
Nothing -> mempty
|
||||
Just n -> [HTML|<input type=hidden name=#{nonceKey} value=#{n}>|]
|
||||
env <- if requestMethod (reqWaiRequest req) == "GET"
|
||||
then return Nothing
|
||||
else fmap Just runRequestBody
|
||||
m <- getYesod
|
||||
langs <- languages
|
||||
((res, xml), enctype) <- runFormGeneric (form nonce) m langs env
|
||||
let res' =
|
||||
case (res, env) of
|
||||
(FormSuccess{}, Just (params, _))
|
||||
| lookup nonceKey params /= reqNonce req ->
|
||||
FormFailure [renderMessage m langs MsgCsrfWarning]
|
||||
_ -> res
|
||||
return ((res', xml), enctype)
|
||||
|
||||
runFormPostNoNonce :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
|
||||
runFormPostNoNonce form = do
|
||||
req <- getRequest
|
||||
env <- if requestMethod (reqWaiRequest req) == "GET"
|
||||
then return Nothing
|
||||
else fmap Just runRequestBody
|
||||
langs <- languages
|
||||
m <- getYesod
|
||||
runFormGeneric (form mempty) m langs env
|
||||
|
||||
runFormGet :: Monad m => (Html -> Form master (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype)
|
||||
runFormGet form = do
|
||||
let key = "_hasdata"
|
||||
let fragment = [HTML|<input type=hidden name=#{key}>|]
|
||||
gets <- liftM reqGetParams getRequest
|
||||
let env =
|
||||
case lookup key gets of
|
||||
Nothing -> Nothing
|
||||
Just _ -> Just (gets, [])
|
||||
langs <- languages
|
||||
m <- getYesod
|
||||
runFormGeneric (form fragment) m langs env
|
||||
|
||||
type FormRender master msg m a =
|
||||
AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) msg m a
|
||||
-> Html
|
||||
-> Form msg m (FormResult a, GGWidget master m ())
|
||||
|
||||
renderTable, renderDivs :: Monad m => FormRender master msg m a
|
||||
renderTable aform fragment = do
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
-- FIXME non-valid HTML
|
||||
let widget = [WHAMLET|
|
||||
\#{fragment}
|
||||
$forall view <- views
|
||||
<tr :fvRequired view:.required :not $ fvRequired view:.optional>
|
||||
<td>
|
||||
<label for=#{fvId view}>#{fvLabel view}
|
||||
$maybe tt <- fvTooltip view
|
||||
<div .tooltip>#{tt}
|
||||
<td>^{fvInput view}
|
||||
$maybe err <- fvErrors view
|
||||
<td .errors>#{err}
|
||||
|]
|
||||
return (res, widget)
|
||||
|
||||
renderDivs aform fragment = do
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
let widget = [WHAMLET|
|
||||
\#{fragment}
|
||||
$forall view <- views
|
||||
<div :fvRequired view:.required :not $ fvRequired view:.optional>
|
||||
<label for=#{fvId view}>#{fvLabel view}
|
||||
$maybe tt <- fvTooltip view
|
||||
<div .tooltip>#{tt}
|
||||
^{fvInput view}
|
||||
$maybe err <- fvErrors view
|
||||
<div .errors>#{err}
|
||||
|]
|
||||
return (res, widget)
|
||||
65
yesod-form/Yesod/Form/Input.hs
Normal file
65
yesod-form/Yesod/Form/Input.hs
Normal file
@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Form.Input
|
||||
( FormInput (..)
|
||||
, runInputGet
|
||||
, runInputPost
|
||||
, ireq
|
||||
, iopt
|
||||
) where
|
||||
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Form.Fields (FormMessage (MsgInputNotFound))
|
||||
import Data.Text (Text)
|
||||
import Control.Applicative (Applicative (..))
|
||||
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod)
|
||||
import Yesod.Request (reqGetParams, languages)
|
||||
import Control.Monad (liftM)
|
||||
import Yesod.Widget (GWidget)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
|
||||
type DText = [Text] -> [Text]
|
||||
newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> Either DText a }
|
||||
instance Functor (FormInput master) where
|
||||
fmap a (FormInput f) = FormInput $ \c d e -> either Left (Right . a) $ f c d e
|
||||
instance Applicative (FormInput master) where
|
||||
pure = FormInput . const . const . const . Right
|
||||
(FormInput f) <*> (FormInput x) = FormInput $ \c d e ->
|
||||
case (f c d e, x c d e) of
|
||||
(Left a, Left b) -> Left $ a . b
|
||||
(Left a, _) -> Left a
|
||||
(_, Left b) -> Left b
|
||||
(Right a, Right b) -> Right $ a b
|
||||
|
||||
ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
|
||||
ireq field name = FormInput $ \m l env ->
|
||||
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
||||
in case fieldParse field $ filteredEnv of
|
||||
Left e -> Left $ (:) $ renderMessage m l e
|
||||
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
|
||||
Right (Just a) -> Right a
|
||||
|
||||
iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)
|
||||
iopt field name = FormInput $ \m l env ->
|
||||
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
||||
in case fieldParse field $ filteredEnv of
|
||||
Left e -> Left $ (:) $ renderMessage m l e
|
||||
Right x -> Right x
|
||||
|
||||
runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a
|
||||
runInputGet (FormInput f) = do
|
||||
env <- liftM reqGetParams getRequest
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
case f m l env of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
Right x -> return x
|
||||
|
||||
runInputPost :: FormInput master a -> GHandler sub master a
|
||||
runInputPost (FormInput f) = do
|
||||
env <- liftM fst runRequestBody
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
case f m l env of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
Right x -> return x
|
||||
205
yesod-form/Yesod/Form/Jquery.hs
Normal file
205
yesod-form/Yesod/Form/Jquery.hs
Normal file
@ -0,0 +1,205 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove
|
||||
-- | Some fields spiced up with jQuery UI.
|
||||
module Yesod.Form.Jquery
|
||||
( YesodJquery (..)
|
||||
, jqueryDayField
|
||||
, jqueryDayTimeField
|
||||
, jqueryAutocompleteField
|
||||
, googleHostedJqueryUiCss
|
||||
, JqueryDaySettings (..)
|
||||
, Default (..)
|
||||
) where
|
||||
|
||||
import Yesod.Handler
|
||||
import Yesod.Form
|
||||
import Yesod.Widget
|
||||
import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
|
||||
timeToTimeOfDay)
|
||||
import Data.Char (isSpace)
|
||||
import Data.Default
|
||||
import Text.Hamlet (html)
|
||||
import Text.Julius (julius)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Data.Monoid (mconcat)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define HTML html
|
||||
#define HAMLET hamlet
|
||||
#define CASSIUS cassius
|
||||
#define JULIUS julius
|
||||
#else
|
||||
#define HTML $html
|
||||
#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 :: Text -> Text
|
||||
googleHostedJqueryUiCss theme = mconcat
|
||||
[ "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) Text
|
||||
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) Text
|
||||
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) Text
|
||||
urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino"
|
||||
|
||||
-- | jQuery UI time picker add-on.
|
||||
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
|
||||
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
|
||||
|
||||
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
|
||||
|
||||
jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
|
||||
jqueryDayField jds = Field
|
||||
{ fieldParse = blank $ maybe
|
||||
(Left MsgInvalidDay)
|
||||
Right
|
||||
. readMay
|
||||
. unpack
|
||||
, fieldView = \theId name val isReq -> do
|
||||
addHtml [HTML|\
|
||||
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal 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
|
||||
showVal = either id (pack . show)
|
||||
jsBool True = "true" :: Text
|
||||
jsBool False = "false" :: Text
|
||||
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
|
||||
|
||||
-- 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 (showLeadingZero h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
|
||||
|
||||
jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime
|
||||
jqueryDayTimeField = Field
|
||||
{ fieldParse = blank $ parseUTCTime . unpack
|
||||
, fieldView = \theId name val isReq -> do
|
||||
addHtml [HTML|\
|
||||
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
addScript' urlJqueryJs
|
||||
addScript' urlJqueryUiJs
|
||||
addScript' urlJqueryUiDateTimePicker
|
||||
addStylesheet' urlJqueryUiCss
|
||||
addJulius [JULIUS|
|
||||
$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd hh:MM TT"})});
|
||||
|]
|
||||
}
|
||||
where
|
||||
showVal = either id (pack . jqueryDayTimeUTCTime)
|
||||
|
||||
parseUTCTime :: String -> Either FormMessage UTCTime
|
||||
parseUTCTime s =
|
||||
let (dateS, timeS') = break isSpace (dropWhile isSpace s)
|
||||
timeS = drop 1 timeS'
|
||||
dateE = parseDate dateS
|
||||
in case dateE of
|
||||
Left l -> Left l
|
||||
Right date ->
|
||||
ifRight (parseTime timeS)
|
||||
(UTCTime date . timeOfDayToTime)
|
||||
|
||||
jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text
|
||||
jqueryAutocompleteField src = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val isReq -> do
|
||||
addHtml [HTML|\
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
|
||||
|]
|
||||
addScript' urlJqueryJs
|
||||
addScript' urlJqueryUiJs
|
||||
addStylesheet' urlJqueryUiCss
|
||||
addJulius [JULIUS|
|
||||
$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
|
||||
|]
|
||||
}
|
||||
|
||||
addScript' :: Monad m => (t -> Either (Route master) Text) -> GGWidget master (GGHandler sub t m) ()
|
||||
addScript' f = do
|
||||
y <- lift getYesod
|
||||
addScriptEither $ f y
|
||||
|
||||
addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y ()
|
||||
addStylesheet' f = do
|
||||
y <- lift 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
|
||||
}
|
||||
155
yesod-form/Yesod/Form/MassInput.hs
Normal file
155
yesod-form/Yesod/Form/MassInput.hs
Normal file
@ -0,0 +1,155 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Form.MassInput
|
||||
( inputList
|
||||
, massDivs
|
||||
, massTable
|
||||
) where
|
||||
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Form.Functions
|
||||
import Yesod.Form.Fields (boolField, FormMessage)
|
||||
import Yesod.Widget (GGWidget, whamlet)
|
||||
import Yesod.Message (RenderMessage)
|
||||
import Yesod.Handler (newIdent, GGHandler)
|
||||
import Text.Blaze (Html)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Text (pack, Text)
|
||||
import Control.Monad.Trans.RWS (get, put, ask)
|
||||
import Data.Maybe (fromMaybe, catMaybes)
|
||||
import Data.Text.Read (decimal)
|
||||
import Control.Monad (liftM)
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.Traversable (sequenceA)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define WHAMLET whamlet
|
||||
#define HTML html
|
||||
#else
|
||||
#define HTML $html
|
||||
#define WHAMLET $whamlet
|
||||
#endif
|
||||
|
||||
down 0 = return ()
|
||||
down i | i < 0 = error "called down with a negative number"
|
||||
down i = do
|
||||
is <- get
|
||||
put $ IntCons 0 is
|
||||
down $ i - 1
|
||||
|
||||
up 0 = return ()
|
||||
up i | i < 0 = error "called down with a negative number"
|
||||
up i = do
|
||||
is <- get
|
||||
case is of
|
||||
IntSingle _ -> error "up on IntSingle"
|
||||
IntCons _ is' -> put is' >> newFormIdent >> return ()
|
||||
up $ i - 1
|
||||
|
||||
inputList :: (Monad mo, m ~ GGHandler sub master mo, xml ~ GGWidget master (GGHandler sub master mo) (), RenderMessage master FormMessage)
|
||||
=> Html
|
||||
-> ([[FieldView xml]] -> xml)
|
||||
-> (Maybe a -> AForm ([FieldView xml] -> [FieldView xml]) master m a)
|
||||
-> (Maybe [a] -> AForm ([FieldView xml] -> [FieldView xml]) master m [a])
|
||||
inputList label fixXml single mdef = formToAForm $ do
|
||||
theId <- lift newIdent
|
||||
down 1
|
||||
countName <- newFormIdent
|
||||
addName <- newFormIdent
|
||||
(menv, _, _) <- ask
|
||||
let readInt t =
|
||||
case decimal t of
|
||||
Right (i, "") -> Just i
|
||||
_ -> Nothing
|
||||
let vals =
|
||||
case menv of
|
||||
Nothing -> map Just $ fromMaybe [] mdef
|
||||
Just (env, _) ->
|
||||
let toAdd = maybe False (const True) $ lookup addName env
|
||||
count' = fromMaybe 0 $ lookup countName env >>= readInt
|
||||
count = (if toAdd then 1 else 0) + count'
|
||||
in replicate count Nothing
|
||||
let count = length vals
|
||||
(res, xmls, views) <- liftM fixme $ mapM (withDelete . single) vals
|
||||
up 1
|
||||
return (res, FieldView
|
||||
{ fvLabel = label
|
||||
, fvTooltip = Nothing
|
||||
, fvId = pack theId
|
||||
, fvInput = [WHAMLET|
|
||||
^{fixXml views}
|
||||
<p>
|
||||
$forall xml <- xmls
|
||||
^{xml}
|
||||
<input .count type=hidden name=#{countName} value=#{count}>
|
||||
<input type=checkbox name=#{addName}>
|
||||
Add another row
|
||||
|]
|
||||
, fvErrors = Nothing
|
||||
, fvRequired = False
|
||||
})
|
||||
|
||||
withDelete :: (xml ~ GGWidget master m (), m ~ GGHandler sub master mo, Monad mo, RenderMessage master FormMessage)
|
||||
=> AForm ([FieldView xml] -> [FieldView xml]) master m a
|
||||
-> Form master m (Either xml (FormResult a, [FieldView xml]))
|
||||
withDelete af = do
|
||||
down 1
|
||||
deleteName <- newFormIdent
|
||||
(menv, _, _) <- ask
|
||||
res <- case menv >>= lookup deleteName . fst of
|
||||
Just "yes" -> return $ Left [WHAMLET|<input type=hidden name=#{deleteName} value=yes>|]
|
||||
_ -> do
|
||||
(_, xml2) <- aFormToForm $ areq boolField FieldSettings
|
||||
{ fsLabel = "Delete?" :: Text -- FIXME
|
||||
, fsTooltip = Nothing
|
||||
, fsName = Just deleteName
|
||||
, fsId = Nothing
|
||||
} $ Just False -- TRANS
|
||||
(res, xml) <- aFormToForm af
|
||||
return $ Right (res, xml [] ++ xml2 []) -- FIXME shouldn't need ++
|
||||
up 1
|
||||
return res
|
||||
|
||||
fixme :: (xml ~ GGWidget master (GGHandler sub master mo) ())
|
||||
=> [Either xml (FormResult a, [FieldView xml])]
|
||||
-> (FormResult [a], [xml], [[FieldView xml]])
|
||||
fixme eithers =
|
||||
(res, xmls, map snd rest)
|
||||
where
|
||||
(xmls, rest) = partitionEithers eithers
|
||||
res = sequenceA $ map fst rest
|
||||
|
||||
massDivs, massTable
|
||||
:: Monad m
|
||||
=> [[FieldView (GGWidget master m ())]]
|
||||
-> GGWidget master m ()
|
||||
massDivs viewss = [WHAMLET|
|
||||
$forall views <- viewss
|
||||
<fieldset>
|
||||
$forall view <- views
|
||||
<div :fvRequired view:.required :not $ fvRequired view:.optional>
|
||||
<label for=#{fvId view}>#{fvLabel view}
|
||||
$maybe tt <- fvTooltip view
|
||||
<div .tooltip>#{tt}
|
||||
^{fvInput view}
|
||||
$maybe err <- fvErrors view
|
||||
<div .errors>#{err}
|
||||
|]
|
||||
|
||||
massTable viewss = [WHAMLET|
|
||||
$forall views <- viewss
|
||||
<fieldset>
|
||||
<table>
|
||||
$forall view <- views
|
||||
<tr :fvRequired view:.required :not $ fvRequired view:.optional>
|
||||
<td>
|
||||
<label for=#{fvId view}>#{fvLabel view}
|
||||
$maybe tt <- fvTooltip view
|
||||
<div .tooltip>#{tt}
|
||||
<td>^{fvInput view}
|
||||
$maybe err <- fvErrors view
|
||||
<td .errors>#{err}
|
||||
|]
|
||||
64
yesod-form/Yesod/Form/Nic.hs
Normal file
64
yesod-form/Yesod/Form/Nic.hs
Normal file
@ -0,0 +1,64 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove
|
||||
-- | Provide the user with a rich text editor.
|
||||
module Yesod.Form.Nic
|
||||
( YesodNic (..)
|
||||
, nicHtmlField
|
||||
) where
|
||||
|
||||
import Yesod.Handler
|
||||
import Yesod.Form
|
||||
import Yesod.Widget
|
||||
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
||||
import Text.Hamlet (Html, html)
|
||||
import Text.Julius (julius)
|
||||
import Text.Blaze.Renderer.String (renderHtml)
|
||||
import Text.Blaze (preEscapedString)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
|
||||
class YesodNic a where
|
||||
-- | NIC Editor Javascript file.
|
||||
urlNicEdit :: a -> Either (Route a) Text
|
||||
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
|
||||
nicHtmlField = Field
|
||||
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME
|
||||
, fieldView = \theId name val _isReq -> do
|
||||
addHtml
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
[html|
|
||||
#else
|
||||
[$html|
|
||||
#endif
|
||||
<textarea id="#{theId}" name="#{name}" .html>#{showVal val}
|
||||
|]
|
||||
addScript' urlNicEdit
|
||||
addJulius
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
[julius|
|
||||
#else
|
||||
[$julius|
|
||||
#endif
|
||||
bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});
|
||||
|]
|
||||
}
|
||||
where
|
||||
showVal = either id (pack . renderHtml)
|
||||
|
||||
addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
|
||||
addScript' f = do
|
||||
y <- lift getYesod
|
||||
addScriptEither $ f y
|
||||
123
yesod-form/Yesod/Form/Types.hs
Normal file
123
yesod-form/Yesod/Form/Types.hs
Normal file
@ -0,0 +1,123 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Yesod.Form.Types
|
||||
( -- * Helpers
|
||||
Enctype (..)
|
||||
, FormResult (..)
|
||||
, Env
|
||||
, FileEnv
|
||||
, Ints (..)
|
||||
-- * Form
|
||||
, Form
|
||||
, AForm (..)
|
||||
-- * Build forms
|
||||
, Field (..)
|
||||
, FieldSettings (..)
|
||||
, FieldView (..)
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
import Yesod.Request (FileInfo)
|
||||
import Data.Text (Text)
|
||||
import Data.Monoid (Monoid (..))
|
||||
import Text.Blaze (Html, ToHtml (toHtml))
|
||||
import Control.Applicative ((<$>), Applicative (..))
|
||||
import Control.Monad (liftM)
|
||||
import Data.String (IsString (..))
|
||||
import Control.Monad.Trans.Class (MonadTrans (..))
|
||||
|
||||
-- | 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 [Text]
|
||||
| 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 'ToHtml' instance produces values
|
||||
-- that can be inserted directly into HTML.
|
||||
data Enctype = UrlEncoded | Multipart
|
||||
deriving (Eq, Enum, Bounded)
|
||||
instance ToHtml Enctype where
|
||||
toHtml UrlEncoded = "application/x-www-form-urlencoded"
|
||||
toHtml Multipart = "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)
|
||||
|
||||
type Env = [(Text, Text)] -- FIXME use a Map
|
||||
type FileEnv = [(Text, FileInfo)]
|
||||
|
||||
type Form master m a = RWST (Maybe (Env, FileEnv), master, [Text]) Enctype Ints m a
|
||||
|
||||
newtype AForm xml master m a = AForm
|
||||
{ unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)
|
||||
}
|
||||
instance Monad m => Functor (AForm xml msg m) where
|
||||
fmap f (AForm a) =
|
||||
AForm $ \x y z -> liftM go $ a x y z
|
||||
where
|
||||
go (w, x, y, z) = (fmap f w, x, y, z)
|
||||
instance (Monad m, Monoid xml) => Applicative (AForm xml msg m) where
|
||||
pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
|
||||
(AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
|
||||
(a, b, ints', c) <- f mr env ints
|
||||
(x, y, ints'', z) <- g mr env ints'
|
||||
return (a <*> x, b `mappend` y, ints'', c `mappend` z)
|
||||
instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml msg m a) where
|
||||
mempty = pure mempty
|
||||
mappend a b = mappend <$> a <*> b
|
||||
instance Monoid xml => MonadTrans (AForm xml msg) where
|
||||
lift mx = AForm $ const $ const $ \ints -> do
|
||||
x <- mx
|
||||
return (pure x, mempty, ints, mempty)
|
||||
|
||||
data FieldSettings msg = FieldSettings
|
||||
{ fsLabel :: msg
|
||||
, fsTooltip :: Maybe msg
|
||||
, fsId :: Maybe Text
|
||||
, fsName :: Maybe Text
|
||||
}
|
||||
|
||||
instance (a ~ Text) => IsString (FieldSettings a) where
|
||||
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing
|
||||
|
||||
data FieldView xml = FieldView
|
||||
{ fvLabel :: Html
|
||||
, fvTooltip :: Maybe Html
|
||||
, fvId :: Text
|
||||
, fvInput :: xml
|
||||
, fvErrors :: Maybe Html
|
||||
, fvRequired :: Bool
|
||||
}
|
||||
|
||||
data Field xml msg a = Field
|
||||
{ fieldParse :: [Text] -> Either msg (Maybe a)
|
||||
, fieldView :: Text -- ^ ID
|
||||
-> Text -- ^ name
|
||||
-> Either Text a -- ^ value could be invalid text or a legitimate a
|
||||
-> Bool -- ^ required?
|
||||
-> xml
|
||||
}
|
||||
203
yesod-form/Yesod/Helpers/Crud.hs
Normal file
203
yesod-form/Yesod/Helpers/Crud.hs
Normal file
@ -0,0 +1,203 @@
|
||||
{-# 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.Core
|
||||
import Text.Hamlet
|
||||
import Yesod.Form
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Yesod.Persist
|
||||
import Data.Text (Text)
|
||||
import Web.Routes.Quasi (toSinglePiece, fromSinglePiece)
|
||||
|
||||
-- | 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 -> Text
|
||||
|
||||
-- | 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 ''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/#Text CrudEditR GET POST
|
||||
/delete/#Text 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 item <- items
|
||||
<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)
|
||||
=> Text -> GHandler (Crud master item) master RepHtml
|
||||
getCrudEditR s = do
|
||||
itemId <- maybe notFound return $ fromSinglePiece 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)
|
||||
=> Text -> GHandler (Crud master item) master RepHtml
|
||||
postCrudEditR s = do
|
||||
itemId <- maybe notFound return $ fromSinglePiece 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))
|
||||
=> Text -> GHandler (Crud master item) master RepHtml
|
||||
getCrudDeleteR s = do
|
||||
itemId <- maybe notFound return $ fromSinglePiece 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))
|
||||
=> Text -> GHandler (Crud master item) master RepHtml
|
||||
postCrudDeleteR s = do
|
||||
itemId <- maybe notFound return $ fromSinglePiece s
|
||||
crud <- getYesodSub
|
||||
toMaster <- getRouteToMaster
|
||||
crudDelete crud itemId
|
||||
redirect RedirectTemporary $ toMaster CrudListR
|
||||
|
||||
crudHelper
|
||||
:: (Item a, Yesod master, SinglePiece (Key a), ToForm a master)
|
||||
=> Text -> 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 $ toHtml 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 e <- me
|
||||
\
|
||||
<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 (GGHandler (Crud a i) a IO)),
|
||||
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
|
||||
}
|
||||
74
yesod-form/hello-forms.hs
Normal file
74
yesod-form/hello-forms.hs
Normal file
@ -0,0 +1,74 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
import Yesod.Core
|
||||
import Yesod.Form
|
||||
import Yesod.Form.MassInput
|
||||
import Control.Applicative
|
||||
import Data.Text (Text, pack)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
|
||||
data Fruit = Apple | Banana | Pear
|
||||
deriving (Show, Enum, Bounded, Eq)
|
||||
|
||||
fruits :: [(Text, Fruit)]
|
||||
fruits = map (\x -> (pack $ show x, x)) [minBound..maxBound]
|
||||
|
||||
myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
|
||||
<*> areq boolField "Bool field" Nothing
|
||||
<*> aopt boolField "Opt bool field" Nothing
|
||||
<*> areq textField "Text field" Nothing
|
||||
<*> areq (selectField fruits) "Select field" Nothing
|
||||
<*> aopt (selectField fruits) "Opt select field" Nothing
|
||||
<*> areq (multiSelectField fruits) "Multi select field" Nothing
|
||||
<*> aopt (multiSelectField fruits) "Opt multi select field" Nothing
|
||||
<*> aopt intField "Opt int field" Nothing
|
||||
<*> aopt (radioField fruits) "Opt radio" Nothing
|
||||
|
||||
data HelloForms = HelloForms
|
||||
type Handler = GHandler HelloForms HelloForms
|
||||
|
||||
fixType :: Handler a -> Handler a
|
||||
fixType = id
|
||||
|
||||
instance RenderMessage HelloForms FormMessage where
|
||||
renderMessage _ _ = defaultFormMessage
|
||||
|
||||
instance Yesod HelloForms where
|
||||
approot _ = ""
|
||||
|
||||
mkYesod "HelloForms" [parseRoutes|
|
||||
/ RootR GET
|
||||
/mass MassR GET
|
||||
|]
|
||||
|
||||
getRootR = do
|
||||
((res, form), enctype) <- myForm
|
||||
defaultLayout [whamlet|
|
||||
<p>Result: #{show res}
|
||||
<form enctype=#{enctype}>
|
||||
^{form}
|
||||
<div>
|
||||
<input type=submit>
|
||||
<p>
|
||||
<a href=@{MassR}>See the mass form
|
||||
|]
|
||||
|
||||
myMassForm = fixType $ runFormGet $ renderTable $ inputList "People" massTable
|
||||
(\x -> (,)
|
||||
<$> areq textField "Name" (fmap fst x)
|
||||
<*> areq intField "Age" (fmap snd x)) (Just [("Michael", 26)])
|
||||
|
||||
getMassR = do
|
||||
((res, form), enctype) <- myMassForm
|
||||
defaultLayout [whamlet|
|
||||
<p>Result: #{show res}
|
||||
<form enctype=#{enctype}>
|
||||
<table>
|
||||
^{form}
|
||||
<div>
|
||||
<input type=submit>
|
||||
<p>
|
||||
<a href=@{RootR}>See the regular form
|
||||
|]
|
||||
|
||||
main = toWaiApp HelloForms >>= run 3000
|
||||
46
yesod-form/yesod-form.cabal
Normal file
46
yesod-form/yesod-form.cabal
Normal file
@ -0,0 +1,46 @@
|
||||
name: yesod-form
|
||||
version: 0.3.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: Form handling support for Yesod Web Framework
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, time >= 1.1.4 && < 1.3
|
||||
, hamlet >= 0.9 && < 0.10
|
||||
, persistent >= 0.6 && < 0.7
|
||||
, yesod-persistent >= 0.2 && < 0.3
|
||||
, 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.4
|
||||
, network >= 2.2 && < 2.4
|
||||
, email-validate >= 0.2.6 && < 0.3
|
||||
, blaze-html >= 0.4 && < 0.5
|
||||
, bytestring >= 0.9 && < 0.10
|
||||
, text >= 0.7 && < 1.0
|
||||
, web-routes-quasi >= 0.7 && < 0.8
|
||||
, wai >= 0.4 && < 0.5
|
||||
exposed-modules: Yesod.Form
|
||||
Yesod.Form.Class
|
||||
Yesod.Form.Types
|
||||
Yesod.Form.Functions
|
||||
Yesod.Form.Input
|
||||
Yesod.Form.Fields
|
||||
Yesod.Form.Jquery
|
||||
Yesod.Form.Nic
|
||||
-- FIXME Yesod.Helpers.Crud
|
||||
ghc-options: -Wall
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://github.com/snoyberg/yesod-form.git
|
||||
Loading…
Reference in New Issue
Block a user