From 2c2ee10dd7151516f8c7c025c418153ec75880d5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 07:08:03 +0200 Subject: [PATCH] Converted Yesod.Handler to typeclasses --- yesod-core/Yesod/Core.hs | 2 + yesod-core/Yesod/Core/Class.hs | 2 +- yesod-core/Yesod/Core/Handler/Class.hs | 36 ++-- yesod-core/Yesod/Core/Json.hs | 3 +- yesod-core/Yesod/Dispatch.hs | 2 +- yesod-core/Yesod/Handler.hs | 286 +++++++++++++------------ yesod-core/Yesod/Internal/Core.hs | 2 +- yesod-core/Yesod/Widget.hs | 3 +- 8 files changed, 172 insertions(+), 164 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index ddbc2b68..0cd10eee 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -51,6 +51,7 @@ module Yesod.Core , module Yesod.Handler , module Yesod.Widget , module Yesod.Core.Json + , module Yesod.Core.Trans.Class , module Text.Shakespeare.I18N ) where @@ -61,6 +62,7 @@ import Yesod.Handler import Yesod.Widget import Yesod.Core.Json import Yesod.Core.Types +import Yesod.Core.Trans.Class import Text.Shakespeare.I18N import Control.Monad.Logger diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 5765ec3f..920028c2 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -6,7 +6,7 @@ module Yesod.Core.Class where import Control.Monad.Logger (logErrorS) import Yesod.Content -import Yesod.Handler hiding (getExpires, lift) +import Yesod.Handler hiding (getExpires) import Yesod.Routes.Class diff --git a/yesod-core/Yesod/Core/Handler/Class.hs b/yesod-core/Yesod/Core/Handler/Class.hs index 46cb8176..6d35112d 100644 --- a/yesod-core/Yesod/Core/Handler/Class.hs +++ b/yesod-core/Yesod/Core/Handler/Class.hs @@ -11,37 +11,34 @@ import Data.IORef.Lifted (atomicModifyIORef) import Control.Exception.Lifted (throwIO) class Monad m => HandlerReader m where - type HandlerReaderSub m - type HandlerReaderMaster m + type HandlerSub m + type HandlerMaster m askYesodRequest :: m YesodRequest - askHandlerEnv :: m (RunHandlerEnv (HandlerReaderSub m) (HandlerReaderMaster m)) + askHandlerEnv :: m (RunHandlerEnv (HandlerSub m) (HandlerMaster m)) instance HandlerReader (GHandler sub master) where - type HandlerReaderSub (GHandler sub master) = sub - type HandlerReaderMaster (GHandler sub master) = master + type HandlerSub (GHandler sub master) = sub + type HandlerMaster (GHandler sub master) = master askYesodRequest = GHandler $ return . handlerRequest askHandlerEnv = GHandler $ return . handlerEnv instance HandlerReader (GWidget sub master) where - type HandlerReaderSub (GWidget sub master) = sub - type HandlerReaderMaster (GWidget sub master) = master + type HandlerSub (GWidget sub master) = sub + type HandlerMaster (GWidget sub master) = master askYesodRequest = lift askYesodRequest askHandlerEnv = lift askHandlerEnv instance (MonadTrans t, HandlerReader m, Monad (t m)) => HandlerReader (t m) where - type HandlerReaderSub (t m) = HandlerReaderSub m - type HandlerReaderMaster (t m) = HandlerReaderMaster m + type HandlerSub (t m) = HandlerSub m + type HandlerMaster (t m) = HandlerMaster m askYesodRequest = lift askYesodRequest askHandlerEnv = lift askHandlerEnv class HandlerReader m => HandlerState m where - type HandlerStateSub m - type HandlerStateMaster m - stateGHState :: (GHState -> (a, GHState)) -> m a getGHState :: m GHState @@ -51,31 +48,22 @@ class HandlerReader m => HandlerState m where putGHState s = stateGHState $ const ((), s) instance HandlerState (GHandler sub master) where - type HandlerStateSub (GHandler sub master) = sub - type HandlerStateMaster (GHandler sub master) = master - stateGHState f = GHandler $ flip atomicModifyIORef f' . handlerState where f' z = let (x, y) = f z in (y, x) instance HandlerState (GWidget sub master) where - type HandlerStateSub (GWidget sub master) = sub - type HandlerStateMaster (GWidget sub master) = master - stateGHState = lift . stateGHState instance (MonadTrans t, HandlerState m, Monad (t m)) => HandlerState (t m) where - type HandlerStateSub (t m) = HandlerStateSub m - type HandlerStateMaster (t m) = HandlerStateMaster m - stateGHState = lift . stateGHState -class Monad m => HandlerError m where - handlerError :: ErrorResponse -> m a +class HandlerReader m => HandlerError m where + handlerError :: HandlerContents -> m a instance HandlerError (GHandler sub master) where - handlerError = throwIO . HCError + handlerError = throwIO instance HandlerError (GWidget sub master) where handlerError = lift . handlerError diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index d4e3eaa8..b4ca9c06 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -20,7 +20,8 @@ module Yesod.Core.Json , acceptsJson ) where -import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs, redirect) +import Yesod.Handler (GHandler, waiRequest, invalidArgs, redirect) +import Yesod.Core.Trans.Class (lift) import Yesod.Content ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml) , RepJson (RepJson) diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index dc752019..6c4a0d6b 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -32,7 +32,7 @@ module Yesod.Dispatch import Control.Applicative ((<$>), (<*>)) import Prelude hiding (exp) import Yesod.Internal.Core -import Yesod.Handler hiding (lift) +import Yesod.Handler import Web.PathPieces import Language.Haskell.TH diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 3f5ba9a0..61f0257e 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -117,7 +117,6 @@ module Yesod.Handler -- ** Misc , newIdent -- * Lifting - , MonadLift (..) , handlerToIO -- * i18n , getMessageRender @@ -130,53 +129,52 @@ module Yesod.Handler , ErrorResponse (..) ) where -import Prelude hiding (catch) -import Yesod.Core.Internal.Request -import Data.Time (UTCTime, getCurrentTime, addUTCTime) +import Data.Time (UTCTime, addUTCTime, + getCurrentTime) +import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, + mkFileInfoLBS, mkFileInfoSource) -import Control.Exception hiding (Handler, catch, finally) -import Control.Applicative +import Control.Applicative ((<$>)) -import Control.Monad (liftM) +import Control.Monad (liftM) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource (MonadResource, liftResourceT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (MonadResource, liftResourceT) -import qualified Network.Wai as W -import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types as H +import qualified Network.Wai as W -import Text.Hamlet +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html.Renderer.Text as RenderText -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.Lazy as TL +import Text.Hamlet (Html, HtmlUrl, hamlet) -import qualified Data.Map as Map -import qualified Data.ByteString as S +import qualified Data.ByteString as S +import qualified Data.Map as Map -import Yesod.Content -import Data.Maybe (mapMaybe) -import Web.Cookie (SetCookie (..)) -import Control.Arrow ((***)) -import qualified Network.Wai.Parse as NWP -import Data.Monoid (mappend, mempty, Endo (..)) -import qualified Data.ByteString.Char8 as S8 -import Data.Text (Text) -import Text.Shakespeare.I18N (RenderMessage (..)) +import Control.Arrow ((***)) +import qualified Data.ByteString.Char8 as S8 +import Data.Maybe (mapMaybe) +import Data.Monoid (Endo (..), mappend, mempty) +import Data.Text (Text) +import qualified Network.Wai.Parse as NWP +import Text.Shakespeare.I18N (RenderMessage (..)) +import Web.Cookie (SetCookie (..)) +import Yesod.Content (HasReps, chooseRep, + formatRFC1123, toContent) -import Text.Blaze.Html (toHtml, preEscapedToMarkup) -#define preEscapedText preEscapedToMarkup +import Text.Blaze.Html (preEscapedToMarkup, toHtml) -import qualified Data.IORef as I -import Control.Monad.Trans.Resource (ResourceT, runResourceT) -import Yesod.Routes.Class (Route) -import Yesod.Core.Types -import Yesod.Core.Trans.Class -import Data.Maybe (listToMaybe) -import Data.Typeable (Typeable, typeOf) -import Data.Dynamic (fromDynamic, toDyn) -import Yesod.Core.Handler.Class +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Data.Dynamic (fromDynamic, toDyn) +import qualified Data.IORef as I +import Data.Maybe (listToMaybe) +import Data.Typeable (Typeable, typeOf) +import Yesod.Core.Handler.Class +import Yesod.Core.Types +import Yesod.Routes.Class (Route) class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y @@ -194,7 +192,7 @@ tell :: HandlerState m => Endo [Header] -> m () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } hcError :: HandlerError m => ErrorResponse -> m a -hcError = handlerError +hcError = handlerError . HCError class SubsiteGetter g m s | g -> s where runSubsiteGetter :: g -> m s @@ -254,32 +252,33 @@ rbHelper' backend mkFI req = go = decodeUtf8With lenientDecode -- | Get the sub application argument. -getYesodSub :: HandlerReader m => m (HandlerReaderSub m) +getYesodSub :: HandlerReader m => m (HandlerSub m) getYesodSub = rheSub `liftM` askHandlerEnv -- | Get the master site appliation argument. -getYesod :: HandlerReader m => m (HandlerReaderMaster m) +getYesod :: HandlerReader m => m (HandlerMaster m) getYesod = rheMaster `liftM` askHandlerEnv -- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Route master -> Text) +getUrlRender :: HandlerReader m => m (Route (HandlerMaster m) -> Text) getUrlRender = do x <- rheRender `liftM` askHandlerEnv return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams - :: GHandler sub master (Route master -> [(Text, Text)] -> Text) + :: HandlerReader m + => m (Route (HandlerMaster 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 :: GHandler sub master (Maybe (Route sub)) +getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSub m))) getCurrentRoute = rheRoute `liftM` askHandlerEnv -- | Get the function to promote a route for a subsite to a route for the -- master site. -getRouteToMaster :: GHandler sub master (Route sub -> Route master) +getRouteToMaster :: HandlerReader m => m (Route (HandlerSub m) -> Route (HandlerMaster m)) getRouteToMaster = rheToMaster `liftM` askHandlerEnv @@ -359,7 +358,8 @@ handlerToIO = -- -- If you want direct control of the final status code, or need a different -- status code, please use 'redirectWith'. -redirect :: RedirectUrl master url => url -> GHandler sub master a +redirect :: (HandlerError m, RedirectUrl (HandlerMaster m) url, HandlerReader m) + => url -> m a redirect url = do req <- waiRequest let status = @@ -369,10 +369,13 @@ redirect url = do redirectWith status url -- | Redirect to the given URL with the specified status code. -redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a +redirectWith :: (HandlerError m, RedirectUrl (HandlerMaster m) url, HandlerReader m) + => H.Status + -> url + -> m a redirectWith status url = do urlText <- toTextUrl url - liftIO $ throwIO $ HCRedirect status urlText + handlerError $ HCRedirect status urlText ultDestKey :: Text ultDestKey = "_ULT" @@ -381,7 +384,9 @@ ultDestKey = "_ULT" -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. -setUltDest :: RedirectUrl master url => url -> GHandler sub master () +setUltDest :: (HandlerState m, RedirectUrl (HandlerMaster m) url) + => url + -> m () setUltDest url = do urlText <- toTextUrl url setSession ultDestKey urlText @@ -390,7 +395,7 @@ setUltDest url = do -- -- If this is a 404 handler, there is no current page, and then this call does -- nothing. -setUltDestCurrent :: GHandler sub master () +setUltDestCurrent :: HandlerState m => m () setUltDestCurrent = do route <- getCurrentRoute case route of @@ -403,7 +408,7 @@ setUltDestCurrent = do -- | Sets the ultimate destination to the referer request header, if present. -- -- This function will not overwrite an existing ultdest. -setUltDestReferer :: GHandler sub master () +setUltDestReferer :: HandlerState m => m () setUltDestReferer = do mdest <- lookupSession ultDestKey maybe @@ -420,16 +425,16 @@ setUltDestReferer = do -- -- This function uses 'redirect', and thus will perform a temporary redirect to -- a GET request. -redirectUltDest :: RedirectUrl master url +redirectUltDest :: (RedirectUrl (HandlerMaster m) url, HandlerState m, HandlerError m) => url -- ^ default destination if nothing in session - -> GHandler sub master a + -> m a redirectUltDest def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey maybe (redirect def) redirect mdest -- | Remove a previously set ultimate destination. See 'setUltDest'. -clearUltDest :: GHandler sub master () +clearUltDest :: HandlerState m => m () clearUltDest = deleteSession ultDestKey msgKey :: Text @@ -438,13 +443,14 @@ msgKey = "_MSG" -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessage :: Html -> GHandler sub master () +setMessage :: HandlerState m => Html -> m () setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y () +setMessageI :: (HandlerState m, RenderMessage (HandlerMaster m) msg) + => msg -> m () setMessageI msg = do mr <- getMessageRender setMessage $ toHtml $ mr msg @@ -453,9 +459,9 @@ setMessageI msg = do -- variable. -- -- See 'setMessage'. -getMessage :: GHandler sub master (Maybe Html) +getMessage :: HandlerState m => m (Maybe Html) getMessage = do - mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey + mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey deleteSession msgKey return mmsg @@ -463,71 +469,72 @@ 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 :: ContentType -> FilePath -> GHandler sub master a -sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing +sendFile :: HandlerError m => ContentType -> FilePath -> m a +sendFile ct fp = handlerError $ HCSendFile ct fp Nothing -- | Same as 'sendFile', but only sends part of a file. -sendFilePart :: ContentType +sendFilePart :: HandlerError m + => ContentType -> FilePath -> Integer -- ^ offset -> Integer -- ^ count - -> GHandler sub master a + -> m a sendFilePart ct fp off count = - liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count + handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count -- | Bypass remaining handler code and output the given content with a 200 -- status code. -sendResponse :: HasReps c => c -> GHandler sub master a -sendResponse = liftIO . throwIO . HCContent H.status200 - . chooseRep +sendResponse :: (HandlerError m, HasReps c) => c -> m a +sendResponse = handlerError . HCContent H.status200 . chooseRep -- | Bypass remaining handler code and output the given content with the given -- status code. -sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a -sendResponseStatus s = liftIO . throwIO . HCContent s - . chooseRep +sendResponseStatus :: (HandlerError m, HasReps c) => H.Status -> c -> m a +sendResponseStatus s = handlerError . HCContent s . chooseRep -- | Send a 201 "Created" response with the given route as the Location -- response header. -sendResponseCreated :: Route m -> GHandler s m a +sendResponseCreated :: HandlerError m => Route (HandlerMaster m) -> m a sendResponseCreated url = do r <- getUrlRender - liftIO . throwIO $ HCCreated $ r url + handlerError $ HCCreated $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session -- 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 :: W.Response -> GHandler s m b -sendWaiResponse = liftIO . throwIO . HCWai +sendWaiResponse :: HandlerError m => W.Response -> m b +sendWaiResponse = handlerError . HCWai -- | Return a 404 not found page. Also denotes no handler available. -notFound :: GHandler sub master a +notFound :: HandlerError m => m a notFound = hcError NotFound -- | Return a 405 method not supported page. -badMethod :: GHandler sub master a +badMethod :: HandlerError m => m a badMethod = do w <- waiRequest hcError $ BadMethod $ W.requestMethod w -- | Return a 403 permission denied page. -permissionDenied :: Text -> GHandler sub master a +permissionDenied :: HandlerError m => Text -> m a permissionDenied = hcError . PermissionDenied -- | Return a 403 permission denied page. -permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a +permissionDeniedI :: (RenderMessage (HandlerMaster m) msg, HandlerError m) + => msg + -> m a permissionDeniedI msg = do mr <- getMessageRender permissionDenied $ mr msg -- | Return a 400 invalid arguments page. -invalidArgs :: [Text] -> GHandler sub master a +invalidArgs :: HandlerError m => [Text] -> m a invalidArgs = hcError . InvalidArgs -- | Return a 400 invalid arguments page. -invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a +invalidArgsI :: (HandlerError m, RenderMessage (HandlerMaster m) msg) => [msg] -> m a invalidArgsI msg = do mr <- getMessageRender invalidArgs $ map mr msg @@ -535,13 +542,13 @@ invalidArgsI msg = do ------- Headers -- | Set the cookie on the client. -setCookie :: SetCookie - -> GHandler sub master () +setCookie :: HandlerState m => SetCookie -> m () setCookie = addHeader . AddCookie -- | Helper function for setCookieExpires value -getExpires :: Int -- ^ minutes - -> IO UTCTime +getExpires :: MonadIO m + => Int -- ^ minutes + -> m UTCTime getExpires m = do now <- liftIO getCurrentTime return $ fromIntegral (m * 60) `addUTCTime` now @@ -551,27 +558,28 @@ 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 :: Text -- ^ key +deleteCookie :: HandlerState m + => Text -- ^ key -> Text -- ^ path - -> GHandler sub master () + -> m () deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8 -- | Set the language in the user session. Will show up in 'languages' on the -- next request. -setLanguage :: Text -> GHandler sub master () +setLanguage :: HandlerState 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 :: Text -> Text -> GHandler sub master () +setHeader :: HandlerState 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 :: Int -> GHandler s m () +cacheSeconds :: HandlerState m => Int -> m () cacheSeconds i = setHeader "Cache-Control" $ T.concat [ "max-age=" , T.pack $ show i @@ -580,16 +588,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 :: GHandler s m () +neverExpires :: HandlerState 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 :: GHandler s m () +alreadyExpired :: HandlerState m => m () alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. -expiresAt :: UTCTime -> GHandler s m () +expiresAt :: HandlerState m => UTCTime -> m () expiresAt = setHeader "Expires" . formatRFC1123 -- | Set a variable in the user's session. @@ -597,38 +605,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 :: Text -- ^ key +setSession :: HandlerState m + => Text -- ^ key -> Text -- ^ value - -> GHandler sub master () + -> m () setSession k = setSessionBS k . encodeUtf8 -- | Same as 'setSession', but uses binary data for the value. -setSessionBS :: Text +setSessionBS :: HandlerState m + => Text -> S.ByteString - -> GHandler sub master () + -> m () setSessionBS k = modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. -deleteSession :: Text -> GHandler sub master () +deleteSession :: HandlerState m => Text -> m () deleteSession = modify . modSession . Map.delete -- | Clear all session variables. -- -- Since: 1.0.1 -clearSession :: GHandler sub master () +clearSession :: HandlerState 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 :: Header -> GHandler sub master () +addHeader :: HandlerState 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 :: a -> GHandler sub master Text + toTextUrl :: (HandlerReader m, HandlerMaster m ~ master) => a -> m Text instance RedirectUrl master Text where toTextUrl = return @@ -650,21 +660,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 :: Text -> GHandler s m (Maybe Text) -lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS +lookupSession :: HandlerState m => Text -> m (Maybe Text) +lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS -- | Lookup for session data in binary format. -lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString) +lookupSessionBS :: HandlerState m => Text -> m (Maybe S.ByteString) lookupSessionBS n = do m <- liftM ghsSession get return $ Map.lookup n m -- | Get all session variables. -getSession :: GHandler sub master SessionMap +getSession :: HandlerState m => m SessionMap getSession = liftM ghsSession get -- | Get a unique identifier. -newIdent :: GHandler sub master Text +newIdent :: HandlerState m => m Text newIdent = do x <- get let i' = ghsIdent x + 1 @@ -677,7 +687,9 @@ 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 :: RedirectUrl master url => url -> GHandler sub master a +redirectToPost :: (HandlerError m, RedirectUrl (HandlerMaster m) url) + => url + -> m a redirectToPost url = do urlText <- toTextUrl url hamletToRepHtml [hamlet| @@ -696,20 +708,21 @@ $doctype 5 -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. -hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content +hamletToContent :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m Content hamletToContent h = do render <- getUrlRenderParams return $ toContent $ h render -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml +hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m RepHtml hamletToRepHtml = liftM RepHtml . hamletToContent -- | Get the request\'s 'W.Request' value. waiRequest :: HandlerReader m => m W.Request waiRequest = reqWaiRequest `liftM` getRequest -getMessageRender :: RenderMessage master message => GHandler s master (message -> Text) +getMessageRender :: (HandlerReader m, RenderMessage (HandlerMaster m) message) + => m (message -> Text) getMessageRender = do m <- getYesod l <- reqLangs `liftM` getRequest @@ -720,9 +733,9 @@ getMessageRender = do -- newtype wrappers to distinguish logically different types. -- -- Since 1.2.0 -cached :: Typeable a - => GHandler sub master a - -> GHandler sub master a +cached :: (HandlerState m, Typeable a) + => m a + -> m a cached f = do gs <- get let cache = ghsCache gs @@ -761,50 +774,53 @@ cached f = do -- If a matching language is not found the default language will be used. -- -- This is handled by parseWaiRequest (not exposed). -languages :: GHandler s m [Text] +languages :: HandlerReader 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 :: Text -> GHandler s m [Text] +lookupGetParams :: HandlerReader m => Text -> m [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. -lookupGetParam :: Text -> GHandler s m (Maybe Text) +lookupGetParam :: HandlerReader m => Text -> m (Maybe Text) lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters. -lookupPostParams :: Text -> GHandler s m [Text] +lookupPostParams :: (MonadResource m, HandlerState m) => Text -> m [Text] lookupPostParams pn = do (pp, _) <- runRequestBody return $ lookup' pn pp -lookupPostParam :: Text - -> GHandler s m (Maybe Text) +lookupPostParam :: (MonadResource m, HandlerState m) + => Text + -> m (Maybe Text) lookupPostParam = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files. -lookupFile :: Text - -> GHandler s m (Maybe FileInfo) +lookupFile :: (HandlerState m, MonadResource m) + => Text + -> m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. -lookupFiles :: Text - -> GHandler s m [FileInfo] +lookupFiles :: (HandlerState m, MonadResource m) + => Text + -> m [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. -lookupCookie :: Text -> GHandler s m (Maybe Text) +lookupCookie :: HandlerReader m => Text -> m (Maybe Text) lookupCookie = liftM listToMaybe . lookupCookies -- | Lookup for cookie data. -lookupCookies :: Text -> GHandler s m [Text] +lookupCookies :: HandlerReader m => Text -> m [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 4a8a3a4e..1e330eb7 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -41,7 +41,7 @@ module Yesod.Internal.Core ) where import Yesod.Content -import Yesod.Handler hiding (lift, getExpires) +import Yesod.Handler hiding (getExpires) import Yesod.Routes.Class diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 9dbb4acb..7391c841 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -53,8 +53,9 @@ import Text.Julius import Yesod.Routes.Class import Yesod.Handler ( YesodSubRoute(..), getYesod - , getMessageRender, getUrlRenderParams, MonadLift (..) + , getMessageRender, getUrlRenderParams ) +import Yesod.Core.Trans.Class (lift) import Text.Shakespeare.I18N (RenderMessage) import Yesod.Content (toContent) import Control.Monad (liftM)