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

MonadHandler/MonadWidget

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-17 10:10:39 +02:00
parent 1fabee31e4
commit a2c4f1f3b7
19 changed files with 211 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
yesod-core/Yesod/Core.hs
View File

@ -48,9 +48,8 @@ module Yesod.Core
, ScriptLoadPosition (..)
, BottomOfHeadAsync
-- * Subsites
, HandlerReader (..)
, HandlerState (..)
, HandlerError (..)
, MonadHandler (..)
, MonadWidget (..)
, getRouteToParent
-- * Misc
, yesodVersion
@ -89,7 +88,7 @@ import Data.Version (showVersion)
import Yesod.Routes.Class (RenderRoute (..))
-- | Return an 'Unauthorized' value, with the given i18n message.
unauthorizedI :: (Monad m, RenderMessage site msg) => msg -> HandlerT site m AuthResult
unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
unauthorizedI msg = do
mr <- getMessageRender
return $ Unauthorized $ mr msg

68
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -1,60 +1,48 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Class.Handler where
module Yesod.Core.Class.Handler
( MonadHandler (..)
, MonadWidget (..)
) where
import Yesod.Core.Types
import Data.IORef.Lifted (atomicModifyIORef)
import Control.Exception.Lifted (throwIO)
import Control.Monad.Base
import Data.Monoid (mempty)
import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase, ExceptionT (..))
import Control.Monad.Trans.Class (lift)
class Monad m => HandlerReader m where
class MonadResource m => MonadHandler m where
type HandlerSite m
liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a
askYesodRequest :: m YesodRequest
askHandlerEnv :: m (RunHandlerEnv (HandlerSite m))
replaceToParent :: HandlerData site route -> HandlerData site ()
replaceToParent hd = hd { handlerToParent = const () }
instance Monad m => HandlerReader (HandlerT site m) where
instance MonadResourceBase m => MonadHandler (HandlerT site m) where
type HandlerSite (HandlerT site m) = site
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-}
askYesodRequest = HandlerT $ return . handlerRequest
askHandlerEnv = HandlerT $ return . handlerEnv
instance Monad m => HandlerReader (WidgetT site m) where
instance MonadResourceBase m => MonadHandler (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
askYesodRequest = WidgetT $ return . (, mempty) . handlerRequest
askHandlerEnv = WidgetT $ return . (, mempty) . handlerEnv
instance MonadHandler m => MonadHandler (ExceptionT m) where
type HandlerSite (ExceptionT m) = HandlerSite m
liftHandlerT = lift . liftHandlerT
-- FIXME add a bunch of transformer instances
class HandlerReader m => HandlerState m where
stateGHState :: (GHState -> (a, GHState)) -> m a
getGHState :: m GHState
getGHState = stateGHState $ \s -> (s, s)
putGHState :: GHState -> m ()
putGHState s = stateGHState $ const ((), s)
instance MonadBase IO m => HandlerState (HandlerT site m) where
stateGHState f =
HandlerT $ flip atomicModifyIORef f' . handlerState
where
f' z = let (x, y) = f z in (y, x)
instance MonadBase IO m => HandlerState (WidgetT site m) where
stateGHState f =
WidgetT $ fmap (, mempty) . flip atomicModifyIORef f' . handlerState
where
f' z = let (x, y) = f z in (y, x)
class HandlerReader m => HandlerError m where
handlerError :: HandlerContents -> m a
instance MonadBase IO m => HandlerError (HandlerT site m) where
handlerError = throwIO
instance MonadBase IO m => HandlerError (WidgetT site m) where
handlerError = throwIO
class MonadHandler m => MonadWidget m where
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
instance MonadResourceBase m => MonadWidget (WidgetT site m) where
liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
-- FIXME add a bunch of transformer instances

2
yesod-core/Yesod/Core/Content.hs
View File

@ -244,6 +244,8 @@ instance ToTypedContent Html where
toTypedContent h = TypedContent typeHtml (toContent h)
instance ToTypedContent T.Text where
toTypedContent t = TypedContent typePlain (toContent t)
instance ToTypedContent [Char] where
toTypedContent = toTypedContent . pack
instance ToTypedContent Text where
toTypedContent t = TypedContent typePlain (toContent t)
instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where

3
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -114,9 +114,8 @@ mkYesodGeneral name args clazzes isSub resS = do
return (renderRouteDec ++ masterTypeSyns, dispatchDec)
where sub = foldl appT subCons subArgs
master = if isSub then (varT $ mkName "m") else sub
context = if isSub then cxt $ yesod : map return clazzes
context = if isSub then cxt $ map return clazzes
else return []
yesod = classP ''HandlerReader [master]
handler = tySynD (mkName "Handler") [] [t| HandlerT $master IO |]
widget = tySynD (mkName "Widget") [] [t| WidgetT $master IO () |]
res = map (fmap parseType) resS

165
yesod-core/Yesod/Core/Handler.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
@ -165,36 +166,41 @@ import Text.Blaze.Html (preEscapedToMarkup, toHtml)
import Control.Monad.Trans.Resource (ResourceT)
import Data.Dynamic (fromDynamic, toDyn)
import qualified Data.IORef as I
import qualified Data.IORef.Lifted as I
import Data.Maybe (listToMaybe)
import Data.Typeable (Typeable, typeOf)
import Yesod.Core.Class.Handler
import Yesod.Core.Types
import Yesod.Routes.Class (Route)
import Control.Failure (failure)
get :: HandlerState m => m GHState
get = getGHState
get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
put :: HandlerState m => GHState -> m ()
put = putGHState
put :: MonadHandler m => GHState -> m ()
put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState
modify :: HandlerState m => (GHState -> GHState) -> m ()
modify = stateGHState . (((), ) .)
modify :: MonadHandler m => (GHState -> GHState) -> m ()
modify f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState
tell :: HandlerState m => Endo [Header] -> m ()
tell :: MonadHandler m => Endo [Header] -> m ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
hcError :: HandlerError m => ErrorResponse -> m a
handlerError :: MonadHandler m => HandlerContents -> m a
handlerError = liftHandlerT . failure
hcError :: MonadHandler m => ErrorResponse -> m a
hcError = handlerError . HCError
getRequest :: HandlerReader m => m YesodRequest
getRequest = askYesodRequest
getRequest :: MonadHandler m => m YesodRequest
getRequest = liftHandlerT $ HandlerT $ return . handlerRequest
runRequestBody :: (MonadResource m, HandlerReader m, HandlerState m)
=> m RequestBodyContents
runRequestBody :: MonadHandler m => m RequestBodyContents
runRequestBody = do
RunHandlerEnv {..} <- askHandlerEnv
req <- askYesodRequest
HandlerData
{ handlerEnv = RunHandlerEnv {..}
, handlerRequest = req
} <- liftHandlerT $ HandlerT return
let len = W.requestBodyLength $ reqWaiRequest req
upload = rheUpload len
x <- get
@ -232,25 +238,28 @@ rbHelper' backend mkFI req =
| otherwise = a'
go = decodeUtf8With lenientDecode
askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))
askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv
-- | Get the master site appliation argument.
getYesod :: HandlerReader m => m (HandlerSite m)
getYesod :: MonadHandler m => m (HandlerSite m)
getYesod = rheSite `liftM` askHandlerEnv
-- | Get the URL rendering function.
getUrlRender :: HandlerReader m => m (Route (HandlerSite m) -> Text)
getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)
getUrlRender = do
x <- rheRender `liftM` askHandlerEnv
return $ flip x []
-- | The URL rendering function with query-string parameters.
getUrlRenderParams
:: HandlerReader m
:: MonadHandler m
=> m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams = rheRender `liftM` askHandlerEnv
-- | Get the route requested by the user. If this is a 404 response- where the
-- user requested an invalid route- this function will return 'Nothing'.
getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSite m)))
getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
getCurrentRoute = rheRoute `liftM` askHandlerEnv
-- | Returns a function that runs 'HandlerT' actions inside @IO@.
@ -332,7 +341,7 @@ handlerToIO =
--
-- If you want direct control of the final status code, or need a different
-- status code, please use 'redirectWith'.
redirect :: (HandlerError m, RedirectUrl (HandlerSite m) url, HandlerReader m)
redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
=> url -> m a
redirect url = do
req <- waiRequest
@ -343,7 +352,7 @@ redirect url = do
redirectWith status url
-- | Redirect to the given URL with the specified status code.
redirectWith :: (HandlerError m, RedirectUrl (HandlerSite m) url, HandlerReader m)
redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
=> H.Status
-> url
-> m a
@ -358,7 +367,7 @@ ultDestKey = "_ULT"
--
-- An ultimate destination is stored in the user session and can be loaded
-- later by 'redirectUltDest'.
setUltDest :: (HandlerState m, RedirectUrl (HandlerSite m) url)
setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
=> url
-> m ()
setUltDest url = do
@ -369,19 +378,19 @@ setUltDest url = do
--
-- If this is a 404 handler, there is no current page, and then this call does
-- nothing.
setUltDestCurrent :: HandlerState m => m ()
setUltDestCurrent :: MonadHandler m => m ()
setUltDestCurrent = do
route <- getCurrentRoute
case route of
Nothing -> return ()
Just r -> do
gets' <- reqGetParams `liftM` askYesodRequest
gets' <- reqGetParams `liftM` getRequest
setUltDest (r, gets')
-- | Sets the ultimate destination to the referer request header, if present.
--
-- This function will not overwrite an existing ultdest.
setUltDestReferer :: HandlerState m => m ()
setUltDestReferer :: MonadHandler m => m ()
setUltDestReferer = do
mdest <- lookupSession ultDestKey
maybe
@ -398,7 +407,7 @@ setUltDestReferer = do
--
-- This function uses 'redirect', and thus will perform a temporary redirect to
-- a GET request.
redirectUltDest :: (RedirectUrl (HandlerSite m) url, HandlerState m, HandlerError m)
redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m)
=> url -- ^ default destination if nothing in session
-> m a
redirectUltDest def = do
@ -407,7 +416,7 @@ redirectUltDest def = do
maybe (redirect def) redirect mdest
-- | Remove a previously set ultimate destination. See 'setUltDest'.
clearUltDest :: HandlerState m => m ()
clearUltDest :: MonadHandler m => m ()
clearUltDest = deleteSession ultDestKey
msgKey :: Text
@ -416,13 +425,13 @@ msgKey = "_MSG"
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
setMessage :: HandlerState m => Html -> m ()
setMessage :: MonadHandler m => Html -> m ()
setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
setMessageI :: (HandlerState m, RenderMessage (HandlerSite m) msg)
setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
=> msg -> m ()
setMessageI msg = do
mr <- getMessageRender
@ -432,7 +441,7 @@ setMessageI msg = do
-- variable.
--
-- See 'setMessage'.
getMessage :: HandlerState m => m (Maybe Html)
getMessage :: MonadHandler m => m (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey
deleteSession msgKey
@ -442,11 +451,11 @@ getMessage = do
--
-- For some backends, this is more efficient than reading in the file to
-- memory, since they can optimize file sending via a system call to sendfile.
sendFile :: HandlerError m => ContentType -> FilePath -> m a
sendFile :: MonadHandler m => ContentType -> FilePath -> m a
sendFile ct fp = handlerError $ HCSendFile ct fp Nothing
-- | Same as 'sendFile', but only sends part of a file.
sendFilePart :: HandlerError m
sendFilePart :: MonadHandler m
=> ContentType
-> FilePath
-> Integer -- ^ offset
@ -457,17 +466,17 @@ sendFilePart ct fp off count =
-- | Bypass remaining handler code and output the given content with a 200
-- status code.
sendResponse :: (HandlerError m, ToTypedContent c) => c -> m a
sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a
sendResponse = handlerError . HCContent H.status200 . toTypedContent
-- | Bypass remaining handler code and output the given content with the given
-- status code.
sendResponseStatus :: (HandlerError m, ToTypedContent c) => H.Status -> c -> m a
sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a
sendResponseStatus s = handlerError . HCContent s . toTypedContent
-- | Send a 201 "Created" response with the given route as the Location
-- response header.
sendResponseCreated :: HandlerError m => Route (HandlerSite m) -> m a
sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a
sendResponseCreated url = do
r <- getUrlRender
handlerError $ HCCreated $ r url
@ -477,25 +486,25 @@ sendResponseCreated url = do
-- that you have already specified. This function short-circuits. It should be
-- considered only for very specific needs. If you are not sure if you need it,
-- you don't.
sendWaiResponse :: HandlerError m => W.Response -> m b
sendWaiResponse :: MonadHandler m => W.Response -> m b
sendWaiResponse = handlerError . HCWai
-- | Return a 404 not found page. Also denotes no handler available.
notFound :: HandlerError m => m a
notFound :: MonadHandler m => m a
notFound = hcError NotFound
-- | Return a 405 method not supported page.
badMethod :: HandlerError m => m a
badMethod :: MonadHandler m => m a
badMethod = do
w <- waiRequest
hcError $ BadMethod $ W.requestMethod w
-- | Return a 403 permission denied page.
permissionDenied :: HandlerError m => Text -> m a
permissionDenied :: MonadHandler m => Text -> m a
permissionDenied = hcError . PermissionDenied
-- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, HandlerError m)
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
=> msg
-> m a
permissionDeniedI msg = do
@ -503,11 +512,11 @@ permissionDeniedI msg = do
permissionDenied $ mr msg
-- | Return a 400 invalid arguments page.
invalidArgs :: HandlerError m => [Text] -> m a
invalidArgs :: MonadHandler m => [Text] -> m a
invalidArgs = hcError . InvalidArgs
-- | Return a 400 invalid arguments page.
invalidArgsI :: (HandlerError m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
invalidArgsI msg = do
mr <- getMessageRender
invalidArgs $ map mr msg
@ -515,7 +524,7 @@ invalidArgsI msg = do
------- Headers
-- | Set the cookie on the client.
setCookie :: HandlerState m => SetCookie -> m ()
setCookie :: MonadHandler m => SetCookie -> m ()
setCookie = addHeader . AddCookie
-- | Helper function for setCookieExpires value
@ -531,7 +540,7 @@ getExpires m = do
--
-- Note: although the value used for key and path is 'Text', you should only
-- use ASCII values to be HTTP compliant.
deleteCookie :: HandlerState m
deleteCookie :: MonadHandler m
=> Text -- ^ key
-> Text -- ^ path
-> m ()
@ -540,19 +549,19 @@ deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8
-- | Set the language in the user session. Will show up in 'languages' on the
-- next request.
setLanguage :: HandlerState m => Text -> m ()
setLanguage :: MonadHandler m => Text -> m ()
setLanguage = setSession langKey
-- | Set an arbitrary response header.
--
-- Note that, while the data type used here is 'Text', you must provide only
-- ASCII value to be HTTP compliant.
setHeader :: HandlerState m => Text -> Text -> m ()
setHeader :: MonadHandler m => Text -> Text -> m ()
setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
-- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds.
cacheSeconds :: HandlerState m => Int -> m ()
cacheSeconds :: MonadHandler m => Int -> m ()
cacheSeconds i = setHeader "Cache-Control" $ T.concat
[ "max-age="
, T.pack $ show i
@ -561,16 +570,16 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
-- | Set the Expires header to some date in 2037. In other words, this content
-- is never (realistically) expired.
neverExpires :: HandlerState m => m ()
neverExpires :: MonadHandler m => m ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
-- | Set an Expires header in the past, meaning this content should not be
-- cached.
alreadyExpired :: HandlerState m => m ()
alreadyExpired :: MonadHandler m => m ()
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date.
expiresAt :: HandlerState m => UTCTime -> m ()
expiresAt :: MonadHandler m => UTCTime -> m ()
expiresAt = setHeader "Expires" . formatRFC1123
-- | Set a variable in the user's session.
@ -578,40 +587,40 @@ expiresAt = setHeader "Expires" . formatRFC1123
-- The session is handled by the clientsession package: it sets an encrypted
-- and hashed cookie on the client. This ensures that all data is secure and
-- not tampered with.
setSession :: HandlerState m
setSession :: MonadHandler m
=> Text -- ^ key
-> Text -- ^ value
-> m ()
setSession k = setSessionBS k . encodeUtf8
-- | Same as 'setSession', but uses binary data for the value.
setSessionBS :: HandlerState m
setSessionBS :: MonadHandler m
=> Text
-> S.ByteString
-> m ()
setSessionBS k = modify . modSession . Map.insert k
-- | Unsets a session variable. See 'setSession'.
deleteSession :: HandlerState m => Text -> m ()
deleteSession :: MonadHandler m => Text -> m ()
deleteSession = modify . modSession . Map.delete
-- | Clear all session variables.
--
-- Since: 1.0.1
clearSession :: HandlerState m => m ()
clearSession :: MonadHandler m => m ()
clearSession = modify $ \x -> x { ghsSession = Map.empty }
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x }
-- | Internal use only, not to be confused with 'setHeader'.
addHeader :: HandlerState m => Header -> m ()
addHeader :: MonadHandler m => Header -> m ()
addHeader = tell . Endo . (:)
-- | Some value which can be turned into a URL for redirects.
class RedirectUrl master a where
-- | Converts the value to the URL and a list of query-string parameters.
toTextUrl :: (HandlerReader m, HandlerSite m ~ master) => a -> m Text
toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text
instance RedirectUrl master Text where
toTextUrl = return
@ -633,21 +642,21 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k
toTextUrl (url, params) = toTextUrl (url, Map.toList params)
-- | Lookup for session data.
lookupSession :: HandlerState m => Text -> m (Maybe Text)
lookupSession :: MonadHandler m => Text -> m (Maybe Text)
lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
-- | Lookup for session data in binary format.
lookupSessionBS :: HandlerState m => Text -> m (Maybe S.ByteString)
lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)
lookupSessionBS n = do
m <- liftM ghsSession get
return $ Map.lookup n m
-- | Get all session variables.
getSession :: HandlerState m => m SessionMap
getSession :: MonadHandler m => m SessionMap
getSession = liftM ghsSession get
-- | Get a unique identifier.
newIdent :: HandlerState m => m Text
newIdent :: MonadHandler m => m Text
newIdent = do
x <- get
let i' = ghsIdent x + 1
@ -660,7 +669,7 @@ newIdent = do
-- POST form, and some Javascript to automatically submit the form. This can be
-- useful when you need to post a plain link somewhere that needs to cause
-- changes on the server.
redirectToPost :: (HandlerError m, RedirectUrl (HandlerSite m) url)
redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
=> url
-> m a
redirectToPost url = do
@ -680,14 +689,14 @@ $doctype 5
|] >>= sendResponse
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerSite m)) -> m Html
hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html
hamletToRepHtml = giveUrlRenderer
-- | Provide a URL rendering function to the given function and return the
-- result. Useful for processing Shakespearean templates.
--
-- Since 1.2.0
giveUrlRenderer :: HandlerReader m
giveUrlRenderer :: MonadHandler m
=> ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
giveUrlRenderer f = do
@ -695,10 +704,10 @@ giveUrlRenderer f = do
return $ f render
-- | Get the request\'s 'W.Request' value.
waiRequest :: HandlerReader m => m W.Request
waiRequest :: MonadHandler m => m W.Request
waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (HandlerReader m, RenderMessage (HandlerSite m) message)
getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
=> m (message -> Text)
getMessageRender = do
env <- askHandlerEnv
@ -710,7 +719,7 @@ getMessageRender = do
-- newtype wrappers to distinguish logically different types.
--
-- Since 1.2.0
cached :: (HandlerState m, Typeable a)
cached :: (MonadHandler m, Typeable a)
=> m a
-> m a
cached f = do
@ -751,41 +760,41 @@ cached f = do
-- If a matching language is not found the default language will be used.
--
-- This is handled by parseWaiRequest (not exposed).
languages :: HandlerReader m => m [Text]
languages :: MonadHandler m => m [Text]
languages = reqLangs `liftM` getRequest
lookup' :: Eq a => a -> [(a, b)] -> [b]
lookup' a = map snd . filter (\x -> a == fst x)
-- | Lookup for GET parameters.
lookupGetParams :: HandlerReader m => Text -> m [Text]
lookupGetParams :: MonadHandler m => Text -> m [Text]
lookupGetParams pn = do
rr <- getRequest
return $ lookup' pn $ reqGetParams rr
-- | Lookup for GET parameters.
lookupGetParam :: HandlerReader m => Text -> m (Maybe Text)
lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)
lookupGetParam = liftM listToMaybe . lookupGetParams
-- | Lookup for POST parameters.
lookupPostParams :: (MonadResource m, HandlerState m) => Text -> m [Text]
lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]
lookupPostParams pn = do
(pp, _) <- runRequestBody
return $ lookup' pn pp
lookupPostParam :: (MonadResource m, HandlerState m)
lookupPostParam :: (MonadResource m, MonadHandler m)
=> Text
-> m (Maybe Text)
lookupPostParam = liftM listToMaybe . lookupPostParams
-- | Lookup for POSTed files.
lookupFile :: (HandlerState m, MonadResource m)
lookupFile :: (MonadHandler m, MonadResource m)
=> Text
-> m (Maybe FileInfo)
lookupFile = liftM listToMaybe . lookupFiles
-- | Lookup for POSTed files.
lookupFiles :: (HandlerState m, MonadResource m)
lookupFiles :: (MonadHandler m, MonadResource m)
=> Text
-> m [FileInfo]
lookupFiles pn = do
@ -793,11 +802,11 @@ lookupFiles pn = do
return $ lookup' pn files
-- | Lookup for cookie data.
lookupCookie :: HandlerReader m => Text -> m (Maybe Text)
lookupCookie :: MonadHandler m => Text -> m (Maybe Text)
lookupCookie = liftM listToMaybe . lookupCookies
-- | Lookup for cookie data.
lookupCookies :: HandlerReader m => Text -> m [Text]
lookupCookies :: MonadHandler m => Text -> m [Text]
lookupCookies pn = do
rr <- getRequest
return $ lookup' pn $ reqCookies rr
@ -823,11 +832,11 @@ lookupCookies pn = do
-- provided inside this do-block. Should be used together with 'provideRep'.
--
-- Since 1.2.0
selectRep :: HandlerReader m
selectRep :: MonadHandler m
=> Writer.Writer (Endo [ProvidedRep m]) ()
-> m TypedContent
selectRep w = do
cts <- liftM reqAccept askYesodRequest
cts <- liftM reqAccept getRequest
case mapMaybe tryAccept cts of
[] ->
case reps of
@ -885,7 +894,7 @@ provideRepType ct handler =
-- | Stream in the raw request body without any parsing.
--
-- Since 1.2.0
rawRequestBody :: (HandlerReader m, MonadResource m) => Source m S.ByteString
rawRequestBody :: (MonadHandler m, MonadResource m) => Source m S.ByteString
rawRequestBody = do
req <- lift waiRequest
transPipe liftResourceT $ W.requestBody req

