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"