252 lines
8.2 KiB
Haskell
252 lines
8.2 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE CPP #-}
|
|
module Yesod.Form.Fields
|
|
( textField
|
|
, passwordField
|
|
, textareaField
|
|
, hiddenField
|
|
, intField
|
|
, dayField
|
|
, timeField
|
|
, htmlField
|
|
, emailField
|
|
, searchField
|
|
, AutoFocus
|
|
, urlField
|
|
, doubleField
|
|
, parseDate
|
|
, parseTime
|
|
, Textarea (..)
|
|
) where
|
|
|
|
import Yesod.Form.Types
|
|
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
|
|
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
|
|
import Data.Text (Text, unpack, pack)
|
|
|
|
#if __GLASGOW_HASKELL__ >= 700
|
|
#define HAMLET hamlet
|
|
#define CASSIUS cassius
|
|
#define JULIUS julius
|
|
#else
|
|
#define HAMLET $hamlet
|
|
#define CASSIUS $cassius
|
|
#define JULIUS $julius
|
|
#endif
|
|
|
|
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) i
|
|
intField = Field
|
|
{ fieldParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read
|
|
, fieldRender = pack . showI
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{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
|
|
|
|
doubleField :: Monad monad => Field (GGWidget master monad ()) Double
|
|
doubleField = Field
|
|
{ fieldParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read
|
|
, fieldRender = pack . show
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
|
|
|]
|
|
}
|
|
|
|
dayField :: Monad monad => Field (GGWidget master monad ()) Day
|
|
dayField = Field
|
|
{ fieldParse = parseDate . unpack
|
|
, fieldRender = pack . show
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
|
|
|]
|
|
}
|
|
|
|
timeField :: Monad monad => Field (GGWidget master monad ()) TimeOfDay
|
|
timeField = Field
|
|
{ fieldParse = parseTime . unpack
|
|
, fieldRender = pack . show . roundFullSeconds
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
|
|
|]
|
|
}
|
|
where
|
|
roundFullSeconds tod =
|
|
TimeOfDay (todHour tod) (todMin tod) fullSec
|
|
where
|
|
fullSec = fromInteger $ floor $ todSec tod
|
|
|
|
htmlField :: Monad monad => Field (GGWidget master monad ()) Html
|
|
htmlField = Field
|
|
{ fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
|
|
, fieldRender = pack . renderHtml
|
|
, fieldView = \theId name val _isReq -> addHamlet
|
|
[HAMLET|\
|
|
<textarea id="#{theId}" name="#{name}" .html>#{val}
|
|
|]
|
|
}
|
|
|
|
-- | 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 ()) Textarea
|
|
textareaField = Field
|
|
{ fieldParse = Right . Textarea
|
|
, fieldRender = unTextarea
|
|
, fieldView = \theId name val _isReq -> addHamlet
|
|
[HAMLET|\
|
|
<textarea id="#{theId}" name="#{name}">#{val}
|
|
|]
|
|
}
|
|
|
|
hiddenField :: Monad monad => Field (GGWidget master monad ()) Text
|
|
hiddenField = Field
|
|
{ fieldParse = Right
|
|
, fieldRender = id
|
|
, fieldView = \theId name val _isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">
|
|
|]
|
|
}
|
|
|
|
textField :: Monad monad => Field (GGWidget master monad ()) Text
|
|
textField = Field
|
|
{ fieldParse = Right
|
|
, fieldRender = id
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
|
|
|]
|
|
}
|
|
|
|
passwordField :: Monad monad => Field (GGWidget master monad ()) Text
|
|
passwordField = Field
|
|
{ fieldParse = Right
|
|
, fieldRender = id
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{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 Text 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 Text 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 Text TimeOfDay
|
|
parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
|
| h < 0 || h > 23 = Left $ pack $ "Invalid hour: " ++ show h
|
|
| m < 0 || m > 59 = Left $ pack $ "Invalid minute: " ++ show m
|
|
| s < 0 || s > 59 = Left $ pack $ "Invalid second: " ++ show s
|
|
| otherwise = Right $ TimeOfDay h m s
|
|
where
|
|
h = read [h1, h2]
|
|
m = read [m1, m2]
|
|
s = fromInteger $ read [s1, s2]
|
|
|
|
emailField :: Monad monad => Field (GGWidget master monad ()) Text
|
|
emailField = Field
|
|
{ fieldParse = \s -> if Email.isValid (unpack s)
|
|
then Right s
|
|
else Left "Invalid e-mail address"
|
|
, fieldRender = id
|
|
, fieldView = \theId name val isReq -> addHamlet
|
|
[HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">
|
|
|]
|
|
}
|
|
|
|
type AutoFocus = Bool
|
|
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) Text
|
|
searchField autoFocus = Field
|
|
{ fieldParse = Right
|
|
, fieldRender = id
|
|
, fieldView = \theId name val isReq -> do
|
|
addHtml [HAMLET|\
|
|
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">
|
|
|]
|
|
when autoFocus $ do
|
|
addHtml $ [HAMLET|\<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 ()) Text
|
|
urlField = Field
|
|
{ fieldParse = \s -> case parseURI $ unpack s of
|
|
Nothing -> Left "Invalid URL"
|
|
Just _ -> Right s
|
|
, fieldRender = id
|
|
, fieldView = \theId name val isReq -> addHtml
|
|
[HAMLET|
|
|
<input ##{theId} name=#{name} type=url :isReq:required value=#{val}>
|
|
|]
|
|
}
|