haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

More things work with rio

Browse Source
This commit is contained in:
Michael Snoyman 2019-02-26 11:33:11 +02:00
parent 2c246486e7
commit 9d47aa24da
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
16 changed files with 444 additions and 420 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
yesod-eventsource/Yesod/EventSource.hs
View File

@ -22,7 +22,7 @@ import qualified Network.Wai.EventSource.EventStream as ES
-- | (Internal) Find out the request's 'EventSourcePolyfill' and -- | (Internal) Find out the request's 'EventSourcePolyfill' and
-- set any necessary headers. -- set any necessary headers.
prepareForEventSource :: MonadHandler m => m EventSourcePolyfill prepareForEventSource :: HasHandlerData env => RIO env EventSourcePolyfill
prepareForEventSource = do prepareForEventSource = do
reqWith <- lookup "X-Requested-With" . W.requestHeaders Data.Functor.<$> waiRequest reqWith <- lookup "X-Requested-With" . W.requestHeaders Data.Functor.<$> waiRequest
let polyfill | reqWith == Just "XMLHttpRequest" = Remy'sESPolyfill let polyfill | reqWith == Just "XMLHttpRequest" = Remy'sESPolyfill

10
yesod-form/Yesod/Form/Bootstrap3.hs
View File

@ -140,7 +140,7 @@ data BootstrapFormLayout =
-- | Render the given form using Bootstrap v3 conventions. -- | Render the given form using Bootstrap v3 conventions.
-- --
-- Since: yesod-form 1.3.8 -- Since: yesod-form 1.3.8
renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a renderBootstrap3 :: BootstrapFormLayout -> FormRender site a
renderBootstrap3 formLayout aform fragment = do renderBootstrap3 formLayout aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
@ -223,8 +223,8 @@ instance IsString msg => IsString (BootstrapSubmit msg) where
-- --
-- Since: yesod-form 1.3.8 -- Since: yesod-form 1.3.8
bootstrapSubmit bootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) :: RenderMessage site msg
=> BootstrapSubmit msg -> AForm m () => BootstrapSubmit msg -> AForm site ()
bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
@ -234,8 +234,8 @@ bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
-- --
-- Since: yesod-form 1.3.8 -- Since: yesod-form 1.3.8
mbootstrapSubmit mbootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) :: RenderMessage site msg
=> BootstrapSubmit msg -> MForm m (FormResult (), FieldView site) => BootstrapSubmit msg -> MForm site (FormResult (), FieldView site)
mbootstrapSubmit (BootstrapSubmit msg classes attrs) = mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
let res = FormSuccess () let res = FormSuccess ()
widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|] widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]

