{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Form.Fields
( -- * i18n
FormMessage (..)
, defaultFormMessage
-- * Fields
, textField
, passwordField
, textareaField
, hiddenField
, intField
, dayField
, timeField
, htmlField
, emailField
, searchField
, AutoFocus
, urlField
, doubleField
, parseDate
, parseTime
, Textarea (..)
, boolField
, checkBoxField
-- * File 'AForm's
, fileAFormReq
, fileAFormOpt
-- * Options
, selectField
, selectFieldList
, radioField
, radioFieldList
, multiSelectField
, multiSelectFieldList
, Option (..)
, OptionList (..)
, mkOptionList
, optionsPersist
, optionsPairs
, optionsEnum
) where
import Yesod.Form.Types
import Yesod.Form.I18n.English
import Yesod.Handler (getMessageRender)
import Yesod.Widget (toWidget, whamlet, GWidget)
import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))
import Text.Hamlet
import Text.Blaze (ToHtml (..), preEscapedText, 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 Database.Persist.Store (Entity (..))
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Control.Monad (when, unless)
import Data.Maybe (listToMaybe)
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
import Database.Persist.Store (PersistEntityBackend)
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 qualified Data.Map as Map
import Yesod.Handler (newIdent, lift)
import Yesod.Request (FileInfo)
import Yesod.Core (toPathPiece, GHandler, PathPiece)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)
import Control.Arrow ((&&&))
import Control.Applicative ((<$>))
defaultFormMessage :: FormMessage -> Text
defaultFormMessage = englishFormMessage
blank :: (Monad m, RenderMessage master FormMessage)
=> (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))
blank _ [] = return $ Right Nothing
blank _ ("":_) = return $ Right Nothing
blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x
intField :: (Integral i, RenderMessage master FormMessage) => Field sub master 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 attrs val isReq -> toWidget [hamlet|
|]
}
where
showVal = either id (pack . showI)
showI x = show (fromIntegral x :: Integer)
doubleField :: RenderMessage master FormMessage => Field sub master Double
doubleField = Field
{ fieldParse = blank $ \s ->
case Data.Text.Read.double s of
Right (a, "") -> Right a
_ -> Left $ MsgInvalidNumber s
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|]
}
where showVal = either id (pack . show)
dayField :: RenderMessage master FormMessage => Field sub master Day
dayField = Field
{ fieldParse = blank $ parseDate . unpack
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|]
}
where showVal = either id (pack . show)
timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay
timeField = Field
{ fieldParse = blank $ parseTime . unpack
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|]
}
where
showVal = either id (pack . show . roundFullSeconds)
roundFullSeconds tod =
TimeOfDay (todHour tod) (todMin tod) fullSec
where
fullSec = fromInteger $ floor $ todSec tod
htmlField :: RenderMessage master FormMessage => Field sub master Html
htmlField = Field
{ fieldParse = blank $ Right . preEscapedText . sanitizeBalance
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
-- FIXME: There was a class="html" attribute, for what purpose?