24
yesod-core/Yesod/Core/Json.hs
View File

@ -20,8 +20,9 @@ module Yesod.Core.Json
, acceptsJson
) where
import Yesod.Core.Handler (HandlerT, waiRequest, invalidArgs, redirect, selectRep, provideRep)
import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Types (reqAccept)
import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT)
@ -67,19 +68,16 @@ jsonToRepJson = return . J.toJSON
-- 'J.Value'@.
--
-- /Since: 0.3.0/
parseJsonBody :: (MonadResource m, HandlerReader m, J.FromJSON a) => m (J.Result a)
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
req <- waiRequest
eValue <- runExceptionT
$ transPipe liftResourceT (requestBody req)
$$ sinkParser JP.value'
eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
return $ case eValue of
Left e -> J.Error $ show e
Right value -> J.fromJSON value
-- | Same as 'parseJsonBody', but return an invalid args response on a parse
-- error.
parseJsonBody_ :: (HandlerError m, J.FromJSON a, MonadResource m) => m a
parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
parseJsonBody_ = do
ra <- parseJsonBody
case ra of
@ -97,8 +95,7 @@ array = J.Array . V.fromList . map J.toJSON
-- @application\/json@ (e.g. AJAX, see 'acceptsJSON').
--
-- 2. 3xx otherwise, following the PRG pattern.
jsonOrRedirect :: HandlerError m
=> J.ToJSON a
jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
=> Route (HandlerSite m) -- ^ Redirect target
-> a -- ^ Data to send via JSON
-> m J.Value
@ -109,9 +106,8 @@ jsonOrRedirect r j = do
-- | Returns @True@ if the client prefers @application\/json@ as
-- indicated by the @Accept@ HTTP header.
acceptsJson :: HandlerReader m => m Bool
acceptsJson :: MonadHandler m => m Bool
acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
. join
. liftM (listToMaybe . parseHttpAccept)
. lookup "Accept" . requestHeaders)
`liftM` waiRequest
. listToMaybe
. reqAccept)
`liftM` getRequest