175
yesod-form/Yesod/Form/Fields.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -60,11 +61,13 @@ module Yesod.Form.Fields
, optionsEnum , optionsEnum
) where ) where
import RIO
import Yesod.Form.Types import Yesod.Form.Types
import Yesod.Form.I18n.English import Yesod.Form.I18n.English
import Yesod.Form.Functions (parseHelper) import Yesod.Form.Functions (parseHelper)
import Yesod.Core import Yesod.Core
import Text.Blaze (ToMarkup (toMarkup), unsafeByteString) import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
import Prelude (zipWith)
#define ToHtml ToMarkup #define ToHtml ToMarkup
#define toHtml toMarkup #define toHtml toMarkup
#define preEscapedText preEscapedToMarkup #define preEscapedText preEscapedToMarkup
@ -117,10 +120,10 @@ defaultFormMessage :: FormMessage -> Text
defaultFormMessage = englishFormMessage defaultFormMessage = englishFormMessage
-- | Creates a input with @type="number"@ and @step=1@. -- | Creates a input with @type="number"@ and @step=1@.
intField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i intField :: (Integral i, RenderMessage site FormMessage) => Field site i
intField = Field intField = Field
{ fieldParse = parseHelper $ \s -> { fieldParse = parseHelper $ \s ->
case Data.Text.Read.signed Data.Text.Read.decimal s of case Data.Text.Read.signed Data.Text.Read.decimal s of -- FIXME it overflows
Right (a, "") -> Right a Right (a, "") -> Right a
_ -> Left $ MsgInvalidInteger s _ -> Left $ MsgInvalidInteger s
@ -135,7 +138,7 @@ $newline never
showI x = show (fromIntegral x :: Integer) showI x = show (fromIntegral x :: Integer)
-- | Creates a input with @type="number"@ and @step=any@. -- | Creates a input with @type="number"@ and @step=any@.
doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double doubleField :: RenderMessage site FormMessage => Field site Double
doubleField = Field doubleField = Field
{ fieldParse = parseHelper $ \s -> { fieldParse = parseHelper $ \s ->
case Data.Text.Read.double (prependZero s) of case Data.Text.Read.double (prependZero s) of
@ -153,7 +156,7 @@ $newline never
-- | Creates an input with @type="date"@, validating the input using the 'parseDate' function. -- | Creates an input with @type="date"@, validating the input using the 'parseDate' function.
-- --
-- Add the @time@ package and import the "Data.Time.Calendar" module to use this function. -- Add the @time@ package and import the "Data.Time.Calendar" module to use this function.
dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day dayField :: RenderMessage site FormMessage => Field site Day
dayField = Field dayField = Field
{ fieldParse = parseHelper $ parseDate . unpack { fieldParse = parseHelper $ parseDate . unpack
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -165,7 +168,7 @@ $newline never
where showVal = either id (pack . show) where showVal = either id (pack . show)
-- | An alias for 'timeFieldTypeTime'. -- | An alias for 'timeFieldTypeTime'.
timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay timeField :: RenderMessage site FormMessage => Field site TimeOfDay
timeField = timeFieldTypeTime timeField = timeFieldTypeTime
-- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'. -- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.
@ -173,7 +176,7 @@ timeField = timeFieldTypeTime
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function. -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
-- --
-- Since 1.4.2 -- Since 1.4.2
timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay timeFieldTypeTime :: RenderMessage site FormMessage => Field site TimeOfDay
timeFieldTypeTime = timeFieldOfType "time" timeFieldTypeTime = timeFieldOfType "time"
-- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system). -- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
@ -183,10 +186,10 @@ timeFieldTypeTime = timeFieldOfType "time"
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function. -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
-- --
-- Since 1.4.2 -- Since 1.4.2
timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay timeFieldTypeText :: RenderMessage site FormMessage => Field site TimeOfDay
timeFieldTypeText = timeFieldOfType "text" timeFieldTypeText = timeFieldOfType "text"
timeFieldOfType :: Monad m => RenderMessage (HandlerSite m) FormMessage => Text -> Field m TimeOfDay timeFieldOfType :: RenderMessage site FormMessage => Text -> Field site TimeOfDay
timeFieldOfType inputType = Field timeFieldOfType inputType = Field
{ fieldParse = parseHelper parseTime { fieldParse = parseHelper parseTime
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -203,7 +206,7 @@ $newline never
fullSec = fromInteger $ floor $ todSec tod fullSec = fromInteger $ floor $ todSec tod
-- | Creates a @\<textarea>@ tag whose input is sanitized to prevent XSS attacks and is validated for having balanced tags. -- | Creates a @\<textarea>@ tag whose input is sanitized to prevent XSS attacks and is validated for having balanced tags.
htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html htmlField :: RenderMessage site FormMessage => Field site Html
htmlField = Field htmlField = Field
{ fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -239,7 +242,7 @@ instance ToHtml Textarea where
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
-- | Creates a @\<textarea>@ tag whose returned value is wrapped in a 'Textarea'; see 'Textarea' for details. -- | Creates a @\<textarea>@ tag whose returned value is wrapped in a 'Textarea'; see 'Textarea' for details.
textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea textareaField :: RenderMessage site FormMessage => Field site Textarea
textareaField = Field textareaField = Field
{ fieldParse = parseHelper $ Right . Textarea { fieldParse = parseHelper $ Right . Textarea
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -250,8 +253,8 @@ $newline never
} }
-- | Creates an input with @type="hidden"@; you can use this to store information in a form that users shouldn't see (for example, Yesod stores CSRF tokens in a hidden field). -- | Creates an input with @type="hidden"@; you can use this to store information in a form that users shouldn't see (for example, Yesod stores CSRF tokens in a hidden field).
hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage) hiddenField :: (PathPiece p, RenderMessage site FormMessage)
=> Field m p => Field site p
hiddenField = Field hiddenField = Field
{ fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet| , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@ -262,7 +265,7 @@ $newline never
} }
-- | Creates a input with @type="text"@. -- | Creates a input with @type="text"@.
textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text textField :: RenderMessage site FormMessage => Field site Text
textField = Field textField = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> , fieldView = \theId name attrs val isReq ->
@ -273,7 +276,7 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
-- | Creates an input with @type="password"@. -- | Creates an input with @type="password"@.
passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text passwordField :: RenderMessage site FormMessage => Field site Text
passwordField = Field passwordField = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs _ isReq -> toWidget [hamlet| , fieldView = \theId name attrs _ isReq -> toWidget [hamlet|
@ -283,15 +286,10 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
readMay :: Read a => String -> Maybe a
readMay s = case filter (Prelude.null . snd) $ reads s of
(x, _):_ -> Just x
[] -> Nothing
-- | Parses a 'Day' from a 'String'. -- | Parses a 'Day' from a 'String'.
parseDate :: String -> Either FormMessage Day parseDate :: String -> Either FormMessage Day
parseDate = maybe (Left MsgInvalidDay) Right parseDate = maybe (Left MsgInvalidDay) Right
. readMay . replace '/' '-' . readMaybe . replace '/' '-'
-- | Replaces all instances of a value in a list by another value. -- | 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 -- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
@ -299,7 +297,7 @@ replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z) replace x y = map (\z -> if z == x then y else z)
parseTime :: Text -> Either FormMessage TimeOfDay parseTime :: Text -> Either FormMessage TimeOfDay
parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMaybe . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
timeParser :: Parser TimeOfDay timeParser :: Parser TimeOfDay
timeParser = do timeParser = do
@ -331,7 +329,10 @@ timeParser = do
x <- digit x <- digit
y <- (return Control.Applicative.<$> digit) <|> return [] y <- (return Control.Applicative.<$> digit) <|> return []
let xy = x : y let xy = x : y
let i = read xy let i =
case readMaybe xy of
Just i' -> i'
Nothing -> error $ "The impossible happened parsing: " ++ show xy
if i < 0 || i >= 24 if i < 0 || i >= 24
then fail $ show $ MsgInvalidHour $ pack xy then fail $ show $ MsgInvalidHour $ pack xy
else return i else return i
@ -340,13 +341,16 @@ timeParser = do
x <- digit x <- digit
y <- digit <|> fail (show $ msg $ pack [x]) y <- digit <|> fail (show $ msg $ pack [x])
let xy = [x, y] let xy = [x, y]
let i = read xy let i =
case readMaybe xy of
Just i' -> i'
Nothing -> error $ "The impossible happened parsing: " ++ show xy
if i < 0 || i >= 60 if i < 0 || i >= 60
then fail $ show $ msg $ pack xy then fail $ show $ msg $ pack xy
else return $ fromIntegral (i :: Int) else return $ fromIntegral (i :: Int)
-- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate"). -- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").
emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text emailField :: RenderMessage site FormMessage => Field site Text
emailField = Field emailField = Field
{ fieldParse = parseHelper $ { fieldParse = parseHelper $
\s -> \s ->
@ -363,7 +367,7 @@ $newline never
-- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'. -- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
-- --
-- Since 1.3.7 -- Since 1.3.7
multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text] multiEmailField :: RenderMessage site FormMessage => Field site [Text]
multiEmailField = Field multiEmailField = Field
{ fieldParse = parseHelper $ { fieldParse = parseHelper $
\s -> \s ->
@ -387,7 +391,7 @@ $newline never
type AutoFocus = Bool type AutoFocus = Bool
-- | Creates an input with @type="search"@. For <http://caniuse.com/#search=autofocus browsers without autofocus support>, a JS fallback is used if @AutoFocus@ is true. -- | Creates an input with @type="search"@. For <http://caniuse.com/#search=autofocus browsers without autofocus support>, a JS fallback is used if @AutoFocus@ is true.
searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text searchField :: RenderMessage site FormMessage => AutoFocus -> Field site Text
searchField autoFocus = Field searchField autoFocus = Field
{ fieldParse = parseHelper Right { fieldParse = parseHelper Right
, fieldView = \theId name attrs val isReq -> do , fieldView = \theId name attrs val isReq -> do
@ -408,7 +412,7 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
-- | Creates an input with @type="url"@, validating the URL according to RFC3986. -- | Creates an input with @type="url"@, validating the URL according to RFC3986.
urlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text urlField :: RenderMessage site FormMessage => Field site Text
urlField = Field urlField = Field
{ fieldParse = parseHelper $ \s -> { fieldParse = parseHelper $ \s ->
case parseURI $ unpack s of case parseURI $ unpack s of
@ -424,7 +428,7 @@ urlField = Field
-- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing -- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerFor site) a -> Field site a
selectFieldList = selectField . optionsPairs selectFieldList = selectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting one option. Example usage: -- | Creates a @\<select>@ tag for selecting one option. Example usage:
@ -432,7 +436,7 @@ selectFieldList = selectField . optionsPairs
-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
selectField :: (Eq a, RenderMessage site FormMessage) selectField :: (Eq a, RenderMessage site FormMessage)
=> HandlerFor site (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerFor site) a -> Field site a
selectField = selectFieldHelper selectField = selectFieldHelper
(\theId name attrs inside -> [whamlet| (\theId name attrs inside -> [whamlet|
$newline never $newline never
@ -450,15 +454,15 @@ $newline never
-- | Creates a @\<select>@ tag for selecting multiple options. -- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectFieldList :: (Eq a, RenderMessage site msg) multiSelectFieldList :: (Eq a, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerFor site) [a] -> Field site [a]
multiSelectFieldList = multiSelectField . optionsPairs multiSelectFieldList = multiSelectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting multiple options. -- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectField :: Eq a multiSelectField :: Eq a
=> HandlerFor site (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerFor site) [a] -> Field site [a]
multiSelectField ioptlist = multiSelectField ioptlist =
Field parse view UrlEncoded Field parse view' UrlEncoded
where where
parse [] _ = return $ Right Nothing parse [] _ = return $ Right Nothing
parse optlist _ = do parse optlist _ = do
@ -467,7 +471,7 @@ multiSelectField ioptlist =
Nothing -> return $ Left "Error parsing values" Nothing -> return $ Left "Error parsing values"
Just res -> return $ Right $ Just res Just res -> return $ Right $ Just res
view theId name attrs val isReq = do view' theId name attrs val isReq = do
opts <- fmap olOptions $ handlerToWidget ioptlist opts <- fmap olOptions $ handlerToWidget ioptlist
let selOpts = map (id &&& (optselected val)) opts let selOpts = map (id &&& (optselected val)) opts
[whamlet| [whamlet|
@ -482,18 +486,18 @@ multiSelectField ioptlist =
-- | Creates an input with @type="radio"@ for selecting one option. -- | Creates an input with @type="radio"@ for selecting one option.
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerFor site) a -> Field site a
radioFieldList = radioField . optionsPairs radioFieldList = radioField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options. -- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)] checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
-> Field (HandlerFor site) [a] -> Field site [a]
checkboxesFieldList = checkboxesField . optionsPairs checkboxesFieldList = checkboxesField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options. -- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesField :: Eq a checkboxesField :: Eq a
=> HandlerFor site (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerFor site) [a] -> Field site [a]
checkboxesField ioptlist = (multiSelectField ioptlist) checkboxesField ioptlist = (multiSelectField ioptlist)
{ fieldView = { fieldView =
\theId name attrs val _isReq -> do \theId name attrs val _isReq -> do
@ -511,7 +515,7 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
-- | Creates an input with @type="radio"@ for selecting one option. -- | Creates an input with @type="radio"@ for selecting one option.
radioField :: (Eq a, RenderMessage site FormMessage) radioField :: (Eq a, RenderMessage site FormMessage)
=> HandlerFor site (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerFor site) a -> Field site a
radioField = selectFieldHelper radioField = selectFieldHelper
(\theId _name _attrs inside -> [whamlet| (\theId _name _attrs inside -> [whamlet|
$newline never $newline never
@ -539,7 +543,7 @@ $newline never
-- If this field is required, the first radio button is labeled \"Yes" and the second \"No". -- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
-- --
-- (Exact label titles will depend on localization). -- (Exact label titles will depend on localization).
boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool boolField :: RenderMessage site FormMessage => Field site Bool
boolField = Field boolField = Field
{ fieldParse = \e _ -> return $ boolParser e { fieldParse = \e _ -> return $ boolParser e
, fieldView = \theId name attrs val isReq -> [whamlet| , fieldView = \theId name attrs val isReq -> [whamlet|
@ -578,7 +582,7 @@ $newline never
-- --
-- Note that this makes the field always optional. -- Note that this makes the field always optional.
-- --
checkBoxField :: Monad m => Field m Bool checkBoxField :: Field site Bool
checkBoxField = Field checkBoxField = Field
{ fieldParse = \e _ -> return $ checkBoxParser e { fieldParse = \e _ -> return $ checkBoxParser e
, fieldView = \theId name attrs val _ -> [whamlet| , fieldView = \theId name attrs val _ -> [whamlet|
@ -623,22 +627,21 @@ data Option a = Option
-- | Since 1.4.6 -- | Since 1.4.6
instance Functor Option where instance Functor Option where
fmap f (Option display internal external) = Option display (f internal) external fmap f (Option display' internal external) = Option display' (f internal) external
-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs. -- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg) optionsPairs :: RenderMessage site msg => [(msg, a)] -> HandlerFor site (OptionList a)
=> [(msg, a)] -> m (OptionList a)
optionsPairs opts = do optionsPairs opts = do
mr <- getMessageRender mr <- getMessageRender
let mkOption external (display, internal) = let mkOption external (display', internal) =
Option { optionDisplay = mr display Option { optionDisplay = mr display'
, optionInternalValue = internal , optionInternalValue = internal
, optionExternalValue = pack $ show external , optionExternalValue = pack $ show external
} }
return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts) return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
-- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value. -- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value.
optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a) optionsEnum :: (Show a, Enum a, Bounded a) => HandlerFor site (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
-- | Selects a list of 'Entity's with the given 'Filter' and 'SelectOpt's. The @(a -> msg)@ function is then used to derive the display value for an 'OptionList'. Example usage: -- | Selects a list of 'Entity's with the given 'Filter' and 'SelectOpt's. The @(a -> msg)@ function is then used to derive the display value for an 'OptionList'. Example usage:
@ -656,33 +659,22 @@ optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
-- > <$> areq (selectField countries) "Which country do you live in?" Nothing -- > <$> areq (selectField countries) "Which country do you live in?" Nothing
-- > where -- > where
-- > countries = optionsPersist [] [Asc CountryName] countryName -- > countries = optionsPersist [] [Asc CountryName] countryName
#if MIN_VERSION_persistent(2,5,0)
optionsPersist :: ( YesodPersist site optionsPersist :: ( YesodPersist site
, PersistQueryRead backend , PersistQueryRead backend
, PathPiece (Key a) , PathPiece (Key a)
, RenderMessage site msg , RenderMessage site msg
, YesodPersistBackend site ~ backend , YesodPersistBackend site ~ backend
, PersistRecordBackend a backend , PersistRecordBackend a backend
, site ~ HandlerSite env
, HasHandlerData env
) )
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerFor site (OptionList (Entity a)) -> RIO env (OptionList (Entity a))
#else
optionsPersist :: ( YesodPersist site, PersistEntity a
, PersistQuery (PersistEntityBackend a)
, PathPiece (Key a)
, RenderMessage site msg
, YesodPersistBackend site ~ PersistEntityBackend a
)
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (OptionList (Entity a))
#endif
optionsPersist filts ords toDisplay = fmap mkOptionList $ do optionsPersist filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender mr <- getMessageRender
pairs <- runDB $ selectList filts ords pairs <- liftHandler $ runDB $ selectList filts ords
return $ map (\(Entity key value) -> Option return $ map (\(Entity key value) -> Option
{ optionDisplay = mr (toDisplay value) { optionDisplay = mr (toDisplay value)
, optionInternalValue = Entity key value , optionInternalValue = Entity key value
@ -693,35 +685,21 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
-- the entire 'Entity'. -- the entire 'Entity'.
-- --
-- Since 1.3.2 -- Since 1.3.2
#if MIN_VERSION_persistent(2,5,0)
optionsPersistKey optionsPersistKey
:: (YesodPersist site :: ( YesodPersist site
, PersistQueryRead backend , PersistQueryRead backend
, PathPiece (Key a) , PathPiece (Key a)
, RenderMessage site msg , RenderMessage site msg
, backend ~ YesodPersistBackend site , backend ~ YesodPersistBackend site
, site ~ HandlerSite env
, PersistRecordBackend a backend , PersistRecordBackend a backend
, HasHandlerData env
) )
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerFor site (OptionList (Key a)) -> RIO env (OptionList (Key a))
#else optionsPersistKey filts ords toDisplay = liftHandler $ fmap mkOptionList $ do
optionsPersistKey
:: (YesodPersist site
, PersistEntity a
, PersistQuery (PersistEntityBackend a)
, PathPiece (Key a)
, RenderMessage site msg
, YesodPersistBackend site ~ PersistEntityBackend a
)
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (OptionList (Key a))
#endif
optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender mr <- getMessageRender
pairs <- runDB $ selectList filts ords pairs <- runDB $ selectList filts ords
return $ map (\(Entity key value) -> Option return $ map (\(Entity key value) -> Option
@ -740,7 +718,7 @@ selectFieldHelper
-> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
-> HandlerFor site (OptionList a) -> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a -> Field site a
selectFieldHelper outside onOpt inside opts' = Field selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x _ -> do { fieldParse = \x _ -> do
opts <- opts' opts <- opts'
@ -770,8 +748,7 @@ selectFieldHelper outside onOpt inside opts' = Field
Just y -> Right $ Just y Just y -> Right $ Just y
-- | Creates an input with @type="file"@. -- | Creates an input with @type="file"@.
fileField :: Monad m fileField :: Field site FileInfo
=> Field m FileInfo
fileField = Field fileField = Field
{ fieldParse = \_ files -> return $ { fieldParse = \_ files -> return $
case files of case files of
@ -783,18 +760,23 @@ fileField = Field
, fieldEnctype = Multipart , fieldEnctype = Multipart
} }
fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) fileAFormReq :: RenderMessage site FormMessage
=> FieldSettings (HandlerSite m) -> AForm m FileInfo => FieldSettings site -> AForm site FileInfo
fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do fileAFormReq fs = AForm $ do
site <- getYesod
langs <- reqLangs <$> getRequest
WFormData viewsRef mfd <- view id
ints <- readIORef $ mfdInts mfd
let (name, ints') = let (name, ints') =
case fsName fs of case fsName fs of
Just x -> (x, ints) Just x -> (x, ints)
Nothing -> Nothing ->
let i' = incrInts ints let i' = incrInts ints
in (pack $ 'f' : show i', i') in (pack $ 'f' : show i', i')
writeIORef (mfdInts mfd) ints'
id' <- maybe newIdent return $ fsId fs id' <- maybe newIdent return $ fsId fs
let (res, errs) = let (res, errs) =
case menvs of case mfdParams mfd of
Nothing -> (FormMissing, Nothing) Nothing -> (FormMissing, Nothing)
Just (_, fenv) -> Just (_, fenv) ->
case Map.lookup name fenv of case Map.lookup name fenv of
@ -813,21 +795,26 @@ $newline never
, fvErrors = errs , fvErrors = errs
, fvRequired = True , fvRequired = True
} }
return (res, (fv :), ints', Multipart) writeIORef (mfdEnctype mfd) Multipart
modifyIORef viewsRef $ \views -> views . (fv:)
return res
fileAFormOpt :: MonadHandler m fileAFormOpt :: FieldSettings site -> AForm site (Maybe FileInfo)
=> FieldSettings (HandlerSite m) fileAFormOpt fs = AForm $ do
-> AForm m (Maybe FileInfo) master <- getYesod
fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do langs <- reqLangs <$> getRequest
WFormData viewsRef mfd <- view id
ints <- readIORef $ mfdInts mfd
let (name, ints') = let (name, ints') =
case fsName fs of case fsName fs of
Just x -> (x, ints) Just x -> (x, ints)
Nothing -> Nothing ->
let i' = incrInts ints let i' = incrInts ints
in (pack $ 'f' : show i', i') in (pack $ 'f' : show i', i')
writeIORef (mfdInts mfd) ints'
id' <- maybe newIdent return $ fsId fs id' <- maybe newIdent return $ fsId fs
let (res, errs) = let (res, errs) =
case menvs of case mfdParams mfd of
Nothing -> (FormMissing, Nothing) Nothing -> (FormMissing, Nothing)
Just (_, fenv) -> Just (_, fenv) ->
case Map.lookup name fenv of case Map.lookup name fenv of
@ -844,7 +831,9 @@ $newline never
, fvErrors = errs , fvErrors = errs
, fvRequired = False , fvRequired = False
} }
return (res, (fv :), ints', Multipart) writeIORef (mfdEnctype mfd) Multipart
modifyIORef viewsRef $ \views -> views . (fv:)
return res
incrInts :: Ints -> Ints incrInts :: Ints -> Ints
incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntSingle i) = IntSingle $ i + 1

310
yesod-form/Yesod/Form/Functions.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -38,7 +39,6 @@ module Yesod.Form.Functions
, renderTable , renderTable
, renderDivs , renderDivs
, renderDivsNoLabels , renderDivsNoLabels
, renderBootstrap
, renderBootstrap2 , renderBootstrap2
-- * Validation -- * Validation
, check , check
@ -55,13 +55,12 @@ module Yesod.Form.Functions
, removeClass , removeClass
) where ) where
import RIO hiding (ask, local)
import Yesod.Form.Types import Yesod.Form.Types
import Yesod.Core.Types (liftHandler)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import qualified Data.Text as T import qualified Data.Text as T
import Control.Arrow (second) import Control.Arrow (second)
import Control.Monad.Trans.Class
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST)
import Control.Monad.Trans.Writer (runWriterT, writer)
import Control.Monad (liftM, join) import Control.Monad (liftM, join)
import Data.Byteable (constEqBytes) import Data.Byteable (constEqBytes)
import Text.Blaze (Markup, toMarkup) import Text.Blaze (Markup, toMarkup)
@ -75,8 +74,28 @@ import qualified Data.Map as Map
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import Control.Arrow (first) import Control.Arrow (first)
get :: MForm site Ints
get = view (to mfdInts) >>= readIORef
put :: Ints -> MForm site ()
put ints = view (to mfdInts) >>= (`writeIORef` ints)
tell :: Enctype -> MForm site ()
tell ec = view (to mfdEnctype) >>= (`writeIORef` ec)
local
:: ( Maybe (Env, FileEnv)
-> Maybe (Env, FileEnv)
)
-> MForm site a
-> MForm site a
local f inner = do
mfd <- view id
let mfd' = mfd { mfdParams = f $ mfdParams mfd }
runRIO mfd' inner
-- | Get a unique identifier. -- | Get a unique identifier.
newFormIdent :: Monad m => MForm m Text newFormIdent :: MForm site Text
newFormIdent = do newFormIdent = do
i <- get i <- get
let i' = incrInts i let i' = incrInts i
@ -86,43 +105,34 @@ newFormIdent = do
incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is incrInts (IntCons i is) = (i + 1) `IntCons` is
formToAForm :: (HandlerSite m ~ site, Monad m) formToAForm :: MForm site (FormResult a, [FieldView site]) -> AForm site a
=> MForm m (FormResult a, [FieldView site]) formToAForm mform = AForm $ do
-> AForm m a WFormData viewsRef mfd <- view id
formToAForm form = AForm $ \(site, langs) env ints -> do (a, views) <- runRIO mfd mform
((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints modifyIORef' viewsRef $ \front -> front . (views++)
return (a, (++) xmls, ints', enc) pure a
aFormToForm :: (Monad m, HandlerSite m ~ site) aFormToForm :: AForm site a
=> AForm m a -> MForm site (FormResult a, [FieldView site] -> [FieldView site])
-> MForm m (FormResult a, [FieldView site] -> [FieldView site]) aFormToForm (AForm wform) = do
aFormToForm (AForm aform) = do (res, views) <- wFormToMForm wform
ints <- get pure (res, (views++))
(env, site, langs) <- ask
(a, xml, ints', enc) <- lift $ aform (site, langs) env ints
put ints'
tell enc
return (a, xml)
askParams :: Monad m => MForm m (Maybe Env) askParams :: MForm site (Maybe Env)
askParams = do askParams = view $ to (fmap fst . mfdParams)
(x, _, _) <- ask
return $ liftM fst x
askFiles :: Monad m => MForm m (Maybe FileEnv) askFiles :: MForm site (Maybe FileEnv)
askFiles = do askFiles = view $ to (fmap snd . mfdParams)
(x, _, _) <- ask
return $ liftM snd x
-- | Converts a form field into monadic form 'WForm'. This field requires a -- | Converts a form field into monadic form 'WForm'. This field requires a
-- value and will return 'FormFailure' if left empty. -- value and will return 'FormFailure' if left empty.
-- --
-- @since 1.4.14 -- @since 1.4.14
wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) wreq :: RenderMessage site FormMessage
=> Field m a -- ^ form field => Field site a -- ^ form field
-> FieldSettings site -- ^ settings for this field -> FieldSettings site -- ^ settings for this field
-> Maybe a -- ^ optional default value -> Maybe a -- ^ optional default value
-> WForm m (FormResult a) -> WForm site (FormResult a)
wreq f fs = mFormToWForm . mreq f fs wreq f fs = mFormToWForm . mreq f fs
-- | Converts a form field into monadic form 'WForm'. This field is optional, -- | Converts a form field into monadic form 'WForm'. This field is optional,
@ -131,75 +141,78 @@ wreq f fs = mFormToWForm . mreq f fs
-- value). -- value).
-- --
-- @since 1.4.14 -- @since 1.4.14
wopt :: (MonadHandler m, HandlerSite m ~ site) wopt :: Field site a -- ^ form field
=> Field m a -- ^ form field
-> FieldSettings site -- ^ settings for this field -> FieldSettings site -- ^ settings for this field
-> Maybe (Maybe a) -- ^ optional default value -> Maybe (Maybe a) -- ^ optional default value
-> WForm m (FormResult (Maybe a)) -> WForm site (FormResult (Maybe a))
wopt f fs = mFormToWForm . mopt f fs wopt f fs = mFormToWForm . mopt f fs
-- | Converts a monadic form 'WForm' into an applicative form 'AForm'. -- | Converts a monadic form 'WForm' into an applicative form 'AForm'.
-- --
-- @since 1.4.14 -- @since 1.4.14
wFormToAForm :: MonadHandler m wFormToAForm
=> WForm m (FormResult a) -- ^ input form :: WForm site (FormResult a) -- ^ input form
-> AForm m a -- ^ output form -> AForm site a -- ^ output form
wFormToAForm = formToAForm . wFormToMForm wFormToAForm = formToAForm . wFormToMForm
-- | Converts a monadic form 'WForm' into another monadic form 'MForm'. -- | Converts a monadic form 'WForm' into another monadic form 'MForm'.
-- --
-- @since 1.4.14 -- @since 1.4.14
wFormToMForm :: (MonadHandler m, HandlerSite m ~ site) wFormToMForm
=> WForm m a -- ^ input form :: WForm site a -- ^ input form
-> MForm m (a, [FieldView site]) -- ^ output form -> MForm site (a, [FieldView site]) -- ^ output form
wFormToMForm = mapRWST (fmap group . runWriterT) wFormToMForm wform = do
where viewsRef <- newIORef id
group ((a, ints, enctype), views) = ((a, views), ints, enctype) mfd <- view id
a <- runRIO (WFormData viewsRef mfd) wform
views <- readIORef viewsRef
pure (a, views [])
-- | Converts a monadic form 'MForm' into another monadic form 'WForm'. -- | Converts a monadic form 'MForm' into another monadic form 'WForm'.
-- --
-- @since 1.4.14 -- @since 1.4.14
mFormToWForm :: (MonadHandler m, HandlerSite m ~ site) mFormToWForm
=> MForm m (a, FieldView site) -- ^ input form :: MForm site (a, FieldView site) -- ^ input form
-> WForm m a -- ^ output form -> WForm site a -- ^ output form
mFormToWForm = mapRWST $ \f -> do mFormToWForm mform = do
((a, view), ints, enctype) <- lift f WFormData views mfd <- view id
writer ((a, ints, enctype), [view]) (a, view') <- runRIO mfd mform
modifyIORef' views $ \front -> front . (view':)
pure a
-- | Converts a form field into monadic form. This field requires a value -- | Converts a form field into monadic form. This field requires a value
-- and will return 'FormFailure' if left empty. -- and will return 'FormFailure' if left empty.
mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) mreq :: RenderMessage site FormMessage
=> Field m a -- ^ form field => Field site a -- ^ form field
-> FieldSettings site -- ^ settings for this field -> FieldSettings site -- ^ settings for this field
-> Maybe a -- ^ optional default value -> Maybe a -- ^ optional default value
-> MForm m (FormResult a, FieldView site) -> MForm site (FormResult a, FieldView site)
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
-- | Converts a form field into monadic form. This field is optional, i.e. -- | Converts a form field into monadic form. This field is optional, i.e.
-- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'. -- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'.
-- Arguments are the same as for 'mreq' (apart from type of default value). -- Arguments are the same as for 'mreq' (apart from type of default value).
mopt :: (site ~ HandlerSite m, MonadHandler m) mopt :: Field site a
=> Field m a
-> FieldSettings site -> FieldSettings site
-> Maybe (Maybe a) -> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site) -> MForm site (FormResult (Maybe a), FieldView site)
mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
mhelper :: (site ~ HandlerSite m, MonadHandler m) mhelper :: Field site a
=> Field m a
-> FieldSettings site -> FieldSettings site
-> Maybe a -> Maybe a
-> (site -> [Text] -> FormResult b) -- ^ on missing -> (site -> [Text] -> FormResult b) -- ^ on missing
-> (a -> FormResult b) -- ^ on success -> (a -> FormResult b) -- ^ on success
-> Bool -- ^ is it required? -> Bool -- ^ is it required?
-> MForm m (FormResult b, FieldView site) -> MForm site (FormResult b, FieldView site)
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
tell fieldEnctype tell fieldEnctype
mp <- askParams mp <- askParams
name <- maybe newFormIdent return fsName name <- maybe newFormIdent return fsName
theId <- lift $ maybe newIdent return fsId theId <- maybe newIdent return fsId
(_, site, langs) <- ask site <- getYesod
langs <- reqLangs <$> getRequest
let mr2 = renderMessage site langs let mr2 = renderMessage site langs
(res, val) <- (res, val) <-
case mp of case mp of
@ -208,7 +221,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
mfs <- askFiles mfs <- askFiles
let mvals = fromMaybe [] $ Map.lookup name p let mvals = fromMaybe [] $ Map.lookup name p
files = fromMaybe [] $ mfs >>= Map.lookup name files = fromMaybe [] $ mfs >>= Map.lookup name
emx <- lift $ fieldParse mvals files emx <- liftHandler $ fieldParse mvals files
return $ case emx of return $ case emx of
Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals)) Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals))
Right mx -> Right mx ->
@ -228,28 +241,37 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
}) })
-- | Applicative equivalent of 'mreq'. -- | Applicative equivalent of 'mreq'.
areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) areq :: RenderMessage site FormMessage
=> Field m a => Field site a
-> FieldSettings site -> FieldSettings site
-> Maybe a -> Maybe a
-> AForm m a -> AForm site a
areq a b = formToAForm . liftM (second return) . mreq a b areq a b = formToAForm . liftM (second return) . mreq a b
-- | Applicative equivalent of 'mopt'. -- | Applicative equivalent of 'mopt'.
aopt :: MonadHandler m aopt :: Field site a
=> Field m a -> FieldSettings site
-> FieldSettings (HandlerSite m)
-> Maybe (Maybe a) -> Maybe (Maybe a)
-> AForm m (Maybe a) -> AForm site (Maybe a)
aopt a b = formToAForm . liftM (second return) . mopt a b aopt a b = formToAForm . liftM (second return) . mopt a b
runFormGeneric :: Monad m runFormGeneric
=> MForm m a :: HasHandlerData env
-> HandlerSite m => MForm (HandlerSite env) a
-> [Text] -> Maybe (Env, FileEnv)
-> Maybe (Env, FileEnv) -> RIO env (a, Enctype)
-> m (a, Enctype) runFormGeneric mform params = do
runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0) hd <- liftHandler $ view subHandlerDataL
enctypeRef <- newIORef mempty
intsRef <- newIORef $! IntSingle 0
let mfd = MFormData
{ mfdHandlerData = hd
, mfdEnctype = enctypeRef
, mfdParams = params
, mfdInts = intsRef
}
a <- runRIO mfd mform
(,) a <$> readIORef enctypeRef
-- | This function is used to both initially render a form and to later extract -- | This function is used to both initially render a form and to later extract
-- results from it. Note that, due to CSRF protection and a few other issues, -- results from it. Note that, due to CSRF protection and a few other issues,
@ -260,17 +282,19 @@ runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle
-- For example, a common case is displaying a form on a GET request and having -- For example, a common case is displaying a form on a GET request and having
-- the form submit to a POST page. In such a case, both the GET and POST -- the form submit to a POST page. In such a case, both the GET and POST
-- handlers should use 'runFormPost'. -- handlers should use 'runFormPost'.
runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m) runFormPost
=> (Html -> MForm m (FormResult a, xml)) :: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
-> m ((FormResult a, xml), Enctype) => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-> RIO env ((FormResult a, xml), Enctype)
runFormPost form = do runFormPost form = do
env <- postEnv env <- postEnv
postHelper form env postHelper form env
postHelper :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) postHelper
=> (Html -> MForm m (FormResult a, xml)) :: (HasHandlerData env, RenderMessage (HandlerSite env) FormMessage)
-> Maybe (Env, FileEnv) => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-> m ((FormResult a, xml), Enctype) -> Maybe (Env, FileEnv)
-> RIO env ((FormResult a, xml), Enctype)
postHelper form env = do postHelper form env = do
req <- getRequest req <- getRequest
let tokenKey = defaultCsrfParamName let tokenKey = defaultCsrfParamName
@ -278,15 +302,14 @@ postHelper form env = do
case reqToken req of case reqToken req of
Nothing -> Data.Monoid.mempty Nothing -> Data.Monoid.mempty
Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|] Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
m <- getYesod ((res, xml), enctype) <- runFormGeneric (form token) env
langs <- languages site <- getYesod
((res, xml), enctype) <- runFormGeneric (form token) m langs env
let res' = let res' =
case (res, env) of case (res, env) of
(_, Nothing) -> FormMissing (_, Nothing) -> FormMissing
(FormSuccess{}, Just (params, _)) (FormSuccess{}, Just (params, _))
| not (Map.lookup tokenKey params === reqToken req) -> | not (Map.lookup tokenKey params === reqToken req) ->
FormFailure [renderMessage m langs MsgCsrfWarning] FormFailure [renderMessage site (reqLangs req) MsgCsrfWarning]
_ -> res _ -> res
-- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks. -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2 where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2
@ -299,12 +322,12 @@ postHelper form env = do
-- page will both receive and incoming form and produce a new, blank form. For -- page will both receive and incoming form and produce a new, blank form. For
-- general usage, you can stick with @runFormPost@. -- general usage, you can stick with @runFormPost@.
generateFormPost generateFormPost
:: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m) :: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
=> (Html -> MForm m (FormResult a, xml)) => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-> m (xml, Enctype) -> RIO env (xml, Enctype)
generateFormPost form = first snd `liftM` postHelper form Nothing generateFormPost form = first snd `liftM` postHelper form Nothing
postEnv :: MonadHandler m => m (Maybe (Env, FileEnv)) postEnv :: HasHandlerData env => RIO env (Maybe (Env, FileEnv))
postEnv = do postEnv = do
req <- getRequest req <- getRequest
if requestMethod (reqWaiRequest req) == "GET" if requestMethod (reqWaiRequest req) == "GET"
@ -314,18 +337,16 @@ postEnv = do
let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f) return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f)
runFormPostNoToken :: MonadHandler m runFormPostNoToken :: HasHandlerData env
=> (Html -> MForm m a) => (Html -> MForm (HandlerSite env) a)
-> m (a, Enctype) -> RIO env (a, Enctype)
runFormPostNoToken form = do runFormPostNoToken form = do
langs <- languages params <- postEnv
m <- getYesod runFormGeneric (form mempty) params
env <- postEnv
runFormGeneric (form mempty) m langs env
runFormGet :: MonadHandler m runFormGet :: HasHandlerData env
=> (Html -> MForm m a) => (Html -> MForm (HandlerSite env) a)
-> m (a, Enctype) -> RIO env (a, Enctype)
runFormGet form = do runFormGet form = do
gets <- liftM reqGetParams getRequest gets <- liftM reqGetParams getRequest
let env = let env =
@ -339,29 +360,27 @@ runFormGet form = do
-- --
-- Since 1.3.11 -- Since 1.3.11
generateFormGet' generateFormGet'
:: MonadHandler m :: HasHandlerData env
=> (Html -> MForm m (FormResult a, xml)) => (Html -> MForm (HandlerSite env) (FormResult a, xml))
-> m (xml, Enctype) -> RIO env (xml, Enctype)
generateFormGet' form = first snd `liftM` getHelper form Nothing generateFormGet' form = first snd `liftM` getHelper form Nothing
{-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-} {-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-}
generateFormGet :: MonadHandler m generateFormGet :: HasHandlerData env
=> (Html -> MForm m a) => (Html -> MForm (HandlerSite env) a)
-> m (a, Enctype) -> RIO env (a, Enctype)
generateFormGet form = getHelper form Nothing generateFormGet form = getHelper form Nothing
getKey :: Text getKey :: Text
getKey = "_hasdata" getKey = "_hasdata"
getHelper :: MonadHandler m getHelper :: HasHandlerData env
=> (Html -> MForm m a) => (Html -> MForm (HandlerSite env) a)
-> Maybe (Env, FileEnv) -> Maybe (Env, FileEnv)
-> m (a, Enctype) -> RIO env (a, Enctype)
getHelper form env = do getHelper form params = do
let fragment = [shamlet|<input type=hidden name=#{getKey}>|] let fragment = [shamlet|<input type=hidden name=#{getKey}>|]
langs <- languages runFormGeneric (form fragment) params
m <- getYesod
runFormGeneric (form fragment) m langs env
-- | Creates a hidden field on the form that identifies it. This -- | Creates a hidden field on the form that identifies it. This
@ -386,10 +405,9 @@ getHelper form env = do
-- even if their number or order change between the HTML -- even if their number or order change between the HTML
-- generation and the form submission. -- generation and the form submission.
identifyForm identifyForm
:: Monad m :: Text -- ^ Form identification string.
=> Text -- ^ Form identification string. -> (Html -> MForm site (FormResult a, WidgetFor site ()))
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())) -> (Html -> MForm site (FormResult a, WidgetFor site ()))
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
identifyForm identVal form = \fragment -> do identifyForm identVal form = \fragment -> do
-- Create hidden <input>. -- Create hidden <input>.
let fragment' = let fragment' =
@ -406,7 +424,7 @@ identifyForm identVal form = \fragment -> do
-- data is missing, then do not provide any params to the -- data is missing, then do not provide any params to the
-- form, which will turn its result into FormMissing. Also, -- form, which will turn its result into FormMissing. Also,
-- doing this avoids having lots of fields with red errors. -- doing this avoids having lots of fields with red errors.
let eraseParams | missing = local (\(_, h, l) -> (Nothing, h, l)) let eraseParams | missing = local (const Nothing)
| otherwise = id | otherwise = id
( res', w) <- eraseParams (form fragment') ( res', w) <- eraseParams (form fragment')
@ -418,12 +436,12 @@ identifyFormKey :: Text
identifyFormKey = "_formid" identifyFormKey = "_formid"
type FormRender m a = type FormRender site a =
AForm m a AForm site a
-> Html -> Html
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ()) -> MForm site (FormResult a, WidgetFor site ())
renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a renderTable, renderDivs, renderDivsNoLabels :: FormRender env a
-- | Render a form into a series of tr tags. Note that, in order to allow -- | Render a form into a series of tr tags. Note that, in order to allow
-- you to add extra rows to the table, this function does /not/ wrap up -- you to add extra rows to the table, this function does /not/ wrap up
-- the resulting HTML in a table tag; you must do that yourself. -- the resulting HTML in a table tag; you must do that yourself.
@ -457,7 +475,7 @@ renderDivs = renderDivsMaybeLabels True
-- | render a field inside a div, not displaying any label -- | render a field inside a div, not displaying any label
renderDivsNoLabels = renderDivsMaybeLabels False renderDivsNoLabels = renderDivsMaybeLabels False
renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a renderDivsMaybeLabels :: Bool -> FormRender env a
renderDivsMaybeLabels withLabels aform fragment = do renderDivsMaybeLabels withLabels aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
@ -495,7 +513,7 @@ $forall view <- views
-- > <input .btn .primary type=submit value=_{MsgSubmit}> -- > <input .btn .primary type=submit value=_{MsgSubmit}>
-- --
-- Since 1.3.14 -- Since 1.3.14
renderBootstrap2 :: Monad m => FormRender m a renderBootstrap2 :: FormRender env a
renderBootstrap2 aform fragment = do renderBootstrap2 aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
@ -516,26 +534,21 @@ renderBootstrap2 aform fragment = do
|] |]
return (res, widget) return (res, widget)
-- | Deprecated synonym for 'renderBootstrap2'. check :: RenderMessage site msg
renderBootstrap :: Monad m => FormRender m a
renderBootstrap = renderBootstrap2
{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}
check :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> Either msg a) => (a -> Either msg a)
-> Field m a -> Field site a
-> Field m a -> Field site a
check f = checkM $ return . f check f = checkM $ return . f
-- | Return the given error message if the predicate is false. -- | Return the given error message if the predicate is false.
checkBool :: (Monad m, RenderMessage (HandlerSite m) msg) checkBool :: RenderMessage site msg
=> (a -> Bool) -> msg -> Field m a -> Field m a => (a -> Bool) -> msg -> Field site a -> Field site a
checkBool b s = check $ \x -> if b x then Right x else Left s checkBool b s = check $ \x -> if b x then Right x else Left s
checkM :: (Monad m, RenderMessage (HandlerSite m) msg) checkM :: RenderMessage site msg
=> (a -> m (Either msg a)) => (a -> HandlerFor site (Either msg a))
-> Field m a -> Field site a
-> Field m a -> Field site a
checkM f = checkMMap f id checkM f = checkMMap f id
-- | Same as 'checkM', but modifies the datatype. -- | Same as 'checkM', but modifies the datatype.
@ -544,11 +557,11 @@ checkM f = checkMMap f id
-- the new datatype to the old one (the second argument to this function). -- the new datatype to the old one (the second argument to this function).
-- --
-- Since 1.1.2 -- Since 1.1.2
checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg) checkMMap :: RenderMessage site msg
=> (a -> m (Either msg b)) => (a -> HandlerFor site (Either msg b))
-> (b -> a) -> (b -> a)
-> Field m a -> Field site a
-> Field m b -> Field site b
checkMMap f inv field = field checkMMap f inv field = field
{ fieldParse = \ts fs -> do { fieldParse = \ts fs -> do
e1 <- fieldParse field ts fs e1 <- fieldParse field ts fs
@ -560,7 +573,7 @@ checkMMap f inv field = field
} }
-- | Allows you to overwrite the error message on parse error. -- | Allows you to overwrite the error message on parse error.
customErrorMessage :: Monad m => SomeMessage (HandlerSite m) -> Field m a -> Field m a customErrorMessage :: SomeMessage site -> Field site a -> Field site a
customErrorMessage msg field = field customErrorMessage msg field = field
{ fieldParse = \ts fs -> { fieldParse = \ts fs ->
liftM (either (const $ Left msg) Right) liftM (either (const $ Left msg) Right)
@ -611,11 +624,10 @@ parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $
-- > lazyTextField = convertField TL.fromStrict TL.toStrict textField -- > lazyTextField = convertField TL.fromStrict TL.toStrict textField
-- --
-- Since 1.3.16 -- Since 1.3.16
convertField :: (Functor m) convertField :: (a -> b) -> (b -> a)
=> (a -> b) -> (b -> a) -> Field env a -> Field env b
-> Field m a -> Field m b convertField to' from (Field fParse fView fEnctype) = let
convertField to from (Field fParse fView fEnctype) = let fParse' ts = fmap (fmap (fmap to')) . fParse ts
fParse' ts = fmap (fmap (fmap to)) . fParse ts
fView' ti tn at ei = fView ti tn at (fmap from ei) fView' ti tn at ei = fView ti tn at (fmap from ei)
in Field fParse' fView' fEnctype in Field fParse' fView' fEnctype

61
yesod-form/Yesod/Form/Input.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
-- | Provides for getting input from either GET or POST params without -- | Provides for getting input from either GET or POST params without
@ -26,14 +27,13 @@ type DText = [Text] -> [Text]
-- | Type for a form which parses a value of type @a@ with the base monad @m@ -- | Type for a form which parses a value of type @a@ with the base monad @m@
-- (usually your @Handler@). Can compose this using its @Applicative@ instance. -- (usually your @Handler@). Can compose this using its @Applicative@ instance.
newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) } newtype FormInput site a = FormInput { unFormInput :: Env -> FileEnv -> HandlerFor site (Either DText a) }
instance Monad m => Functor (FormInput m) where deriving Functor
fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e' instance Control.Applicative.Applicative (FormInput site) where
instance Monad m => Control.Applicative.Applicative (FormInput m) where pure x = FormInput $ \_env _filenv -> pure $ Right x
pure = FormInput . const . const . const . const . return . Right (FormInput f) <*> (FormInput x) = FormInput $ \env fileEnv -> do
(FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do res1 <- f env fileEnv
res1 <- f c d e e' res2 <- x env fileEnv
res2 <- x c d e e'
return $ case (res1, res2) of return $ case (res1, res2) of
(Left a, Left b) -> Left $ a . b (Left a, Left b) -> Left $ a . b
(Left a, _) -> Left a (Left a, _) -> Left a
@ -42,14 +42,16 @@ instance Monad m => Control.Applicative.Applicative (FormInput m) where
-- | Promote a @Field@ into a @FormInput@, requiring that the value be present -- | Promote a @Field@ into a @FormInput@, requiring that the value be present
-- and valid. -- and valid.
ireq :: (Monad m, RenderMessage (HandlerSite m) FormMessage) ireq :: RenderMessage site FormMessage
=> Field m a => Field site a
-> Text -- ^ name of the field -> Text -- ^ name of the field
-> FormInput m a -> FormInput site a
ireq field name = FormInput $ \m l env fenv -> do ireq field name = FormInput $ \env fenv -> do
let filteredEnv = fromMaybe [] $ Map.lookup name env let filteredEnv = fromMaybe [] $ Map.lookup name env
filteredFEnv = fromMaybe [] $ Map.lookup name fenv filteredFEnv = fromMaybe [] $ Map.lookup name fenv
emx <- fieldParse field filteredEnv filteredFEnv emx <- fieldParse field filteredEnv filteredFEnv
m <- getYesod
l <- reqLangs <$> getRequest
return $ case emx of return $ case emx of
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
@ -57,33 +59,34 @@ ireq field name = FormInput $ \m l env fenv -> do
-- | Promote a @Field@ into a @FormInput@, with its presence being optional. If -- | Promote a @Field@ into a @FormInput@, with its presence being optional. If
-- the value is present but does not parse correctly, the form will still fail. -- the value is present but does not parse correctly, the form will still fail.
iopt :: Monad m => Field m a -> Text -> FormInput m (Maybe a) iopt :: Field site a -> Text -> FormInput site (Maybe a)
iopt field name = FormInput $ \m l env fenv -> do iopt field name = FormInput $ \env fenv -> do
let filteredEnv = fromMaybe [] $ Map.lookup name env let filteredEnv = fromMaybe [] $ Map.lookup name env
filteredFEnv = fromMaybe [] $ Map.lookup name fenv filteredFEnv = fromMaybe [] $ Map.lookup name fenv
emx <- fieldParse field filteredEnv filteredFEnv emx <- fieldParse field filteredEnv filteredFEnv
return $ case emx of case emx of
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e Left (SomeMessage e) -> do
Right x -> Right x site <- getYesod
l <- reqLangs <$> getRequest
pure $ Left $ (:) $ renderMessage site l e
Right x -> pure $ Right x
-- | Run a @FormInput@ on the GET parameters (i.e., query string). If parsing -- | Run a @FormInput@ on the GET parameters (i.e., query string). If parsing
-- fails, calls 'invalidArgs'. -- fails, calls 'invalidArgs'.
runInputGet :: MonadHandler m => FormInput m a -> m a runInputGet :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env a
runInputGet = either invalidArgs return <=< runInputGetHelper runInputGet = either invalidArgs return <=< runInputGetHelper
-- | Run a @FormInput@ on the GET parameters (i.e., query string). Does /not/ -- | Run a @FormInput@ on the GET parameters (i.e., query string). Does /not/
-- throw exceptions on failure. -- throw exceptions on failure.
-- --
-- Since 1.4.1 -- Since 1.4.1
runInputGetResult :: MonadHandler m => FormInput m a -> m (FormResult a) runInputGetResult :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (FormResult a)
runInputGetResult = fmap (either FormFailure FormSuccess) . runInputGetHelper runInputGetResult = fmap (either FormFailure FormSuccess) . runInputGetHelper
runInputGetHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a) runInputGetHelper :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (Either [Text] a)
runInputGetHelper (FormInput f) = do runInputGetHelper (FormInput f) = do
env <- liftM (toMap . reqGetParams) getRequest env <- liftM (toMap . reqGetParams) getRequest
m <- getYesod emx <- liftHandler $ f env Map.empty
l <- languages
emx <- f m l env Map.empty
return $ either (Left . ($ [])) Right emx return $ either (Left . ($ [])) Right emx
toMap :: [(Text, a)] -> Map.Map Text [a] toMap :: [(Text, a)] -> Map.Map Text [a]
@ -91,17 +94,15 @@ toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
-- | Run a @FormInput@ on the POST parameters (i.e., request body). If parsing -- | Run a @FormInput@ on the POST parameters (i.e., request body). If parsing
-- fails, calls 'invalidArgs'. -- fails, calls 'invalidArgs'.
runInputPost :: MonadHandler m => FormInput m a -> m a runInputPost :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env a
runInputPost = either invalidArgs return <=< runInputPostHelper runInputPost = either invalidArgs return <=< runInputPostHelper
-- | Run a @FormInput@ on the POST parameters (i.e., request body). Does /not/ -- | Run a @FormInput@ on the POST parameters (i.e., request body). Does /not/
-- throw exceptions on failure. -- throw exceptions on failure.
runInputPostResult :: MonadHandler m => FormInput m a -> m (FormResult a) runInputPostResult :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (FormResult a)
runInputPostResult = fmap (either FormFailure FormSuccess) . runInputPostHelper runInputPostResult = fmap (either FormFailure FormSuccess) . runInputPostHelper
runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a) runInputPostHelper :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (Either [Text] a)
runInputPostHelper (FormInput f) = do runInputPostHelper (FormInput f) = liftHandler $ do
(env, fenv) <- liftM (toMap *** toMap) runRequestBody (env, fenv) <- liftM (toMap *** toMap) runRequestBody
m <- getYesod fmap (either (Left . ($ [])) Right) $ f env fenv
l <- languages
fmap (either (Left . ($ [])) Right) $ f m l env fenv

16
yesod-form/Yesod/Form/Jquery.hs
View File

@ -53,16 +53,16 @@ class YesodJquery a where
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field site Day
jqueryDayField = flip jqueryDayField' "date" jqueryDayField = flip jqueryDayField' "date"
-- | Use jQuery's datepicker as the underlying implementation. -- | Use jQuery's datepicker as the underlying implementation.
-- --
-- Since 1.4.3 -- Since 1.4.3
jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field site Day
jqueryDatePickerDayField = flip jqueryDayField' "text" jqueryDatePickerDayField = flip jqueryDayField' "text"
jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerFor site) Day jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field site Day
jqueryDayField' jds inputType = Field jqueryDayField' jds inputType = Field
{ fieldParse = parseHelper $ maybe { fieldParse = parseHelper $ maybe
(Left MsgInvalidDay) (Left MsgInvalidDay)
@ -107,13 +107,13 @@ $(function(){
] ]
jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site) jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
=> Route site -> Field (HandlerFor site) Text => Route site -> Field site Text
jqueryAutocompleteField = jqueryAutocompleteField' 2 jqueryAutocompleteField = jqueryAutocompleteField' 2
jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site) jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)
=> Int -- ^ autocomplete minimum length => Int -- ^ autocomplete minimum length
-> Route site -> Route site
-> Field (HandlerFor site) Text -> Field site Text
jqueryAutocompleteField' minLen src = Field jqueryAutocompleteField' minLen src = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> do , fieldView = \theId name attrs val isReq -> do
@ -130,14 +130,14 @@ $(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:#{toJS
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
addScript' :: (HandlerSite m ~ site, MonadWidget m) => (site -> Either (Route site) Text) -> m () addScript' :: (site -> Either (Route site) Text) -> WidgetFor site ()
addScript' f = do addScript' f = do
y <- getYesod y <- getYesod
addScriptEither $ f y addScriptEither $ f y
addStylesheet' :: (MonadWidget m, HandlerSite m ~ site) addStylesheet' :: (HasWidgetData env, HandlerSite env ~ site)
=> (site -> Either (Route site) Text) => (site -> Either (Route site) Text)
-> m () -> RIO env ()
addStylesheet' f = do addStylesheet' f = do
y <- getYesod y <- getYesod
addStylesheetEither $ f y addStylesheetEither $ f y

37
yesod-form/Yesod/Form/MassInput.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -11,11 +12,11 @@ module Yesod.Form.MassInput
, massTable , massTable
) where ) where
import RIO
import Yesod.Form.Types import Yesod.Form.Types
import Yesod.Form.Functions import Yesod.Form.Functions
import Yesod.Form.Fields (checkBoxField) import Yesod.Form.Fields (checkBoxField)
import Yesod.Core import Yesod.Core
import Control.Monad.Trans.RWS (get, put, ask)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text.Read (decimal) import Data.Text.Read (decimal)
import Control.Monad (liftM) import Control.Monad (liftM)
@ -24,43 +25,45 @@ import Data.Traversable (sequenceA)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
down :: Monad m => Int -> MForm m () down :: Int -> MForm site ()
down 0 = return () down 0 = return ()
down i | i < 0 = error "called down with a negative number" down i | i < 0 = error "called down with a negative number"
down i = do down i = do
is <- get ref <- view $ to mfdInts
put $ IntCons 0 is is <- readIORef ref
writeIORef ref $ IntCons 0 is
down $ i - 1 down $ i - 1
up :: Monad m => Int -> MForm m () up :: Int -> MForm site ()
up 0 = return () up 0 = return ()
up i | i < 0 = error "called down with a negative number" up i | i < 0 = error "called down with a negative number"
up i = do up i = do
is <- get ref <- view $ to mfdInts
is <- readIORef ref
case is of case is of
IntSingle _ -> error "up on IntSingle" IntSingle _ -> error "up on IntSingle"
IntCons _ is' -> put is' >> newFormIdent >> return () IntCons _ is' -> writeIORef ref is' >> newFormIdent >> return ()
up $ i - 1 up $ i - 1
-- | Generate a form that accepts 0 or more values from the user, allowing the -- | Generate a form that accepts 0 or more values from the user, allowing the
-- user to specify that a new row is necessary. -- user to specify that a new row is necessary.
inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage) inputList :: RenderMessage site FormMessage
=> Html => Html
-- ^ label for the form -- ^ label for the form
-> ([[FieldView site]] -> xml) -> ([[FieldView site]] -> WidgetFor site ())
-- ^ how to display the rows, usually either 'massDivs' or 'massTable' -- ^ how to display the rows, usually either 'massDivs' or 'massTable'
-> (Maybe a -> AForm (HandlerFor site) a) -> (Maybe a -> AForm site a)
-- ^ display a single row of the form, where @Maybe a@ gives the -- ^ display a single row of the form, where @Maybe a@ gives the
-- previously submitted value -- previously submitted value
-> Maybe [a] -> Maybe [a]
-- ^ default initial values for the form -- ^ default initial values for the form
-> AForm (HandlerFor site) [a] -> AForm site [a]
inputList label fixXml single mdef = formToAForm $ do inputList label fixXml single mdef = formToAForm $ do
theId <- lift newIdent theId <- newIdent
down 1 down 1
countName <- newFormIdent countName <- newFormIdent
addName <- newFormIdent addName <- newFormIdent
(menv, _, _) <- ask menv <- view $ to mfdParams
let readInt t = let readInt t =
case decimal t of case decimal t of
Right (i, "") -> Just i Right (i, "") -> Just i
@ -94,13 +97,13 @@ $newline never
, fvRequired = False , fvRequired = False
}]) }])
withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage) withDelete :: RenderMessage site FormMessage
=> AForm (HandlerFor site) a => AForm site a
-> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site])) -> MForm site (Either (WidgetFor site ())(FormResult a, [FieldView site]))
withDelete af = do withDelete af = do
down 1 down 1
deleteName <- newFormIdent deleteName <- newFormIdent
(menv, _, _) <- ask menv <- view $ to mfdParams
res <- case menv >>= Map.lookup deleteName . fst of res <- case menv >>= Map.lookup deleteName . fst of
Just ("yes":_) -> return $ Left [whamlet| Just ("yes":_) -> return $ Left [whamlet|
$newline never $newline never

6
yesod-form/Yesod/Form/Nic.hs
View File

@ -29,7 +29,7 @@ class Yesod a => YesodNic a where
urlNicEdit :: a -> Either (Route a) Text urlNicEdit :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
nicHtmlField :: YesodNic site => Field (HandlerFor site) Html nicHtmlField :: YesodNic site => Field site Html
nicHtmlField = Field nicHtmlField = Field
{ fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
, fieldView = \theId name attrs val _isReq -> do , fieldView = \theId name attrs val _isReq -> do
@ -52,9 +52,9 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{ra
where where
showVal = either id (pack . renderHtml) showVal = either id (pack . renderHtml)
addScript' :: (MonadWidget m, HandlerSite m ~ site) addScript' :: (HasWidgetData env, HandlerSite env ~ site)
=> (site -> Either (Route site) Text) => (site -> Either (Route site) Text)
-> m () -> RIO env ()
addScript' f = do addScript' f = do
y <- getYesod y <- getYesod
addScriptEither $ f y addScriptEither $ f y

96
yesod-form/Yesod/Form/Types.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
@ -15,6 +17,8 @@ module Yesod.Form.Types
, WForm , WForm
, MForm , MForm
, AForm (..) , AForm (..)
, WFormData (..)
, MFormData (..)
-- * Build forms -- * Build forms
, Field (..) , Field (..)
, FieldSettings (..) , FieldSettings (..)
@ -22,8 +26,8 @@ module Yesod.Form.Types
, FieldViewFunc , FieldViewFunc
) where ) where
import Control.Monad.Trans.RWS (RWST) import RIO
import Control.Monad.Trans.Writer (WriterT) import RIO.Orphans
import Data.Text (Text) import Data.Text (Text)
import Data.Monoid (Monoid (..)) import Data.Monoid (Monoid (..))
import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue)) import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue))
@ -31,10 +35,9 @@ import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue))
#define ToHtml ToMarkup #define ToHtml ToMarkup
#define toHtml toMarkup #define toHtml toMarkup
import Control.Applicative ((<$>), Alternative (..), Applicative (..)) import Control.Applicative ((<$>), Alternative (..), Applicative (..))
import Control.Monad (liftM)
import Control.Monad.Trans.Class
import Data.String (IsString (..)) import Data.String (IsString (..))
import Yesod.Core import Yesod.Core
import Yesod.Core.Types
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Semigroup (Semigroup, (<>)) import Data.Semigroup (Semigroup, (<>))
import Data.Traversable import Data.Traversable
@ -140,46 +143,53 @@ type FileEnv = Map.Map Text [FileInfo]
-- > return $ MyForm <$> field1F <*> field2F <*> field3F -- > return $ MyForm <$> field1F <*> field2F <*> field3F
-- --
-- @since 1.4.14 -- @since 1.4.14
type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a type WForm site = RIO (WFormData site)
data WFormData site = WFormData
{ wfdViews :: !(IORef ([FieldView site] -> [FieldView site]))
, wfdMfd :: !(MFormData site)
}
instance HasHandlerData (WFormData site) where
type HandlerSite (WFormData site) = site
type SubHandlerSite (WFormData site) = site
subHandlerDataL = (lens wfdMfd (\x y -> x { wfdMfd = y })).subHandlerDataL
instance HasResourceMap (WFormData site) where
resourceMapL = subHandlerDataL.resourceMapL
instance HasLogFunc (WFormData site) where
logFuncL = subHandlerDataL.logFuncL
type MForm m a = RWST type MForm site = RIO (MFormData site)
(Maybe (Env, FileEnv), HandlerSite m, [Lang]) data MFormData site = MFormData
Enctype { mfdHandlerData :: !(SubHandlerData site site)
Ints , mfdEnctype :: !(IORef Enctype)
m , mfdParams :: !(Maybe (Env, FileEnv))
a , mfdInts :: !(IORef Ints)
}
instance HasHandlerData (MFormData site) where
type HandlerSite (MFormData site) = site
type SubHandlerSite (MFormData site) = site
subHandlerDataL = lens mfdHandlerData (\x y -> x { mfdHandlerData = y})
instance HasResourceMap (MFormData site) where
resourceMapL = subHandlerDataL.resourceMapL
instance HasLogFunc (MFormData site) where
logFuncL = subHandlerDataL.logFuncL
newtype AForm m a = AForm newtype AForm site a = AForm (WForm site (FormResult a))
{ unAForm :: (HandlerSite m, [Text]) deriving Functor
-> Maybe (Env, FileEnv) instance Applicative (AForm site) where
-> Ints pure = AForm . pure . pure
-> m (FormResult a, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints, Enctype) (AForm f) <*> (AForm g) = AForm $ do
} f' <- f
instance Monad m => Functor (AForm m) where g' <- g
fmap f (AForm a) = pure $ f' <*> g'
AForm $ \x y z -> liftM go $ a x y z instance Monoid a => Monoid (AForm site a) where
where
go (w, x, y, z) = (fmap f w, x, y, z)
instance Monad m => Applicative (AForm m) where
pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, id, 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 . y, ints'', c `mappend` z)
instance (Monad m, Monoid a) => Monoid (AForm m a) where
mempty = pure mempty mempty = pure mempty
mappend a b = mappend <$> a <*> b mappend a b = mappend <$> a <*> b
instance (Monad m, Semigroup a) => Semigroup (AForm m a) where instance Semigroup a => Semigroup (AForm site a) where
a <> b = (<>) <$> a <*> b a <> b = (<>) <$> a <*> b
instance MonadTrans AForm where data FieldSettings site = FieldSettings
lift f = AForm $ \_ _ ints -> do { fsLabel :: SomeMessage site
x <- f , fsTooltip :: Maybe (SomeMessage site)
return (FormSuccess x, id, ints, mempty)
data FieldSettings master = FieldSettings
{ fsLabel :: SomeMessage master
, fsTooltip :: Maybe (SomeMessage master)
, fsId :: Maybe Text , fsId :: Maybe Text
, fsName :: Maybe Text , fsName :: Maybe Text
, fsAttrs :: [(Text, Text)] , fsAttrs :: [(Text, Text)]
@ -197,17 +207,17 @@ data FieldView site = FieldView
, fvRequired :: Bool , fvRequired :: Bool
} }
type FieldViewFunc m a type FieldViewFunc site a
= Text -- ^ ID = Text -- ^ ID
-> Text -- ^ Name -> Text -- ^ Name
-> [(Text, Text)] -- ^ Attributes -> [(Text, Text)] -- ^ Attributes
-> Either Text a -- ^ Either (invalid text) or (legitimate result) -> Either Text a -- ^ Either (invalid text) or (legitimate result)
-> Bool -- ^ Required? -> Bool -- ^ Required?
-> WidgetFor (HandlerSite m) () -> WidgetFor site ()
data Field m a = Field data Field site a = Field
{ fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)) { fieldParse :: [Text] -> [FileInfo] -> HandlerFor site (Either (SomeMessage site) (Maybe a))
, fieldView :: FieldViewFunc m a , fieldView :: FieldViewFunc site a
, fieldEnctype :: Enctype , fieldEnctype :: Enctype
} }

