diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs
index 68618b29..4ce6dd62 100644
--- a/yesod-core/Yesod/Core.hs
+++ b/yesod-core/Yesod/Core.hs
@@ -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
diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs
index 4885fc21..e94f8d5f 100644
--- a/yesod-core/Yesod/Core/Class/Handler.hs
+++ b/yesod-core/Yesod/Core/Class/Handler.hs
@@ -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
diff --git a/yesod-core/Yesod/Core/Content.hs b/yesod-core/Yesod/Core/Content.hs
index fcc72f71..a456d0a7 100644
--- a/yesod-core/Yesod/Core/Content.hs
+++ b/yesod-core/Yesod/Core/Content.hs
@@ -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
diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs
index ee9c1186..c71d61a1 100644
--- a/yesod-core/Yesod/Core/Dispatch.hs
+++ b/yesod-core/Yesod/Core/Dispatch.hs
@@ -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
diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs
index 2e804a48..9f47770d 100644
--- a/yesod-core/Yesod/Core/Handler.hs
+++ b/yesod-core/Yesod/Core/Handler.hs
@@ -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
diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs
index d899bf1e..27e3ac99 100644
--- a/yesod-core/Yesod/Core/Json.hs
+++ b/yesod-core/Yesod/Core/Json.hs
@@ -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
diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs
index a0332d5f..f3b1a6f3 100644
--- a/yesod-core/Yesod/Core/Types.hs
+++ b/yesod-core/Yesod/Core/Types.hs
@@ -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
diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs
index 3b36f4df..eda44ebd 100644
--- a/yesod-core/Yesod/Core/Widget.hs
+++ b/yesod-core/Yesod/Core/Widget.hs
@@ -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 . (:)
diff --git a/yesod-core/helloworld.hs b/yesod-core/helloworld.hs
index c36abfbf..8ccba74d 100644
--- a/yesod-core/helloworld.hs
+++ b/yesod-core/helloworld.hs
@@ -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)
diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs
index 46344428..72883e08 100644
--- a/yesod-form/Yesod/Form/Fields.hs
+++ b/yesod-form/Yesod/Form/Fields.hs
@@ -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)
diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs
index 070bffaf..40b29929 100644
--- a/yesod-form/Yesod/Form/Functions.hs
+++ b/yesod-form/Yesod/Form/Functions.hs
@@ -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)
diff --git a/yesod-form/Yesod/Form/Input.hs b/yesod-form/Yesod/Form/Input.hs
index dd5fb73c..6cbe8dd0 100644
--- a/yesod-form/Yesod/Form/Input.hs
+++ b/yesod-form/Yesod/Form/Input.hs
@@ -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
diff --git a/yesod-form/Yesod/Form/Jquery.hs b/yesod-form/Yesod/Form/Jquery.hs
index f2721d30..d56573d8 100644
--- a/yesod-form/Yesod/Form/Jquery.hs
+++ b/yesod-form/Yesod/Form/Jquery.hs
@@ -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
diff --git a/yesod-form/Yesod/Form/Nic.hs b/yesod-form/Yesod/Form/Nic.hs
index bf6db93c..28afc50c 100644
--- a/yesod-form/Yesod/Form/Nic.hs
+++ b/yesod-form/Yesod/Form/Nic.hs
@@ -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
diff --git a/yesod-newsfeed/Yesod/AtomFeed.hs b/yesod-newsfeed/Yesod/AtomFeed.hs
index a3304bdd..a9c0d257 100644
--- a/yesod-newsfeed/Yesod/AtomFeed.hs
+++ b/yesod-newsfeed/Yesod/AtomFeed.hs
@@ -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|
|]
diff --git a/yesod-newsfeed/Yesod/Feed.hs b/yesod-newsfeed/Yesod/Feed.hs
index eb8eeba3..0dcd2b09 100644
--- a/yesod-newsfeed/Yesod/Feed.hs
+++ b/yesod-newsfeed/Yesod/Feed.hs
@@ -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
diff --git a/yesod-newsfeed/Yesod/RssFeed.hs b/yesod-newsfeed/Yesod/RssFeed.hs
index 4d744778..8243b4a1 100644
--- a/yesod-newsfeed/Yesod/RssFeed.hs
+++ b/yesod-newsfeed/Yesod/RssFeed.hs
@@ -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|
|]
diff --git a/yesod-sitemap/Yesod/Sitemap.hs b/yesod-sitemap/Yesod/Sitemap.hs
index 45659685..dbf633b5 100644
--- a/yesod-sitemap/Yesod/Sitemap.hs
+++ b/yesod-sitemap/Yesod/Sitemap.hs
@@ -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
diff --git a/yesod/Yesod/Default/Handlers.hs b/yesod/Yesod/Default/Handlers.hs
index 870f16ee..8abc57fa 100644
--- a/yesod/Yesod/Default/Handlers.hs
+++ b/yesod/Yesod/Default/Handlers.hs
@@ -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"