4
yesod-core/Yesod/Core/Types.hs
View File

@ -13,7 +13,6 @@ import Control.Applicative (Applicative (..))
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Exception (Exception)
import Control.Failure (Failure (..))
import Control.Monad (liftM, ap)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.IO.Class (MonadIO (liftIO))
@ -424,9 +423,6 @@ instance MonadIO m => MonadLogger (HandlerT site m) where
monadLoggerLog a b c d = HandlerT $ \hd ->
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
instance Failure e m => Failure e (HandlerT site m) where
failure = lift . failure
instance Monoid (UniqueList x) where
mempty = UniqueList id
UniqueList x `mappend` UniqueList y = UniqueList $ x . y

64
yesod-core/Yesod/Core/Widget.hs
View File

@ -70,24 +70,25 @@ import qualified Data.Text.Lazy as TL
import Yesod.Core.Types
import Yesod.Core.Class.Handler
import Text.Shakespeare.I18N (renderMessage)
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup
class Monad m => ToWidget site m a where
toWidget :: a -> WidgetT site m ()
class ToWidget site a where
toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
instance (Monad m, render ~ RY site) => ToWidget site m (render -> Html) where
instance render ~ RY site => ToWidget site (render -> Html) where
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
instance (Monad m, render ~ RY site) => ToWidget site m (render -> Css) where
instance render ~ RY site => ToWidget site (render -> Css) where
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
instance (Monad m, render ~ RY site) => ToWidget site m (render -> CssBuilder) where
instance render ~ RY site => ToWidget site (render -> CssBuilder) where
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
instance (Monad m, render ~ RY site) => ToWidget site m (render -> Javascript) where
instance render ~ RY site => ToWidget site (render -> Javascript) where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance (site' ~ site, Monad m, m' ~ m) => ToWidget site' m' (WidgetT site m ()) where
toWidget = id
instance Monad m => ToWidget site m Html where
instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
toWidget = liftWidgetT
instance ToWidget site Html where
toWidget = toWidget . const
-- | Allows adding some CSS to the page with a specific media type.
@ -97,17 +98,17 @@ class ToWidgetMedia site a where
-- | Add the given content to the page, but only for the given media type.
--
-- Since 1.2
toWidgetMedia :: Monad m
toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)
=> Text -- ^ media value
-> a
-> WidgetT site m ()
-> m ()
instance render ~ RY site => ToWidgetMedia site (render -> Css) where
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
class ToWidgetBody site a where
toWidgetBody :: Monad m => a -> WidgetT site m ()
toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
instance render ~ RY site => ToWidgetBody site (render -> Html) where
toWidgetBody = toWidget
@ -117,7 +118,7 @@ instance ToWidgetBody site Html where
toWidgetBody = toWidget
class ToWidgetHead site a where
toWidgetHead :: Monad m => a -> WidgetT site m ()
toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
instance render ~ RY site => ToWidgetHead site (render -> Html) where
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
@ -132,52 +133,59 @@ instance ToWidgetHead site Html where
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values.
setTitle :: Monad m => Html -> WidgetT site m ()
setTitle :: MonadWidget m => Html -> m ()
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values.
setTitleI :: (Monad m, RenderMessage site msg) => msg -> WidgetT site m ()
setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
setTitleI msg = do
mr <- getMessageRender
setTitle $ toHtml $ mr msg
-- | Link to the specified local stylesheet.
addStylesheet :: Monad m => Route site -> WidgetT site m ()
addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
addStylesheet = flip addStylesheetAttrs []
-- | Link to the specified local stylesheet.
addStylesheetAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m ()
addStylesheetAttrs :: MonadWidget m
=> Route (HandlerSite m)
-> [(Text, Text)]
-> m ()
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
-- | Link to the specified remote stylesheet.
addStylesheetRemote :: Monad m => Text -> WidgetT site m ()
addStylesheetRemote :: MonadWidget m => Text -> m ()
addStylesheetRemote = flip addStylesheetRemoteAttrs []
-- | Link to the specified remote stylesheet.
addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m ()
addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
addStylesheetEither :: Monad m => Either (Route site) Text -> WidgetT site m ()
addStylesheetEither :: MonadWidget m
=> Either (Route (HandlerSite m)) Text
-> m ()
addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Monad m => Either (Route site) Text -> WidgetT site m ()
addScriptEither :: MonadWidget m
=> Either (Route (HandlerSite m)) Text
-> m ()
addScriptEither = either addScript addScriptRemote
-- | Link to the specified local script.
addScript :: Monad m => Route site -> WidgetT site m ()
addScript :: MonadWidget m => Route (HandlerSite m) -> m ()
addScript = flip addScriptAttrs []
-- | Link to the specified local script.
addScriptAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m ()
addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
-- | Link to the specified remote script.
addScriptRemote :: Monad m => Text -> WidgetT site m ()
addScriptRemote :: MonadWidget m => Text -> m ()
addScriptRemote = flip addScriptRemoteAttrs []
-- | Link to the specified remote script.
addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m ()
addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
whamlet :: QuasiQuoter
@ -207,7 +215,7 @@ rules = do
return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: (HandlerReader m, RenderMessage (HandlerSite m) message)
ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
=> HtmlUrlI18n message (Route (HandlerSite m))
-> m Html
ihamletToRepHtml ih = do
@ -215,8 +223,8 @@ ihamletToRepHtml ih = do
mrender <- getMessageRender
return $ ih (toHtml . mrender) urender
tell :: Monad m => GWData (Route site) -> WidgetT site m ()
tell w = WidgetT $ const $ return ((), w)
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
toUnique :: x -> UniqueList x
toUnique = UniqueList . (:)