4
yesod-form/yesod-form.cabal
View File

@ -30,7 +30,7 @@ library
, containers >= 0.2 , containers >= 0.2
, data-default , data-default
, email-validate >= 1.0 , email-validate >= 1.0
, persistent , persistent >= 2.5
, resourcet , resourcet
, semigroups , semigroups
, shakespeare >= 2.0 , shakespeare >= 2.0
@ -41,6 +41,8 @@ library
, xss-sanitize >= 0.3.0.1 , xss-sanitize >= 0.3.0.1
, yesod-core >= 1.6 && < 1.7 , yesod-core >= 1.6 && < 1.7
, yesod-persistent >= 1.6 && < 1.7 , yesod-persistent >= 1.6 && < 1.7
, rio
, rio-orphans
if flag(network-uri) if flag(network-uri)
build-depends: network-uri >= 2.6 build-depends: network-uri >= 2.6

10
yesod-newsfeed/Yesod/AtomFeed.hs
View File

@ -42,14 +42,14 @@ instance HasContentType RepAtom where
instance ToTypedContent RepAtom where instance ToTypedContent RepAtom where
toTypedContent = TypedContent typeAtom . toContent toTypedContent = TypedContent typeAtom . toContent
atomFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepAtom atomFeed :: HasHandlerData env => Feed (Route (HandlerSite env)) -> RIO env RepAtom
atomFeed feed = do atomFeed feed = do
render <- getUrlRender render <- getUrlRender
return $ RepAtom $ toContent $ renderLBS def $ template feed render return $ RepAtom $ toContent $ renderLBS def $ template feed render
-- | Same as @'atomFeed'@ but for @'Feed Text'@. Useful for cases where you are -- | Same as @'atomFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links. -- generating a feed of external links.
atomFeedText :: MonadHandler m => Feed Text -> m RepAtom atomFeedText :: HasHandlerData env => Feed Text -> RIO env RepAtom
atomFeedText feed = return $ RepAtom $ toContent $ renderLBS def $ template feed id atomFeedText feed = return $ RepAtom $ toContent $ renderLBS def $ template feed id
template :: Feed url -> (url -> Text) -> Document template :: Feed url -> (url -> Text) -> Document
@ -90,10 +90,10 @@ entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElemen
,("href", render enclosedUrl)]) []] ,("href", render enclosedUrl)]) []]
-- | Generates a link tag in the head of a widget. -- | Generates a link tag in the head of a widget.
atomLink :: MonadWidget m atomLink :: HasWidgetData env
=> Route (HandlerSite m) => Route (HandlerSite env)
-> Text -- ^ title -> Text -- ^ title
-> m () -> RIO env ()
atomLink r title = toWidgetHead [hamlet| atomLink r title = toWidgetHead [hamlet|
<link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}> <link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
|] |]

