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
-- set any necessary headers.
prepareForEventSource :: MonadHandler m => m EventSourcePolyfill
prepareForEventSource :: HasHandlerData env => RIO env EventSourcePolyfill
prepareForEventSource = do
reqWith <- lookup "X-Requested-With" . W.requestHeaders Data.Functor.<$> waiRequest
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.
--
-- Since: yesod-form 1.3.8
renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
renderBootstrap3 :: BootstrapFormLayout -> FormRender site a
renderBootstrap3 formLayout aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
@ -223,8 +223,8 @@ instance IsString msg => IsString (BootstrapSubmit msg) where
--
-- Since: yesod-form 1.3.8
bootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BootstrapSubmit msg -> AForm m ()
:: RenderMessage site msg
=> BootstrapSubmit msg -> AForm site ()
bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
@ -234,8 +234,8 @@ bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
--
-- Since: yesod-form 1.3.8
mbootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
:: RenderMessage site msg
=> BootstrapSubmit msg -> MForm site (FormResult (), FieldView site)
mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
let res = FormSuccess ()
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 NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
@ -60,11 +61,13 @@ module Yesod.Form.Fields
, optionsEnum
) where
import RIO
import Yesod.Form.Types
import Yesod.Form.I18n.English
import Yesod.Form.Functions (parseHelper)
import Yesod.Core
import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
import Prelude (zipWith)
#define ToHtml ToMarkup
#define toHtml toMarkup
#define preEscapedText preEscapedToMarkup
@ -117,10 +120,10 @@ defaultFormMessage :: FormMessage -> Text
defaultFormMessage = englishFormMessage
-- | 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
{ 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
_ -> Left $ MsgInvalidInteger s
@ -135,7 +138,7 @@ $newline never
showI x = show (fromIntegral x :: Integer)
-- | 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
{ fieldParse = parseHelper $ \s ->
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.
--
-- 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
{ fieldParse = parseHelper $ parseDate . unpack
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -165,7 +168,7 @@ $newline never
where showVal = either id (pack . show)
-- | An alias for 'timeFieldTypeTime'.
timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField :: RenderMessage site FormMessage => Field site TimeOfDay
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'.
@ -173,7 +176,7 @@ timeField = timeFieldTypeTime
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
--
-- Since 1.4.2
timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeFieldTypeTime :: RenderMessage site FormMessage => Field site TimeOfDay
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).
@ -183,10 +186,10 @@ timeFieldTypeTime = timeFieldOfType "time"
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
--
-- Since 1.4.2
timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeFieldTypeText :: RenderMessage site FormMessage => Field site TimeOfDay
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
{ fieldParse = parseHelper parseTime
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -203,7 +206,7 @@ $newline never
fullSec = fromInteger $ floor $ todSec tod
-- | 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
{ fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -239,7 +242,7 @@ instance ToHtml Textarea where
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
-- | 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
{ fieldParse = parseHelper $ Right . Textarea
, 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).
hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
=> Field m p
hiddenField :: (PathPiece p, RenderMessage site FormMessage)
=> Field site p
hiddenField = Field
{ fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@ -262,7 +265,7 @@ $newline never
}
-- | 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
{ fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq ->
@ -273,7 +276,7 @@ $newline never
, fieldEnctype = UrlEncoded
}
-- | 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
{ fieldParse = parseHelper $ Right
, fieldView = \theId name attrs _ isReq -> toWidget [hamlet|
@ -283,15 +286,10 @@ $newline never
, 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'.
parseDate :: String -> Either FormMessage Day
parseDate = maybe (Left MsgInvalidDay) Right
. readMay . replace '/' '-'
. readMaybe . replace '/' '-'
-- | Replaces all instances of a value in a list by another value.
-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
@ -299,7 +297,7 @@ replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z)
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 = do
@ -331,7 +329,10 @@ timeParser = do
x <- digit
y <- (return Control.Applicative.<$> digit) <|> return []
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
then fail $ show $ MsgInvalidHour $ pack xy
else return i
@ -340,13 +341,16 @@ timeParser = do
x <- digit
y <- digit <|> fail (show $ msg $ pack [x])
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
then fail $ show $ msg $ pack xy
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").
emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
emailField :: RenderMessage site FormMessage => Field site Text
emailField = Field
{ fieldParse = parseHelper $
\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'.
--
-- Since 1.3.7
multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
multiEmailField :: RenderMessage site FormMessage => Field site [Text]
multiEmailField = Field
{ fieldParse = parseHelper $
\s ->
@ -387,7 +391,7 @@ $newline never
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.
searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
searchField :: RenderMessage site FormMessage => AutoFocus -> Field site Text
searchField autoFocus = Field
{ fieldParse = parseHelper Right
, fieldView = \theId name attrs val isReq -> do
@ -408,7 +412,7 @@ $newline never
, fieldEnctype = UrlEncoded
}
-- | 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
{ fieldParse = parseHelper $ \s ->
case parseURI $ unpack s of
@ -424,7 +428,7 @@ urlField = Field
-- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerFor site) a
-> Field site a
selectFieldList = selectField . optionsPairs
-- | 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
selectField :: (Eq a, RenderMessage site FormMessage)
=> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
-> Field site a
selectField = selectFieldHelper
(\theId name attrs inside -> [whamlet|
$newline never
@ -450,15 +454,15 @@ $newline never
-- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectFieldList :: (Eq a, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerFor site) [a]
-> Field site [a]
multiSelectFieldList = multiSelectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectField :: Eq a
=> HandlerFor site (OptionList a)
-> Field (HandlerFor site) [a]
-> Field site [a]
multiSelectField ioptlist =
Field parse view UrlEncoded
Field parse view' UrlEncoded
where
parse [] _ = return $ Right Nothing
parse optlist _ = do
@ -467,7 +471,7 @@ multiSelectField ioptlist =
Nothing -> return $ Left "Error parsing values"
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
let selOpts = map (id &&& (optselected val)) opts
[whamlet|
@ -482,18 +486,18 @@ multiSelectField ioptlist =
-- | Creates an input with @type="radio"@ for selecting one option.
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerFor site) a
-> Field site a
radioFieldList = radioField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
-> Field (HandlerFor site) [a]
-> Field site [a]
checkboxesFieldList = checkboxesField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesField :: Eq a
=> HandlerFor site (OptionList a)
-> Field (HandlerFor site) [a]
-> Field site [a]
checkboxesField ioptlist = (multiSelectField ioptlist)
{ fieldView =
\theId name attrs val _isReq -> do
@ -511,7 +515,7 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
-- | Creates an input with @type="radio"@ for selecting one option.
radioField :: (Eq a, RenderMessage site FormMessage)
=> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
-> Field site a
radioField = selectFieldHelper
(\theId _name _attrs inside -> [whamlet|
$newline never
@ -539,7 +543,7 @@ $newline never
-- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
--
-- (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
{ fieldParse = \e _ -> return $ boolParser e
, fieldView = \theId name attrs val isReq -> [whamlet|
@ -578,7 +582,7 @@ $newline never
--
-- Note that this makes the field always optional.
--
checkBoxField :: Monad m => Field m Bool
checkBoxField :: Field site Bool
checkBoxField = Field
{ fieldParse = \e _ -> return $ checkBoxParser e
, fieldView = \theId name attrs val _ -> [whamlet|
@ -623,22 +627,21 @@ data Option a = Option
-- | Since 1.4.6
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.
optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
=> [(msg, a)] -> m (OptionList a)
optionsPairs :: RenderMessage site msg => [(msg, a)] -> HandlerFor site (OptionList a)
optionsPairs opts = do
mr <- getMessageRender
let mkOption external (display, internal) =
Option { optionDisplay = mr display
let mkOption external (display', internal) =
Option { optionDisplay = mr display'
, optionInternalValue = internal
, optionExternalValue = pack $ show external
}
return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
-- | 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]
-- | 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
-- > where
-- > countries = optionsPersist [] [Asc CountryName] countryName
#if MIN_VERSION_persistent(2,5,0)
optionsPersist :: ( YesodPersist site
, PersistQueryRead backend
, PathPiece (Key a)
, RenderMessage site msg
, YesodPersistBackend site ~ backend
, PersistRecordBackend a backend
, site ~ HandlerSite env
, HasHandlerData env
)
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (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
-> RIO env (OptionList (Entity a))
optionsPersist filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender
pairs <- runDB $ selectList filts ords
pairs <- liftHandler $ runDB $ selectList filts ords
return $ map (\(Entity key value) -> Option
{ optionDisplay = mr (toDisplay value)
, optionInternalValue = Entity key value
@ -693,35 +685,21 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
-- the entire 'Entity'.
--
-- Since 1.3.2
#if MIN_VERSION_persistent(2,5,0)
optionsPersistKey
:: (YesodPersist site
:: ( YesodPersist site
, PersistQueryRead backend
, PathPiece (Key a)
, RenderMessage site msg
, backend ~ YesodPersistBackend site
, site ~ HandlerSite env
, PersistRecordBackend a backend
, HasHandlerData env
)
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (OptionList (Key a))
#else
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
-> RIO env (OptionList (Key a))
optionsPersistKey filts ords toDisplay = liftHandler $ fmap mkOptionList $ do
mr <- getMessageRender
pairs <- runDB $ selectList filts ords
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 -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
-> Field site a
selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x _ -> do
opts <- opts'
@ -770,8 +748,7 @@ selectFieldHelper outside onOpt inside opts' = Field
Just y -> Right $ Just y
-- | Creates an input with @type="file"@.
fileField :: Monad m
=> Field m FileInfo
fileField :: Field site FileInfo
fileField = Field
{ fieldParse = \_ files -> return $
case files of
@ -783,18 +760,23 @@ fileField = Field
, fieldEnctype = Multipart
}
fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
=> FieldSettings (HandlerSite m) -> AForm m FileInfo
fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
fileAFormReq :: RenderMessage site FormMessage
=> FieldSettings site -> AForm site FileInfo
fileAFormReq fs = AForm $ do
site <- getYesod
langs <- reqLangs <$> getRequest
WFormData viewsRef mfd <- view id
ints <- readIORef $ mfdInts mfd
let (name, ints') =
case fsName fs of
Just x -> (x, ints)
Nothing ->
let i' = incrInts ints
in (pack $ 'f' : show i', i')
writeIORef (mfdInts mfd) ints'
id' <- maybe newIdent return $ fsId fs
let (res, errs) =
case menvs of
case mfdParams mfd of
Nothing -> (FormMissing, Nothing)
Just (_, fenv) ->
case Map.lookup name fenv of
@ -813,21 +795,26 @@ $newline never
, fvErrors = errs
, fvRequired = True
}
return (res, (fv :), ints', Multipart)
writeIORef (mfdEnctype mfd) Multipart
modifyIORef viewsRef $ \views -> views . (fv:)
return res
fileAFormOpt :: MonadHandler m
=> FieldSettings (HandlerSite m)
-> AForm m (Maybe FileInfo)
fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
fileAFormOpt :: FieldSettings site -> AForm site (Maybe FileInfo)
fileAFormOpt fs = AForm $ do
master <- getYesod
langs <- reqLangs <$> getRequest
WFormData viewsRef mfd <- view id
ints <- readIORef $ mfdInts mfd
let (name, ints') =
case fsName fs of
Just x -> (x, ints)
Nothing ->
let i' = incrInts ints
in (pack $ 'f' : show i', i')
writeIORef (mfdInts mfd) ints'
id' <- maybe newIdent return $ fsId fs
let (res, errs) =
case menvs of
case mfdParams mfd of
Nothing -> (FormMissing, Nothing)
Just (_, fenv) ->
case Map.lookup name fenv of
@ -844,7 +831,9 @@ $newline never
, fvErrors = errs
, fvRequired = False
}
return (res, (fv :), ints', Multipart)
writeIORef (mfdEnctype mfd) Multipart
modifyIORef viewsRef $ \views -> views . (fv:)
return res
incrInts :: Ints -> Ints
incrInts (IntSingle i) = IntSingle $ i + 1

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

@ -1,3 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
@ -38,7 +39,6 @@ module Yesod.Form.Functions
, renderTable
, renderDivs
, renderDivsNoLabels
, renderBootstrap
, renderBootstrap2
-- * Validation
, check
@ -55,13 +55,12 @@ module Yesod.Form.Functions
, removeClass
) where
import RIO hiding (ask, local)
import Yesod.Form.Types
import Yesod.Core.Types (liftHandler)
import Data.Text (Text, pack)
import qualified Data.Text as T
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 Data.Byteable (constEqBytes)
import Text.Blaze (Markup, toMarkup)
@ -75,8 +74,28 @@ import qualified Data.Map as Map
import qualified Data.Text.Encoding as TE
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.
newFormIdent :: Monad m => MForm m Text
newFormIdent :: MForm site Text
newFormIdent = do
i <- get
let i' = incrInts i
@ -86,43 +105,34 @@ newFormIdent = do
incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is
formToAForm :: (HandlerSite m ~ site, Monad m)
=> MForm m (FormResult a, [FieldView site])
-> AForm m a
formToAForm form = AForm $ \(site, langs) env ints -> do
((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints
return (a, (++) xmls, ints', enc)
formToAForm :: MForm site (FormResult a, [FieldView site]) -> AForm site a
formToAForm mform = AForm $ do
WFormData viewsRef mfd <- view id
(a, views) <- runRIO mfd mform
modifyIORef' viewsRef $ \front -> front . (views++)
pure a
aFormToForm :: (Monad m, HandlerSite m ~ site)
=> AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm (AForm aform) = do
ints <- get
(env, site, langs) <- ask
(a, xml, ints', enc) <- lift $ aform (site, langs) env ints
put ints'
tell enc
return (a, xml)
aFormToForm :: AForm site a
-> MForm site (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm (AForm wform) = do
(res, views) <- wFormToMForm wform
pure (res, (views++))
askParams :: Monad m => MForm m (Maybe Env)
askParams = do
(x, _, _) <- ask
return $ liftM fst x
askParams :: MForm site (Maybe Env)
askParams = view $ to (fmap fst . mfdParams)
askFiles :: Monad m => MForm m (Maybe FileEnv)
askFiles = do
(x, _, _) <- ask
return $ liftM snd x
askFiles :: MForm site (Maybe FileEnv)
askFiles = view $ to (fmap snd . mfdParams)
-- | Converts a form field into monadic form 'WForm'. This field requires a
-- value and will return 'FormFailure' if left empty.
--
-- @since 1.4.14
wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -- ^ form field
wreq :: RenderMessage site FormMessage
=> Field site a -- ^ form field
-> FieldSettings site -- ^ settings for this field
-> Maybe a -- ^ optional default value
-> WForm m (FormResult a)
-> WForm site (FormResult a)
wreq f fs = mFormToWForm . mreq f fs
-- | Converts a form field into monadic form 'WForm'. This field is optional,
@ -131,75 +141,78 @@ wreq f fs = mFormToWForm . mreq f fs
-- value).
--
-- @since 1.4.14
wopt :: (MonadHandler m, HandlerSite m ~ site)
=> Field m a -- ^ form field
wopt :: Field site a -- ^ form field
-> FieldSettings site -- ^ settings for this field
-> Maybe (Maybe a) -- ^ optional default value
-> WForm m (FormResult (Maybe a))
-> WForm site (FormResult (Maybe a))
wopt f fs = mFormToWForm . mopt f fs
-- | Converts a monadic form 'WForm' into an applicative form 'AForm'.
--
-- @since 1.4.14
wFormToAForm :: MonadHandler m
=> WForm m (FormResult a) -- ^ input form
-> AForm m a -- ^ output form
wFormToAForm
:: WForm site (FormResult a) -- ^ input form
-> AForm site a -- ^ output form
wFormToAForm = formToAForm . wFormToMForm
-- | Converts a monadic form 'WForm' into another monadic form 'MForm'.
--
-- @since 1.4.14
wFormToMForm :: (MonadHandler m, HandlerSite m ~ site)
=> WForm m a -- ^ input form
-> MForm m (a, [FieldView site]) -- ^ output form
wFormToMForm = mapRWST (fmap group . runWriterT)
where
group ((a, ints, enctype), views) = ((a, views), ints, enctype)
wFormToMForm
:: WForm site a -- ^ input form
-> MForm site (a, [FieldView site]) -- ^ output form
wFormToMForm wform = do
viewsRef <- newIORef id
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'.
--
-- @since 1.4.14
mFormToWForm :: (MonadHandler m, HandlerSite m ~ site)
=> MForm m (a, FieldView site) -- ^ input form
-> WForm m a -- ^ output form
mFormToWForm = mapRWST $ \f -> do
((a, view), ints, enctype) <- lift f
writer ((a, ints, enctype), [view])
mFormToWForm
:: MForm site (a, FieldView site) -- ^ input form
-> WForm site a -- ^ output form
mFormToWForm mform = do
WFormData views mfd <- view id
(a, view') <- runRIO mfd mform
modifyIORef' views $ \front -> front . (view':)
pure a
-- | Converts a form field into monadic form. This field requires a value
-- and will return 'FormFailure' if left empty.
mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -- ^ form field
mreq :: RenderMessage site FormMessage
=> Field site a -- ^ form field
-> FieldSettings site -- ^ settings for this field
-> 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
-- | 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'.
-- Arguments are the same as for 'mreq' (apart from type of default value).
mopt :: (site ~ HandlerSite m, MonadHandler m)
=> Field m a
mopt :: Field site a
-> FieldSettings site
-> 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
mhelper :: (site ~ HandlerSite m, MonadHandler m)
=> Field m a
mhelper :: Field site a
-> FieldSettings site
-> Maybe a
-> (site -> [Text] -> FormResult b) -- ^ on missing
-> (a -> FormResult b) -- ^ on success
-> Bool -- ^ is it required?
-> MForm m (FormResult b, FieldView site)
-> MForm site (FormResult b, FieldView site)
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
tell fieldEnctype
mp <- askParams
name <- maybe newFormIdent return fsName
theId <- lift $ maybe newIdent return fsId
(_, site, langs) <- ask
theId <- maybe newIdent return fsId
site <- getYesod
langs <- reqLangs <$> getRequest
let mr2 = renderMessage site langs
(res, val) <-
case mp of
@ -208,7 +221,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
mfs <- askFiles
let mvals = fromMaybe [] $ Map.lookup name p
files = fromMaybe [] $ mfs >>= Map.lookup name
emx <- lift $ fieldParse mvals files
emx <- liftHandler $ fieldParse mvals files
return $ case emx of
Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals))
Right mx ->
@ -228,28 +241,37 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
})
-- | Applicative equivalent of 'mreq'.
areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a
areq :: RenderMessage site FormMessage
=> Field site a
-> FieldSettings site
-> Maybe a
-> AForm m a
-> AForm site a
areq a b = formToAForm . liftM (second return) . mreq a b
-- | Applicative equivalent of 'mopt'.
aopt :: MonadHandler m
=> Field m a
-> FieldSettings (HandlerSite m)
aopt :: Field site a
-> FieldSettings site
-> Maybe (Maybe a)
-> AForm m (Maybe a)
-> AForm site (Maybe a)
aopt a b = formToAForm . liftM (second return) . mopt a b
runFormGeneric :: Monad m
=> MForm m a
-> HandlerSite m
-> [Text]
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0)
runFormGeneric
:: HasHandlerData env
=> MForm (HandlerSite env) a
-> Maybe (Env, FileEnv)
-> RIO env (a, Enctype)
runFormGeneric mform params = do
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
-- 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
-- the form submit to a POST page. In such a case, both the GET and POST
-- handlers should use 'runFormPost'.
runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)
=> (Html -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype)
runFormPost
:: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
=> (Html -> MForm (HandlerSite env) (FormResult a, xml))
-> RIO env ((FormResult a, xml), Enctype)
runFormPost form = do
env <- postEnv
postHelper form env
postHelper :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
=> (Html -> MForm m (FormResult a, xml))
-> Maybe (Env, FileEnv)
-> m ((FormResult a, xml), Enctype)
postHelper
:: (HasHandlerData env, RenderMessage (HandlerSite env) FormMessage)
=> (Html -> MForm (HandlerSite env) (FormResult a, xml))
-> Maybe (Env, FileEnv)
-> RIO env ((FormResult a, xml), Enctype)
postHelper form env = do
req <- getRequest
let tokenKey = defaultCsrfParamName
@ -278,15 +302,14 @@ postHelper form env = do
case reqToken req of
Nothing -> Data.Monoid.mempty
Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
m <- getYesod
langs <- languages
((res, xml), enctype) <- runFormGeneric (form token) m langs env
((res, xml), enctype) <- runFormGeneric (form token) env
site <- getYesod
let res' =
case (res, env) of
(_, Nothing) -> FormMissing
(FormSuccess{}, Just (params, _))
| not (Map.lookup tokenKey params === reqToken req) ->
FormFailure [renderMessage m langs MsgCsrfWarning]
FormFailure [renderMessage site (reqLangs req) MsgCsrfWarning]
_ -> res
-- 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
@ -299,12 +322,12 @@ postHelper form env = do
-- page will both receive and incoming form and produce a new, blank form. For
-- general usage, you can stick with @runFormPost@.
generateFormPost
:: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
=> (Html -> MForm m (FormResult a, xml))
-> m (xml, Enctype)
:: (RenderMessage (HandlerSite env) FormMessage, HasHandlerData env)
=> (Html -> MForm (HandlerSite env) (FormResult a, xml))
-> RIO env (xml, Enctype)
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
req <- getRequest
if requestMethod (reqWaiRequest req) == "GET"
@ -314,18 +337,16 @@ postEnv = do
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)
runFormPostNoToken :: MonadHandler m
=> (Html -> MForm m a)
-> m (a, Enctype)
runFormPostNoToken :: HasHandlerData env
=> (Html -> MForm (HandlerSite env) a)
-> RIO env (a, Enctype)
runFormPostNoToken form = do
langs <- languages
m <- getYesod
env <- postEnv
runFormGeneric (form mempty) m langs env
params <- postEnv
runFormGeneric (form mempty) params
runFormGet :: MonadHandler m
=> (Html -> MForm m a)
-> m (a, Enctype)
runFormGet :: HasHandlerData env
=> (Html -> MForm (HandlerSite env) a)
-> RIO env (a, Enctype)
runFormGet form = do
gets <- liftM reqGetParams getRequest
let env =
@ -339,29 +360,27 @@ runFormGet form = do
--
-- Since 1.3.11
generateFormGet'
:: MonadHandler m
=> (Html -> MForm m (FormResult a, xml))
-> m (xml, Enctype)
:: HasHandlerData env
=> (Html -> MForm (HandlerSite env) (FormResult a, xml))
-> RIO env (xml, Enctype)
generateFormGet' form = first snd `liftM` getHelper form Nothing
{-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-}
generateFormGet :: MonadHandler m
=> (Html -> MForm m a)
-> m (a, Enctype)
generateFormGet :: HasHandlerData env
=> (Html -> MForm (HandlerSite env) a)
-> RIO env (a, Enctype)
generateFormGet form = getHelper form Nothing
getKey :: Text
getKey = "_hasdata"
getHelper :: MonadHandler m
=> (Html -> MForm m a)
getHelper :: HasHandlerData env
=> (Html -> MForm (HandlerSite env) a)
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
getHelper form env = do
-> RIO env (a, Enctype)
getHelper form params = do
let fragment = [shamlet|<input type=hidden name=#{getKey}>|]
langs <- languages
m <- getYesod
runFormGeneric (form fragment) m langs env
runFormGeneric (form fragment) params
-- | 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
-- generation and the form submission.
identifyForm
:: Monad m
=> Text -- ^ Form identification string.
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
:: Text -- ^ Form identification string.
-> (Html -> MForm site (FormResult a, WidgetFor site ()))
-> (Html -> MForm site (FormResult a, WidgetFor site ()))
identifyForm identVal form = \fragment -> do
-- Create hidden <input>.
let fragment' =
@ -406,7 +424,7 @@ identifyForm identVal form = \fragment -> do
-- data is missing, then do not provide any params to the
-- form, which will turn its result into FormMissing. Also,
-- 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
( res', w) <- eraseParams (form fragment')
@ -418,12 +436,12 @@ identifyFormKey :: Text
identifyFormKey = "_formid"
type FormRender m a =
AForm m a
type FormRender site a =
AForm site a
-> 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
-- 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.
@ -457,7 +475,7 @@ renderDivs = renderDivsMaybeLabels True
-- | render a field inside a div, not displaying any label
renderDivsNoLabels = renderDivsMaybeLabels False
renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a
renderDivsMaybeLabels :: Bool -> FormRender env a
renderDivsMaybeLabels withLabels aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
@ -495,7 +513,7 @@ $forall view <- views
-- > <input .btn .primary type=submit value=_{MsgSubmit}>
--
-- Since 1.3.14
renderBootstrap2 :: Monad m => FormRender m a
renderBootstrap2 :: FormRender env a
renderBootstrap2 aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
@ -516,26 +534,21 @@ renderBootstrap2 aform fragment = do
|]
return (res, widget)
-- | Deprecated synonym for 'renderBootstrap2'.
renderBootstrap :: Monad m => FormRender m a
renderBootstrap = renderBootstrap2
{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}
check :: (Monad m, RenderMessage (HandlerSite m) msg)
check :: RenderMessage site msg
=> (a -> Either msg a)
-> Field m a
-> Field m a
-> Field site a
-> Field site a
check f = checkM $ return . f
-- | Return the given error message if the predicate is false.
checkBool :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> Bool) -> msg -> Field m a -> Field m a
checkBool :: RenderMessage site msg
=> (a -> Bool) -> msg -> Field site a -> Field site a
checkBool b s = check $ \x -> if b x then Right x else Left s
checkM :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> m (Either msg a))
-> Field m a
-> Field m a
checkM :: RenderMessage site msg
=> (a -> HandlerFor site (Either msg a))
-> Field site a
-> Field site a
checkM f = checkMMap f id
-- | 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).
--
-- Since 1.1.2
checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> m (Either msg b))
checkMMap :: RenderMessage site msg
=> (a -> HandlerFor site (Either msg b))
-> (b -> a)
-> Field m a
-> Field m b
-> Field site a
-> Field site b
checkMMap f inv field = field
{ fieldParse = \ts fs -> do
e1 <- fieldParse field ts fs
@ -560,7 +573,7 @@ checkMMap f inv field = field
}
-- | 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
{ fieldParse = \ts fs ->
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
--
-- Since 1.3.16
convertField :: (Functor m)
=> (a -> b) -> (b -> a)
-> Field m a -> Field m b
convertField to from (Field fParse fView fEnctype) = let
fParse' ts = fmap (fmap (fmap to)) . fParse ts
convertField :: (a -> b) -> (b -> a)
-> Field env a -> Field env b
convertField to' from (Field fParse fView fEnctype) = let
fParse' ts = fmap (fmap (fmap to')) . fParse ts
fView' ti tn at ei = fView ti tn at (fmap from ei)
in Field fParse' fView' fEnctype

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

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
-- | 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@
-- (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) }
instance Monad m => Functor (FormInput m) where
fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e'
instance Monad m => Control.Applicative.Applicative (FormInput m) where
pure = FormInput . const . const . const . const . return . Right
(FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do
res1 <- f c d e e'
res2 <- x c d e e'
newtype FormInput site a = FormInput { unFormInput :: Env -> FileEnv -> HandlerFor site (Either DText a) }
deriving Functor
instance Control.Applicative.Applicative (FormInput site) where
pure x = FormInput $ \_env _filenv -> pure $ Right x
(FormInput f) <*> (FormInput x) = FormInput $ \env fileEnv -> do
res1 <- f env fileEnv
res2 <- x env fileEnv
return $ case (res1, res2) of
(Left a, Left b) -> Left $ a . b
(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
-- and valid.
ireq :: (Monad m, RenderMessage (HandlerSite m) FormMessage)
=> Field m a
ireq :: RenderMessage site FormMessage
=> Field site a
-> Text -- ^ name of the field
-> FormInput m a
ireq field name = FormInput $ \m l env fenv -> do
-> FormInput site a
ireq field name = FormInput $ \env fenv -> do
let filteredEnv = fromMaybe [] $ Map.lookup name env
filteredFEnv = fromMaybe [] $ Map.lookup name fenv
emx <- fieldParse field filteredEnv filteredFEnv
m <- getYesod
l <- reqLangs <$> getRequest
return $ case emx of
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
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
-- 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 name = FormInput $ \m l env fenv -> do
iopt :: Field site a -> Text -> FormInput site (Maybe a)
iopt field name = FormInput $ \env fenv -> do
let filteredEnv = fromMaybe [] $ Map.lookup name env
filteredFEnv = fromMaybe [] $ Map.lookup name fenv
emx <- fieldParse field filteredEnv filteredFEnv
return $ case emx of
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
Right x -> Right x
case emx of
Left (SomeMessage e) -> do
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
-- 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
-- | Run a @FormInput@ on the GET parameters (i.e., query string). Does /not/
-- throw exceptions on failure.
--
-- 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
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
env <- liftM (toMap . reqGetParams) getRequest
m <- getYesod
l <- languages
emx <- f m l env Map.empty
emx <- liftHandler $ f env Map.empty
return $ either (Left . ($ [])) Right emx
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
-- 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
-- | Run a @FormInput@ on the POST parameters (i.e., request body). Does /not/
-- 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
runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
runInputPostHelper (FormInput f) = do
runInputPostHelper :: HasHandlerData env => FormInput (HandlerSite env) a -> RIO env (Either [Text] a)
runInputPostHelper (FormInput f) = liftHandler $ do
(env, fenv) <- liftM (toMap *** toMap) runRequestBody
m <- getYesod
l <- languages
fmap (either (Left . ($ [])) Right) $ f m l env fenv
fmap (either (Left . ($ [])) Right) $ f 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 _ = 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"
-- | Use jQuery's datepicker as the underlying implementation.
--
-- 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"
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
{ fieldParse = parseHelper $ maybe
(Left MsgInvalidDay)
@ -107,13 +107,13 @@ $(function(){
]
jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
=> Route site -> Field (HandlerFor site) Text
=> Route site -> Field site Text
jqueryAutocompleteField = jqueryAutocompleteField' 2
jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)
=> Int -- ^ autocomplete minimum length
-> Route site
-> Field (HandlerFor site) Text
-> Field site Text
jqueryAutocompleteField' minLen src = Field
{ fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> do
@ -130,14 +130,14 @@ $(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:#{toJS
, 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
y <- getYesod
addScriptEither $ f y
addStylesheet' :: (MonadWidget m, HandlerSite m ~ site)
addStylesheet' :: (HasWidgetData env, HandlerSite env ~ site)
=> (site -> Either (Route site) Text)
-> m ()
-> RIO env ()
addStylesheet' f = do
y <- getYesod
addStylesheetEither $ f y

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

@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
@ -11,11 +12,11 @@ module Yesod.Form.MassInput
, massTable
) where
import RIO
import Yesod.Form.Types
import Yesod.Form.Functions
import Yesod.Form.Fields (checkBoxField)
import Yesod.Core
import Control.Monad.Trans.RWS (get, put, ask)
import Data.Maybe (fromMaybe)
import Data.Text.Read (decimal)
import Control.Monad (liftM)
@ -24,43 +25,45 @@ import Data.Traversable (sequenceA)
import qualified Data.Map as Map
import Data.Maybe (listToMaybe)
down :: Monad m => Int -> MForm m ()
down :: Int -> MForm site ()
down 0 = return ()
down i | i < 0 = error "called down with a negative number"
down i = do
is <- get
put $ IntCons 0 is
ref <- view $ to mfdInts
is <- readIORef ref
writeIORef ref $ IntCons 0 is
down $ i - 1
up :: Monad m => Int -> MForm m ()
up :: Int -> MForm site ()
up 0 = return ()
up i | i < 0 = error "called down with a negative number"
up i = do
is <- get
ref <- view $ to mfdInts
is <- readIORef ref
case is of
IntSingle _ -> error "up on IntSingle"
IntCons _ is' -> put is' >> newFormIdent >> return ()
IntCons _ is' -> writeIORef ref is' >> newFormIdent >> return ()
up $ i - 1
-- | Generate a form that accepts 0 or more values from the user, allowing the
-- user to specify that a new row is necessary.
inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
inputList :: RenderMessage site FormMessage
=> Html
-- ^ label for the form
-> ([[FieldView site]] -> xml)
-> ([[FieldView site]] -> WidgetFor site ())
-- ^ 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
-- previously submitted value
-> Maybe [a]
-- ^ default initial values for the form
-> AForm (HandlerFor site) [a]
-> AForm site [a]
inputList label fixXml single mdef = formToAForm $ do
theId <- lift newIdent
theId <- newIdent
down 1
countName <- newFormIdent
addName <- newFormIdent
(menv, _, _) <- ask
menv <- view $ to mfdParams
let readInt t =
case decimal t of
Right (i, "") -> Just i
@ -94,13 +97,13 @@ $newline never
, fvRequired = False
}])
withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
=> AForm (HandlerFor site) a
-> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
withDelete :: RenderMessage site FormMessage
=> AForm site a
-> MForm site (Either (WidgetFor site ())(FormResult a, [FieldView site]))
withDelete af = do
down 1
deleteName <- newFormIdent
(menv, _, _) <- ask
menv <- view $ to mfdParams
res <- case menv >>= Map.lookup deleteName . fst of
Just ("yes":_) -> return $ Left [whamlet|
$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 _ = Right "http://js.nicedit.com/nicEdit-latest.js"
nicHtmlField :: YesodNic site => Field (HandlerFor site) Html
nicHtmlField :: YesodNic site => Field site Html
nicHtmlField = Field
{ fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
, fieldView = \theId name attrs val _isReq -> do
@ -52,9 +52,9 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{ra
where
showVal = either id (pack . renderHtml)
addScript' :: (MonadWidget m, HandlerSite m ~ site)
addScript' :: (HasWidgetData env, HandlerSite env ~ site)
=> (site -> Either (Route site) Text)
-> m ()
-> RIO env ()
addScript' f = do
y <- getYesod
addScriptEither $ f y

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

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

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

@ -30,7 +30,7 @@ library
, containers >= 0.2
, data-default
, email-validate >= 1.0
, persistent
, persistent >= 2.5
, resourcet
, semigroups
, shakespeare >= 2.0
@ -41,6 +41,8 @@ library
, xss-sanitize >= 0.3.0.1
, yesod-core >= 1.6 && < 1.7
, yesod-persistent >= 1.6 && < 1.7
, rio
, rio-orphans
if flag(network-uri)
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
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
render <- getUrlRender
return $ RepAtom $ toContent $ renderLBS def $ template feed render
-- | Same as @'atomFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- 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
template :: Feed url -> (url -> Text) -> Document
@ -90,10 +90,10 @@ entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElemen
,("href", render enclosedUrl)]) []]
-- | Generates a link tag in the head of a widget.
atomLink :: MonadWidget m
=> Route (HandlerSite m)
atomLink :: HasWidgetData env
=> Route (HandlerSite env)
-> Text -- ^ title
-> m ()
-> RIO env ()
atomLink r title = toWidgetHead [hamlet|
<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
newsFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m TypedContent
newsFeed :: HasHandlerData env => Feed (Route (HandlerSite env)) -> RIO env TypedContent
newsFeed f = selectRep $ do
provideRep $ atomFeed f
provideRep $ rssFeed f
-- | Same as @'newsFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- 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
provideRep $ atomFeedText f
provideRep $ rssFeedText f

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

@ -39,14 +39,14 @@ instance ToTypedContent RepRss where
toTypedContent = TypedContent typeRss . toContent
-- | 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
render <- getUrlRender
return $ RepRss $ toContent $ renderLBS def $ template feed render
-- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- 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
template :: Feed url -> (url -> Text) -> Document
@ -93,10 +93,10 @@ entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
,("url", render enclosedUrl)]) []]
-- | Generates a link tag in the head of a widget.
rssLink :: MonadWidget m
=> Route (HandlerSite m)
rssLink :: HasWidgetData env
=> Route (HandlerSite env)
-> Text -- ^ title
-> m ()
-> RIO env ()
rssLink r title = toWidgetHead [hamlet|
<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.
robots :: MonadHandler m
=> Route (HandlerSite m) -- ^ sitemap url
-> m Text
robots :: HasHandlerData env
=> Route (HandlerSite env) -- ^ sitemap url
-> RIO env Text
robots smurl = do
ur <- getUrlRender
return $ T.unlines

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

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

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

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