11
yesod-core/helloworld.hs
View File

@ -17,17 +17,16 @@ mkYesodSub "Subsite" [] [parseRoutes|
/multi/*Strings SubMultiR
|]
getSubRootR :: Yesod m => GHandler Subsite m RepPlain
getSubRootR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepPlain
getSubRootR = do
Subsite s <- getYesodSub
tm <- getRouteToMaster
Subsite s <- getYesod
render <- getUrlRender
$logDebug "I'm in SubRootR"
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render SubRootR)
handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
handleSubMultiR :: Yesod master => Strings -> HandlerT Subsite (HandlerT master IO) RepPlain
handleSubMultiR x = do
Subsite y <- getYesodSub
Subsite y <- getYesod
$logInfo "In SubMultiR"
return . RepPlain . toContent . show $ (x, y)

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

@ -79,7 +79,6 @@ import qualified Data.ByteString.Lazy as L
import Data.Text (Text, unpack, pack)
import qualified Data.Text.Read
import Control.Monad.Trans.Class
import qualified Data.Map as Map
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB)
import Control.Arrow ((&&&))
@ -482,7 +481,7 @@ data Option a = Option
, optionExternalValue :: Text
}
optionsPairs :: (HandlerReader m, RenderMessage (HandlerSite m) msg)
optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
=> [(msg, a)] -> m (OptionList a)
optionsPairs opts = do
mr <- getMessageRender
@ -493,7 +492,7 @@ optionsPairs opts = do
}
return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
optionsEnum :: (HandlerReader m, Show a, Enum a, Bounded a) => m (OptionList a)
optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
optionsPersist :: ( YesodPersist site, PersistEntity a
@ -563,7 +562,7 @@ fileField = Field
, fieldEnctype = Multipart
}
fileAFormReq :: (HandlerState m, RenderMessage (HandlerSite m) FormMessage)
fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
=> FieldSettings (HandlerSite m) -> AForm m FileInfo
fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
let (name, ints') =
@ -595,7 +594,7 @@ $newline never
}
return (res, (fv :), ints', Multipart)
fileAFormOpt :: HandlerState m
fileAFormOpt :: MonadHandler m
=> RenderMessage (HandlerSite m) FormMessage
=> FieldSettings (HandlerSite m)
-> AForm m (Maybe FileInfo)

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

@ -100,21 +100,21 @@ askFiles = do
(x, _, _) <- ask
return $ liftM snd x
mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, HandlerState m)
mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
mopt :: (site ~ HandlerSite m, HandlerState m)
mopt :: (site ~ HandlerSite m, MonadHandler m)
=> Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (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, HandlerState m)
mhelper :: (site ~ HandlerSite m, MonadHandler m)
=> Field m a
-> FieldSettings site
-> Maybe a
@ -156,14 +156,14 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
, fvRequired = isReq
})
areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, HandlerState m)
areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a
-> FieldSettings site
-> Maybe a
-> AForm m a
areq a b = formToAForm . liftM (second return) . mreq a b
aopt :: HandlerState m
aopt :: MonadHandler m
=> Field m a
-> FieldSettings (HandlerSite m)
-> Maybe (Maybe a)
@ -187,14 +187,14 @@ 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, HandlerState m)
runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)
=> (Html -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype)
runFormPost form = do
env <- postEnv
postHelper form env
postHelper :: (HandlerReader m, RenderMessage (HandlerSite m) FormMessage)
postHelper :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
=> (Html -> MForm m (FormResult a, xml))
-> Maybe (Env, FileEnv)
-> m ((FormResult a, xml), Enctype)
@ -224,12 +224,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, HandlerReader m)
:: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
=> (Html -> MForm m (FormResult a, xml))
-> m (xml, Enctype)
generateFormPost form = first snd `liftM` postHelper form Nothing
postEnv :: (HandlerState m, MonadResource m)
postEnv :: (MonadHandler m, MonadResource m)
=> m (Maybe (Env, FileEnv))
postEnv = do
req <- getRequest
@ -240,7 +240,7 @@ 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 :: (HandlerState m, MonadResource m)
runFormPostNoToken :: MonadHandler m
=> (Html -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype)
runFormPostNoToken form = do
@ -249,7 +249,7 @@ runFormPostNoToken form = do
env <- postEnv
runFormGeneric (form mempty) m langs env
runFormGet :: HandlerReader m
runFormGet :: MonadHandler m
=> (Html -> MForm m a)
-> m (a, Enctype)
runFormGet form = do
@ -260,7 +260,7 @@ runFormGet form = do
Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
getHelper form env
generateFormGet :: HandlerReader m
generateFormGet :: MonadHandler m
=> (Html -> MForm m a)
-> m (a, Enctype)
generateFormGet form = getHelper form Nothing
@ -268,7 +268,7 @@ generateFormGet form = getHelper form Nothing
getKey :: Text
getKey = "_hasdata"
getHelper :: HandlerReader m
getHelper :: MonadHandler m
=> (Html -> MForm m a)
-> Maybe (Env, FileEnv)
-> m (a, Enctype)

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

@ -13,7 +13,6 @@ import Data.Text (Text)
import Control.Applicative (Applicative (..))
import Yesod.Core
import Control.Monad (liftM)
import Control.Monad.Trans.Resource
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Control.Arrow ((***))
@ -53,7 +52,7 @@ iopt field name = FormInput $ \m l env fenv -> do
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
Right x -> Right x
runInputGet :: HandlerError m => FormInput m a -> m a
runInputGet :: MonadHandler m => FormInput m a -> m a
runInputGet (FormInput f) = do
env <- liftM (toMap . reqGetParams) getRequest
m <- getYesod
@ -66,7 +65,7 @@ runInputGet (FormInput f) = do
toMap :: [(Text, a)] -> Map.Map Text [a]
toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
runInputPost :: (HandlerState m, HandlerError m, MonadResource m) => FormInput m a -> m a
runInputPost :: MonadHandler m => FormInput m a -> m a
runInputPost (FormInput f) = do
(env, fenv) <- liftM (toMap *** toMap) runRequestBody
m <- getYesod

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

@ -115,12 +115,14 @@ $(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:2})});
, fieldEnctype = UrlEncoded
}
addScript' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
addScript' :: (HandlerSite m ~ site, MonadWidget m) => (site -> Either (Route site) Text) -> m ()
addScript' f = do
y <- getYesod
addScriptEither $ f y
addStylesheet' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
addStylesheet' :: (MonadWidget m, HandlerSite m ~ site)
=> (site -> Either (Route site) Text)
-> m ()
addStylesheet' f = do
y <- getYesod
addStylesheetEither $ f y

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

@ -47,7 +47,9 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{ra
where
showVal = either id (pack . renderHtml)
addScript' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
addScript' :: (MonadWidget m, HandlerSite m ~ site)
=> (site -> Either (Route site) Text)
-> m ()
addScript' f = do
y <- getYesod
addScriptEither $ f y

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

@ -42,7 +42,7 @@ instance HasContentType RepAtom where
instance ToTypedContent RepAtom where
toTypedContent = TypedContent typeAtom . toContent
atomFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m RepAtom
atomFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepAtom
atomFeed feed = do
render <- getUrlRender
return $ RepAtom $ toContent $ renderLBS def $ template feed render
@ -75,10 +75,10 @@ entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElemen
]
-- | Generates a link tag in the head of a widget.
atomLink :: Monad m
=> Route site
atomLink :: MonadWidget m
=> Route (HandlerSite m)
-> Text -- ^ title
-> WidgetT site m ()
-> m ()
atomLink r title = toWidgetHead [hamlet|
<link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
|]

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

@ -25,7 +25,7 @@ import Yesod.AtomFeed
import Yesod.RssFeed
import Yesod.Core
newsFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m TypedContent
newsFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m TypedContent
newsFeed f = selectRep $ do
provideRep $ atomFeed f
provideRep $ rssFeed f

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

@ -39,7 +39,7 @@ instance ToTypedContent RepRss where
toTypedContent = TypedContent typeRss . toContent
-- | Generate the feed
rssFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m RepRss
rssFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepRss
rssFeed feed = do
render <- getUrlRender
return $ RepRss $ toContent $ renderLBS def $ template feed render
@ -71,10 +71,10 @@ entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
]
-- | Generates a link tag in the head of a widget.
rssLink :: Monad m
=> Route site
rssLink :: MonadWidget m
=> Route (HandlerSite m)
-> Text -- ^ title
-> WidgetT site m ()
-> m ()
rssLink r title = toWidgetHead [hamlet|
<link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
|]

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

@ -75,14 +75,14 @@ template urls render =
, Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority]
]
sitemap :: HandlerReader m => [SitemapUrl (Route (HandlerSite m))] -> m RepXml
sitemap :: MonadHandler m => [SitemapUrl (Route (HandlerSite m))] -> m RepXml
sitemap urls = do
render <- getUrlRender
let doc = template urls render
return $ RepXml $ toContent $ renderLBS def doc
-- | A basic robots file which just lists the "Sitemap: " line.
robots :: HandlerReader m
robots :: MonadHandler m
=> Route (HandlerSite m) -- ^ sitemap url
-> m RepPlain
robots smurl = do

4
yesod/Yesod/Default/Handlers.hs
View File

@ -6,8 +6,8 @@ module Yesod.Default.Handlers
import Yesod.Core
getFaviconR :: HandlerError m => m ()
getFaviconR :: MonadHandler m => m ()
getFaviconR = sendFile "image/x-icon" "config/favicon.ico"
getRobotsR :: HandlerError m => m ()
getRobotsR :: MonadHandler m => m ()
getRobotsR = sendFile "text/plain" "config/robots.txt"