4
yesod-newsfeed/Yesod/Feed.hs
View File

@ -28,14 +28,14 @@ import Yesod.Core
import Data.Text import Data.Text
newsFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m TypedContent newsFeed :: HasHandlerData env => Feed (Route (HandlerSite env)) -> RIO env TypedContent
newsFeed f = selectRep $ do newsFeed f = selectRep $ do
provideRep $ atomFeed f provideRep $ atomFeed f
provideRep $ rssFeed f provideRep $ rssFeed f
-- | Same as @'newsFeed'@ but for @'Feed Text'@. Useful for cases where you are -- | Same as @'newsFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links. -- generating a feed of external links.
newsFeedText :: MonadHandler m => Feed Text -> m TypedContent newsFeedText :: HasHandlerData env => Feed Text -> RIO env TypedContent
newsFeedText f = selectRep $ do newsFeedText f = selectRep $ do
provideRep $ atomFeedText f provideRep $ atomFeedText f
provideRep $ rssFeedText f provideRep $ rssFeedText f

10
yesod-newsfeed/Yesod/RssFeed.hs
View File

@ -39,14 +39,14 @@ instance ToTypedContent RepRss where
toTypedContent = TypedContent typeRss . toContent toTypedContent = TypedContent typeRss . toContent
-- | Generate the feed -- | Generate the feed
rssFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepRss rssFeed :: HasHandlerData env => Feed (Route (HandlerSite env)) -> RIO env RepRss
rssFeed feed = do rssFeed feed = do
render <- getUrlRender render <- getUrlRender
return $ RepRss $ toContent $ renderLBS def $ template feed render return $ RepRss $ toContent $ renderLBS def $ template feed render
-- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are -- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links. -- generating a feed of external links.
rssFeedText :: MonadHandler m => Feed Text -> m RepRss rssFeedText :: HasHandlerData env => Feed Text -> RIO env RepRss
rssFeedText feed = return $ RepRss $ toContent $ renderLBS def $ template feed id rssFeedText feed = return $ RepRss $ toContent $ renderLBS def $ template feed id
template :: Feed url -> (url -> Text) -> Document template :: Feed url -> (url -> Text) -> Document
@ -93,10 +93,10 @@ entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
,("url", render enclosedUrl)]) []] ,("url", render enclosedUrl)]) []]
-- | Generates a link tag in the head of a widget. -- | Generates a link tag in the head of a widget.
rssLink :: MonadWidget m rssLink :: HasWidgetData env
=> Route (HandlerSite m) => Route (HandlerSite env)
-> Text -- ^ title -> Text -- ^ title
-> m () -> RIO env ()
rssLink r title = toWidgetHead [hamlet| rssLink r title = toWidgetHead [hamlet|
<link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}> <link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
|] |]

6
yesod-sitemap/Yesod/Sitemap.hs
View File

@ -61,9 +61,9 @@ data SitemapUrl url = SitemapUrl
} }
-- | A basic robots file which just lists the "Sitemap: " line. -- | A basic robots file which just lists the "Sitemap: " line.
robots :: MonadHandler m robots :: HasHandlerData env
=> Route (HandlerSite m) -- ^ sitemap url => Route (HandlerSite env) -- ^ sitemap url
-> m Text -> RIO env Text
robots smurl = do robots smurl = do
ur <- getUrlRender ur <- getUrlRender
return $ T.unlines return $ T.unlines

116
yesod-websockets/Yesod/WebSockets.hs
View File

@ -1,9 +1,9 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Yesod.WebSockets module Yesod.WebSockets
( -- * Core API ( -- * Core API
WebSocketsT webSockets
, webSockets
, webSocketsWith , webSocketsWith
, webSocketsOptions , webSocketsOptions
, webSocketsOptionsWith , webSocketsOptionsWith
@ -39,12 +39,16 @@ import Conduit
import qualified Network.Wai.Handler.WebSockets as WaiWS import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS import qualified Network.WebSockets as WS
import qualified Yesod.Core as Y import qualified Yesod.Core as Y
import UnliftIO (SomeException, tryAny, MonadIO, liftIO, MonadUnliftIO, withRunInIO, race, race_, concurrently, concurrently_) import RIO
-- | A transformer for a WebSockets handler. -- FIXME document
-- class Y.HasHandlerData env => HasWebsockets env where
-- Since 0.1.0 websocketsL :: Lens' env WS.Connection
type WebSocketsT = ReaderT WS.Connection
data WithWebsockets env = WithWebsockets
{ wwConnection :: !WS.Connection
, wwEnv :: !env
}
-- | Attempt to run a WebSockets handler. This function first checks if the -- | Attempt to run a WebSockets handler. This function first checks if the
-- client initiated a WebSockets connection and, if so, runs the provided -- client initiated a WebSockets connection and, if so, runs the provided
@ -54,9 +58,9 @@ type WebSocketsT = ReaderT WS.Connection
-- --
-- Since 0.1.0 -- Since 0.1.0
webSockets webSockets
:: (MonadUnliftIO m, Y.MonadHandler m) :: Y.HasHandlerData env
=> WebSocketsT m () => RIO (WithWebsockets env) ()
-> m () -> RIO env ()
webSockets = webSocketsOptions WS.defaultConnectionOptions webSockets = webSocketsOptions WS.defaultConnectionOptions
-- | Varient of 'webSockets' which allows you to specify -- | Varient of 'webSockets' which allows you to specify
@ -64,26 +68,26 @@ webSockets = webSocketsOptions WS.defaultConnectionOptions
-- --
-- Since 0.2.5 -- Since 0.2.5
webSocketsOptions webSocketsOptions
:: (MonadUnliftIO m, Y.MonadHandler m) :: Y.HasHandlerData env
=> WS.ConnectionOptions => WS.ConnectionOptions
-> WebSocketsT m () -> RIO (WithWebsockets env) ()
-> m () -> RIO env ()
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing [] webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing []
-- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest' -- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest'
-- setttings when upgrading to a websocket connection. -- setttings when upgrading to a websocket connection.
-- --
-- Since 0.2.4 -- Since 0.2.4
webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m) webSocketsWith :: Y.HasHandlerData env
=> (WS.RequestHead -> m (Maybe WS.AcceptRequest)) => (WS.RequestHead -> RIO env (Maybe WS.AcceptRequest))
-- ^ A Nothing indicates that the websocket upgrade request should not happen -- ^ A Nothing indicates that the websocket upgrade request should not happen
-- and instead the rest of the handler will be called instead. This allows -- and instead the rest of the handler will be called instead. This allows
-- you to use 'WS.getRequestSubprotocols' and only accept the request if -- you to use 'WS.getRequestSubprotocols' and only accept the request if
-- a compatible subprotocol is given. Also, the action runs before upgrading -- a compatible subprotocol is given. Also, the action runs before upgrading
-- the request to websockets, so you can also use short-circuiting handler -- the request to websockets, so you can also use short-circuiting handler
-- actions such as 'Y.invalidArgs'. -- actions such as 'Y.invalidArgs'.
-> WebSocketsT m () -> RIO (WithWebsockets env) ()
-> m () -> RIO env ()
webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
-- | Varient of 'webSockets' which allows you to specify both -- | Varient of 'webSockets' which allows you to specify both
@ -91,18 +95,18 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
-- setttings when upgrading to a websocket connection. -- setttings when upgrading to a websocket connection.
-- --
-- Since 0.2.5 -- Since 0.2.5
webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m) webSocketsOptionsWith :: Y.HasHandlerData env
=> WS.ConnectionOptions => WS.ConnectionOptions
-- ^ Custom websockets options -- ^ Custom websockets options
-> (WS.RequestHead -> m (Maybe WS.AcceptRequest)) -> (WS.RequestHead -> RIO env (Maybe WS.AcceptRequest))
-- ^ A Nothing indicates that the websocket upgrade request should not happen -- ^ A Nothing indicates that the websocket upgrade request should not happen
-- and instead the rest of the handler will be called instead. This allows -- and instead the rest of the handler will be called instead. This allows
-- you to use 'WS.getRequestSubprotocols' and only accept the request if -- you to use 'WS.getRequestSubprotocols' and only accept the request if
-- a compatible subprotocol is given. Also, the action runs before upgrading -- a compatible subprotocol is given. Also, the action runs before upgrading
-- the request to websockets, so you can also use short-circuiting handler -- the request to websockets, so you can also use short-circuiting handler
-- actions such as 'Y.invalidArgs'. -- actions such as 'Y.invalidArgs'.
-> WebSocketsT m () -> RIO (WithWebsockets env) ()
-> m () -> RIO env ()
webSocketsOptionsWith wsConnOpts buildAr inner = do webSocketsOptionsWith wsConnOpts buildAr inner = do
req <- Y.waiRequest req <- Y.waiRequest
when (WaiWS.isWebSocketsReq req) $ do when (WaiWS.isWebSocketsReq req) $ do
@ -110,43 +114,45 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
mar <- buildAr rhead mar <- buildAr rhead
case mar of case mar of
Nothing -> return () Nothing -> return ()
Just ar -> Just ar -> do
env <- ask
Y.sendRawResponseNoConduit Y.sendRawResponseNoConduit
$ \src sink -> withRunInIO $ \runInIO -> WaiWS.runWebSockets $ \src sink -> liftIO $ WaiWS.runWebSockets
wsConnOpts wsConnOpts
rhead rhead
(\pconn -> do (\pconn -> do
conn <- WS.acceptRequestWith pconn ar conn <- WS.acceptRequestWith pconn ar
WS.forkPingThread conn 30 WS.forkPingThread conn 30
runInIO $ runReaderT inner conn) let ww = WithWebsockets conn env
runRIO ww inner)
src src
sink sink
-- | Wrapper for capturing exceptions -- | Wrapper for capturing exceptions
wrapWSE :: (MonadIO m, MonadReader WS.Connection m) wrapWSE :: HasWebsockets env
=> (WS.Connection -> a -> IO ()) => (WS.Connection -> a -> IO ())
-> a -> a
-> m (Either SomeException ()) -> RIO env (Either SomeException ())
wrapWSE ws x = do wrapWSE ws x = do
conn <- ask conn <- view websocketsL
liftIO $ tryAny $ ws conn x liftIO $ tryAny $ ws conn x
wrapWS :: (MonadIO m, MonadReader WS.Connection m) wrapWS :: HasWebsockets env
=> (WS.Connection -> a -> IO ()) => (WS.Connection -> a -> IO ())
-> a -> a
-> m () -> RIO env ()
wrapWS ws x = do wrapWS ws x = do
conn <- ask conn <- view websocketsL
liftIO $ ws conn x liftIO $ ws conn x
-- | Receive a piece of data from the client. -- | Receive a piece of data from the client.
-- --
-- Since 0.1.0 -- Since 0.1.0
receiveData receiveData
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a) :: (WS.WebSocketsData a, HasWebsockets env)
=> m a => RIO env a
receiveData = do receiveData = do
conn <- ask conn <- view websocketsL
liftIO $ WS.receiveData conn liftIO $ WS.receiveData conn
-- | Receive a piece of data from the client. -- | Receive a piece of data from the client.
@ -173,9 +179,9 @@ receiveDataMessageE = do
-- --
-- Since 0.1.0 -- Since 0.1.0
sendTextData sendTextData
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> a => a
-> m () -> RIO env ()
sendTextData = wrapWS WS.sendTextData sendTextData = wrapWS WS.sendTextData
-- | Send a textual message to the client. -- | Send a textual message to the client.
@ -184,45 +190,45 @@ sendTextData = wrapWS WS.sendTextData
-- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)` -- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)`
-- Since 0.2.2 -- Since 0.2.2
sendTextDataE sendTextDataE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> a => a
-> m (Either SomeException ()) -> RIO env (Either SomeException ())
sendTextDataE = wrapWSE WS.sendTextData sendTextDataE = wrapWSE WS.sendTextData
-- | Send a binary message to the client. -- | Send a binary message to the client.
-- --
-- Since 0.1.0 -- Since 0.1.0
sendBinaryData sendBinaryData
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> a => a
-> m () -> RIO env ()
sendBinaryData = wrapWS WS.sendBinaryData sendBinaryData = wrapWS WS.sendBinaryData
-- | Send a binary message to the client. -- | Send a binary message to the client.
-- Capture SomeException as the result of operation -- Capture SomeException as the result of operation
-- Since 0.2.2 -- Since 0.2.2
sendBinaryDataE sendBinaryDataE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> a => a
-> m (Either SomeException ()) -> RIO env (Either SomeException ())
sendBinaryDataE = wrapWSE WS.sendBinaryData sendBinaryDataE = wrapWSE WS.sendBinaryData
-- | Send a ping message to the client. -- | Send a ping message to the client.
-- --
-- Since 0.2.2 -- Since 0.2.2
sendPing sendPing
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> a => a
-> WebSocketsT m () -> RIO env ()
sendPing = wrapWS WS.sendPing sendPing = wrapWS WS.sendPing
-- | Send a ping message to the client. -- | Send a ping message to the client.
-- Capture SomeException as the result of operation -- Capture SomeException as the result of operation
-- Since 0.2.2 -- Since 0.2.2
sendPingE sendPingE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> a => a
-> m (Either SomeException ()) -> RIO env (Either SomeException ())
sendPingE = wrapWSE WS.sendPing sendPingE = wrapWSE WS.sendPing
-- | Send a DataMessage to the client. -- | Send a DataMessage to the client.
@ -240,40 +246,40 @@ sendDataMessageE x = do
-- --
-- Since 0.2.2 -- Since 0.2.2
sendClose sendClose
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> a => a
-> WebSocketsT m () -> RIO env ()
sendClose = wrapWS WS.sendClose sendClose = wrapWS WS.sendClose
-- | Send a close request to the client. -- | Send a close request to the client.
-- Capture SomeException as the result of operation -- Capture SomeException as the result of operation
-- Since 0.2.2 -- Since 0.2.2
sendCloseE sendCloseE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> a => a
-> m (Either SomeException ()) -> RIO env (Either SomeException ())
sendCloseE = wrapWSE WS.sendClose sendCloseE = wrapWSE WS.sendClose
-- | A @Source@ of WebSockets data from the user. -- | A @Source@ of WebSockets data from the user.
-- --
-- Since 0.1.0 -- Since 0.1.0
sourceWS sourceWS
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> ConduitT i a m () => ConduitT i a (RIO env) ()
sourceWS = forever $ lift receiveData >>= yield sourceWS = forever $ lift receiveData >>= yield
-- | A @Sink@ for sending textual data to the user. -- | A @Sink@ for sending textual data to the user.
-- --
-- Since 0.1.0 -- Since 0.1.0
sinkWSText sinkWSText
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> ConduitT a o m () => ConduitT a o (RIO env) ()
sinkWSText = mapM_C sendTextData sinkWSText = mapM_C sendTextData
-- | A @Sink@ for sending binary data to the user. -- | A @Sink@ for sending binary data to the user.
-- --
-- Since 0.1.0 -- Since 0.1.0
sinkWSBinary sinkWSBinary
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) :: (WS.WebSocketsData a, HasWebsockets env)
=> ConduitT a o m () => ConduitT a o (RIO env) ()
sinkWSBinary = mapM_C sendBinaryData sinkWSBinary = mapM_C sendBinaryData

1
yesod-websockets/yesod-websockets.cabal
View File

@ -22,6 +22,7 @@ library
, wai-websockets >= 2.1 , wai-websockets >= 2.1
, websockets >= 0.10 , websockets >= 0.10
, yesod-core >= 1.6 , yesod-core >= 1.6
, rio
source-repository head source-repository head
type: git type: git