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

yesod-core compiles and passes all tests (that was easy)

Browse Source
This commit is contained in:
Michael Snoyman 2011-12-27 16:11:52 +02:00
parent 7036402b0a
commit 0511a1e351
13 changed files with 109 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-core/Yesod/Content.hs
View File

@ -54,7 +54,6 @@ import System.Locale
import qualified Data.Text.Encoding import qualified Data.Text.Encoding
import qualified Data.Text.Lazy.Encoding import qualified Data.Text.Lazy.Encoding
import Data.Enumerator (Enumerator)
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import Data.Monoid (mempty) import Data.Monoid (mempty)
@ -62,9 +61,10 @@ import Text.Hamlet (Html)
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import Data.String (IsString (fromString)) import Data.String (IsString (fromString))
import Network.Wai (FilePart) import Network.Wai (FilePart)
import Data.Conduit (Source)
data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
| ContentEnum (forall a. Enumerator Builder IO a) | ContentSource (Source IO Builder)
| ContentFile FilePath (Maybe FilePart) | ContentFile FilePath (Maybe FilePart)
-- | Zero-length enumerator. -- | Zero-length enumerator.

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

@ -34,7 +34,6 @@ module Yesod.Core
, module Yesod.Request , module Yesod.Request
, module Yesod.Widget , module Yesod.Widget
, module Yesod.Message , module Yesod.Message
, module Yesod.Config
) where ) where
import Yesod.Internal.Core import Yesod.Internal.Core
@ -44,7 +43,6 @@ import Yesod.Handler
import Yesod.Request import Yesod.Request
import Yesod.Widget import Yesod.Widget
import Yesod.Message import Yesod.Message
import Yesod.Config
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Data.Text (Text) import Data.Text (Text)

6
yesod-core/Yesod/Dispatch.hs
View File

@ -15,8 +15,8 @@ module Yesod.Dispatch
, mkYesodDispatch , mkYesodDispatch
, mkYesodSubDispatch , mkYesodSubDispatch
-- ** Path pieces -- ** Path pieces
, SinglePiece (..) , PathPiece (..)
, MultiPiece (..) , PathMultiPiece (..)
, Texts , Texts
-- * Convert to WAI -- * Convert to WAI
, toWaiApp , toWaiApp
@ -31,7 +31,7 @@ import Yesod.Handler
import Yesod.Internal.Dispatch import Yesod.Internal.Dispatch
import Yesod.Widget (GWidget) import Yesod.Widget (GWidget)
import Web.PathPieces (SinglePiece (..), MultiPiece (..)) import Web.PathPieces
import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck) import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax

160
yesod-core/Yesod/Handler.hs
View File

@ -28,7 +28,7 @@ module Yesod.Handler
, YesodSubRoute (..) , YesodSubRoute (..)
-- * Handler monad -- * Handler monad
, GHandler , GHandler
, GGHandler , GHandlerT
-- ** Read information from handler -- ** Read information from handler
, getYesod , getYesod
, getYesodSub , getYesodSub
@ -148,8 +148,6 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString as S import qualified Data.ByteString as S
import Data.ByteString (ByteString)
import Data.Enumerator (Iteratee (..), run_, ($$))
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
import Yesod.Content import Yesod.Content
@ -165,12 +163,15 @@ import Data.Text (Text)
import Yesod.Message (RenderMessage (..)) import Yesod.Message (RenderMessage (..))
import Text.Blaze (toHtml, preEscapedText) import Text.Blaze (toHtml, preEscapedText)
import Yesod.Internal.TestApi (catchIter)
import qualified Yesod.Internal.Cache as Cache import qualified Yesod.Internal.Cache as Cache
import Yesod.Internal.Cache (mkCacheKey, CacheKey) import Yesod.Internal.Cache (mkCacheKey, CacheKey)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import qualified Data.IORef as I import qualified Data.IORef as I
import Control.Monad.Trans.Resource (ResourceT)
import Control.Exception.Lifted (catch)
import Network.Wai (requestBody)
import Data.Conduit (($$))
-- | The type-safe URLs associated with a site argument. -- | The type-safe URLs associated with a site argument.
type family Route a type family Route a
@ -206,22 +207,22 @@ handlerSubDataMaybe tm ts route hd = hd
, handlerRoute = route , handlerRoute = route
} }
get :: MonadIO monad => GGHandler sub master monad GHState get :: MonadIO monad => GHandlerT sub master monad GHState
get = do get = do
hd <- ask hd <- ask
liftIO $ I.readIORef $ handlerState hd liftIO $ I.readIORef $ handlerState hd
put :: MonadIO monad => GHState -> GGHandler sub master monad () put :: MonadIO monad => GHState -> GHandlerT sub master monad ()
put g = do put g = do
hd <- ask hd <- ask
liftIO $ I.writeIORef (handlerState hd) g liftIO $ I.writeIORef (handlerState hd) g
modify :: MonadIO monad => (GHState -> GHState) -> GGHandler sub master monad () modify :: MonadIO monad => (GHState -> GHState) -> GHandlerT sub master monad ()
modify f = do modify f = do
hd <- ask hd <- ask
liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ()) liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
tell :: MonadIO monad => Endo [Header] -> GGHandler sub master monad () tell :: MonadIO monad => Endo [Header] -> GHandlerT sub master monad ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
-- | Used internally for promoting subsite handler functions to master site -- | Used internally for promoting subsite handler functions to master site
@ -229,16 +230,16 @@ tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
toMasterHandler :: (Route sub -> Route master) toMasterHandler :: (Route sub -> Route master)
-> (master -> sub) -> (master -> sub)
-> Route sub -> Route sub
-> GGHandler sub master mo a -> GHandlerT sub master mo a
-> GGHandler sub' master mo a -> GHandlerT sub' master mo a
toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route) toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)
toMasterHandlerDyn :: Monad mo toMasterHandlerDyn :: Monad mo
=> (Route sub -> Route master) => (Route sub -> Route master)
-> GGHandler sub' master mo sub -> GHandlerT sub' master mo sub
-> Route sub -> Route sub
-> GGHandler sub master mo a -> GHandlerT sub master mo a
-> GGHandler sub' master mo a -> GHandlerT sub' master mo a
toMasterHandlerDyn tm getSub route h = do toMasterHandlerDyn tm getSub route h = do
sub <- getSub sub <- getSub
withReaderT (handlerSubData tm (const sub) route) h withReaderT (handlerSubData tm (const sub) route) h
@ -258,8 +259,8 @@ instance (anySub ~ anySub'
toMasterHandlerMaybe :: (Route sub -> Route master) toMasterHandlerMaybe :: (Route sub -> Route master)
-> (master -> sub) -> (master -> sub)
-> Maybe (Route sub) -> Maybe (Route sub)
-> GGHandler sub master mo a -> GHandlerT sub master mo a
-> GGHandler sub' master mo a -> GHandlerT sub' master mo a
toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route) toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
-- | A generic handler monad, which can have a different subsite and master -- | A generic handler monad, which can have a different subsite and master
@ -267,9 +268,9 @@ toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
-- special responses. It is declared as a newtype to make compiler errors more -- special responses. It is declared as a newtype to make compiler errors more
-- readable. -- readable.
type GGHandler sub master = ReaderT (HandlerData sub master) type GHandlerT sub master = ReaderT (HandlerData sub master)
type GHandler sub master = GGHandler sub master (Iteratee ByteString IO) type GHandler sub master = GHandlerT sub master (ResourceT IO)
data GHState = GHState data GHState = GHState
{ ghsSession :: SessionMap { ghsSession :: SessionMap
@ -290,7 +291,7 @@ newtype YesodApp = YesodApp
-> Request -> Request
-> [ContentType] -> [ContentType]
-> SessionMap -> SessionMap
-> Iteratee ByteString IO YesodAppResult -> ResourceT IO YesodAppResult
} }
data YesodAppResult data YesodAppResult
@ -310,10 +311,10 @@ instance Show HandlerContents where
show _ = "Cannot show a HandlerContents" show _ = "Cannot show a HandlerContents"
instance Exception HandlerContents instance Exception HandlerContents
getRequest :: Monad mo => GGHandler s m mo Request getRequest :: Monad mo => GHandlerT s m mo Request
getRequest = handlerRequest `liftM` ask getRequest = handlerRequest `liftM` ask
instance MonadIO monad => Failure ErrorResponse (GGHandler sub master monad) where instance MonadIO monad => Failure ErrorResponse (GHandlerT sub master monad) where
failure = liftIO . throwIO . HCError failure = liftIO . throwIO . HCError
runRequestBody :: GHandler s m RequestBodyContents runRequestBody :: GHandler s m RequestBodyContents
@ -327,9 +328,9 @@ runRequestBody = do
put x { ghsRBC = Just rbc } put x { ghsRBC = Just rbc }
return rbc return rbc
rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents rbHelper :: W.Request -> ResourceT IO RequestBodyContents
rbHelper req = rbHelper req =
(map fix1 *** map fix2) <$> iter (map fix1 *** map fix2) <$> (requestBody req $$ iter)
where where
iter = NWP.parseRequestBody NWP.lbsSink req iter = NWP.parseRequestBody NWP.lbsSink req
fix1 = go *** go fix1 = go *** go
@ -338,15 +339,15 @@ rbHelper req =
go = decodeUtf8With lenientDecode go = decodeUtf8With lenientDecode
-- | Get the sub application argument. -- | Get the sub application argument.
getYesodSub :: Monad m => GGHandler sub master m sub getYesodSub :: Monad m => GHandlerT sub master m sub
getYesodSub = handlerSub `liftM` ask getYesodSub = handlerSub `liftM` ask
-- | Get the master site appliation argument. -- | Get the master site appliation argument.
getYesod :: Monad m => GGHandler sub master m master getYesod :: Monad m => GHandlerT sub master m master
getYesod = handlerMaster `liftM` ask getYesod = handlerMaster `liftM` ask
-- | Get the URL rendering function. -- | Get the URL rendering function.
getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text) getUrlRender :: Monad m => GHandlerT sub master m (Route master -> Text)
getUrlRender = do getUrlRender = do
x <- handlerRender `liftM` ask x <- handlerRender `liftM` ask
return $ flip x [] return $ flip x []
@ -354,17 +355,17 @@ getUrlRender = do
-- | The URL rendering function with query-string parameters. -- | The URL rendering function with query-string parameters.
getUrlRenderParams getUrlRenderParams
:: Monad m :: Monad m
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text) => GHandlerT sub master m (Route master -> [(Text, Text)] -> Text)
getUrlRenderParams = handlerRender `liftM` ask getUrlRenderParams = handlerRender `liftM` ask
-- | Get the route requested by the user. If this is a 404 response- where the -- | 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'. -- user requested an invalid route- this function will return 'Nothing'.
getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub)) getCurrentRoute :: Monad m => GHandlerT sub master m (Maybe (Route sub))
getCurrentRoute = handlerRoute `liftM` ask getCurrentRoute = handlerRoute `liftM` ask
-- | Get the function to promote a route for a subsite to a route for the -- | Get the function to promote a route for a subsite to a route for the
-- master site. -- master site.
getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master) getRouteToMaster :: Monad m => GHandlerT sub master m (Route sub -> Route master)
getRouteToMaster = handlerToMaster `liftM` ask getRouteToMaster = handlerToMaster `liftM` ask
-- | Function used internally by Yesod in the process of converting a -- | Function used internally by Yesod in the process of converting a
@ -399,7 +400,7 @@ runHandler handler mrender sroute tomr master sub =
, handlerToMaster = tomr , handlerToMaster = tomr
, handlerState = istate , handlerState = istate
} }
contents' <- catchIter (fmap Right $ runReaderT handler hd) contents' <- catch (fmap Right $ runReaderT handler hd)
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
$ fromException e) $ fromException e)
state <- liftIO $ I.readIORef istate state <- liftIO $ I.readIORef istate
@ -425,7 +426,7 @@ runHandler handler mrender sroute tomr master sub =
return $ YARPlain return $ YARPlain
(getRedirectStatus rt $ reqWaiRequest rr) hs typePlain emptyContent (getRedirectStatus rt $ reqWaiRequest rr) hs typePlain emptyContent
finalSession finalSession
HCSendFile ct fp p -> catchIter HCSendFile ct fp p -> catch
(sendFile' ct fp p) (sendFile' ct fp p)
(handleError . toErrorHandler) (handleError . toErrorHandler)
HCCreated loc -> do HCCreated loc -> do
@ -449,19 +450,19 @@ safeEh er = YesodApp $ \_ _ _ session -> do
session session
-- | Redirect to the given route. -- | Redirect to the given route.
redirect :: MonadIO mo => RedirectType -> Route master -> GGHandler sub master mo a redirect :: MonadIO mo => RedirectType -> Route master -> GHandlerT sub master mo a
redirect rt url = redirectParams rt url [] redirect rt url = redirectParams rt url []
-- | Redirects to the given route with the associated query-string parameters. -- | Redirects to the given route with the associated query-string parameters.
redirectParams :: MonadIO mo redirectParams :: MonadIO mo
=> RedirectType -> Route master -> [(Text, Text)] => RedirectType -> Route master -> [(Text, Text)]
-> GGHandler sub master mo a -> GHandlerT sub master mo a
redirectParams rt url params = do redirectParams rt url params = do
r <- getUrlRenderParams r <- getUrlRenderParams
redirectString rt $ r url params redirectString rt $ r url params
-- | Redirect to the given URL. -- | Redirect to the given URL.
redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GGHandler sub master mo a redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GHandlerT sub master mo a
redirectText rt = liftIO . throwIO . HCRedirect rt redirectText rt = liftIO . throwIO . HCRedirect rt
redirectString = redirectText redirectString = redirectText
{-# DEPRECATED redirectString "Use redirectText instead" #-} {-# DEPRECATED redirectString "Use redirectText instead" #-}
@ -473,16 +474,16 @@ ultDestKey = "_ULT"
-- --
-- An ultimate destination is stored in the user session and can be loaded -- An ultimate destination is stored in the user session and can be loaded
-- later by 'redirectUltDest'. -- later by 'redirectUltDest'.
setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo () setUltDest :: MonadIO mo => Route master -> GHandlerT sub master mo ()
setUltDest dest = do setUltDest dest = do
render <- getUrlRender render <- getUrlRender
setUltDestString $ render dest setUltDestString $ render dest
-- | Same as 'setUltDest', but use the given string. -- | Same as 'setUltDest', but use the given string.
setUltDestText :: MonadIO mo => Text -> GGHandler sub master mo () setUltDestText :: MonadIO mo => Text -> GHandlerT sub master mo ()
setUltDestText = setSession ultDestKey setUltDestText = setSession ultDestKey
setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo () setUltDestString :: MonadIO mo => Text -> GHandlerT sub master mo ()
setUltDestString = setSession ultDestKey setUltDestString = setSession ultDestKey
{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-} {-# DEPRECATED setUltDestString "Use setUltDestText instead" #-}
@ -490,7 +491,7 @@ setUltDestString = setSession ultDestKey
-- --
-- If this is a 404 handler, there is no current page, and then this call does -- If this is a 404 handler, there is no current page, and then this call does
-- nothing. -- nothing.
setUltDest' :: MonadIO mo => GGHandler sub master mo () setUltDest' :: MonadIO mo => GHandlerT sub master mo ()
setUltDest' = do setUltDest' = do
route <- getCurrentRoute route <- getCurrentRoute
case route of case route of
@ -504,7 +505,7 @@ setUltDest' = do
-- | Sets the ultimate destination to the referer request header, if present. -- | Sets the ultimate destination to the referer request header, if present.
-- --
-- This function will not overwrite an existing ultdest. -- This function will not overwrite an existing ultdest.
setUltDestReferer :: MonadIO mo => GGHandler sub master mo () setUltDestReferer :: MonadIO mo => GHandlerT sub master mo ()
setUltDestReferer = do setUltDestReferer = do
mdest <- lookupSession ultDestKey mdest <- lookupSession ultDestKey
maybe maybe
@ -521,14 +522,14 @@ setUltDestReferer = do
redirectUltDest :: MonadIO mo redirectUltDest :: MonadIO mo
=> RedirectType => RedirectType
-> Route master -- ^ default destination if nothing in session -> Route master -- ^ default destination if nothing in session
-> GGHandler sub master mo a -> GHandlerT sub master mo a
redirectUltDest rt def = do redirectUltDest rt def = do
mdest <- lookupSession ultDestKey mdest <- lookupSession ultDestKey
deleteSession ultDestKey deleteSession ultDestKey
maybe (redirect rt def) (redirectText rt) mdest maybe (redirect rt def) (redirectText rt) mdest
-- | Remove a previously set ultimate destination. See 'setUltDest'. -- | Remove a previously set ultimate destination. See 'setUltDest'.
clearUltDest :: MonadIO mo => GGHandler sub master mo () clearUltDest :: MonadIO mo => GHandlerT sub master mo ()
clearUltDest = deleteSession ultDestKey clearUltDest = deleteSession ultDestKey
msgKey :: Text msgKey :: Text
@ -537,13 +538,13 @@ msgKey = "_MSG"
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessage :: MonadIO mo => Html -> GGHandler sub master mo () setMessage :: MonadIO mo => Html -> GHandlerT sub master mo ()
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler sub y mo () setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GHandlerT sub y mo ()
setMessageI msg = do setMessageI msg = do
mr <- getMessageRender mr <- getMessageRender
setMessage $ toHtml $ mr msg setMessage $ toHtml $ mr msg
@ -552,7 +553,7 @@ setMessageI msg = do
-- variable. -- variable.
-- --
-- See 'setMessage'. -- See 'setMessage'.
getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html) getMessage :: MonadIO mo => GHandlerT sub master mo (Maybe Html)
getMessage = do getMessage = do
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey deleteSession msgKey
@ -562,7 +563,7 @@ getMessage = do
-- --
-- For some backends, this is more efficient than reading in the file to -- 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. -- memory, since they can optimize file sending via a system call to sendfile.
sendFile :: MonadIO mo => ContentType -> FilePath -> GGHandler sub master mo a sendFile :: MonadIO mo => ContentType -> FilePath -> GHandlerT sub master mo a
sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
-- | Same as 'sendFile', but only sends part of a file. -- | Same as 'sendFile', but only sends part of a file.
@ -571,25 +572,25 @@ sendFilePart :: MonadIO mo
-> FilePath -> FilePath
-> Integer -- ^ offset -> Integer -- ^ offset
-> Integer -- ^ count -> Integer -- ^ count
-> GGHandler sub master mo a -> GHandlerT sub master mo a
sendFilePart ct fp off count = sendFilePart ct fp off count =
liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
-- | Bypass remaining handler code and output the given content with a 200 -- | Bypass remaining handler code and output the given content with a 200
-- status code. -- status code.
sendResponse :: (MonadIO mo, HasReps c) => c -> GGHandler sub master mo a sendResponse :: (MonadIO mo, HasReps c) => c -> GHandlerT sub master mo a
sendResponse = liftIO . throwIO . HCContent H.status200 sendResponse = liftIO . throwIO . HCContent H.status200
. chooseRep . chooseRep
-- | Bypass remaining handler code and output the given content with the given -- | Bypass remaining handler code and output the given content with the given
-- status code. -- status code.
sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GGHandler s m mo a sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GHandlerT s m mo a
sendResponseStatus s = liftIO . throwIO . HCContent s sendResponseStatus s = liftIO . throwIO . HCContent s
. chooseRep . chooseRep
-- | Send a 201 "Created" response with the given route as the Location -- | Send a 201 "Created" response with the given route as the Location
-- response header. -- response header.
sendResponseCreated :: MonadIO mo => Route m -> GGHandler s m mo a sendResponseCreated :: MonadIO mo => Route m -> GHandlerT s m mo a
sendResponseCreated url = do sendResponseCreated url = do
r <- getUrlRender r <- getUrlRender
liftIO . throwIO $ HCCreated $ r url liftIO . throwIO $ HCCreated $ r url
@ -599,7 +600,7 @@ sendResponseCreated url = do
-- that you have already specified. This function short-circuits. It should be -- 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, -- considered only for very specific needs. If you are not sure if you need it,
-- you don't. -- you don't.
sendWaiResponse :: MonadIO mo => W.Response -> GGHandler s m mo b sendWaiResponse :: MonadIO mo => W.Response -> GHandlerT s m mo b
sendWaiResponse = liftIO . throwIO . HCWai sendWaiResponse = liftIO . throwIO . HCWai
-- | Return a 404 not found page. Also denotes no handler available. -- | Return a 404 not found page. Also denotes no handler available.
@ -607,7 +608,7 @@ notFound :: Failure ErrorResponse m => m a
notFound = failure NotFound notFound = failure NotFound
-- | Return a 405 method not supported page. -- | Return a 405 method not supported page.
badMethod :: MonadIO mo => GGHandler s m mo a badMethod :: MonadIO mo => GHandlerT s m mo a
badMethod = do badMethod = do
w <- waiRequest w <- waiRequest
failure $ BadMethod $ W.requestMethod w failure $ BadMethod $ W.requestMethod w
@ -617,7 +618,7 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a
permissionDenied = failure . PermissionDenied permissionDenied = failure . PermissionDenied
-- | Return a 403 permission denied page. -- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler s y mo a permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GHandlerT s y mo a
permissionDeniedI msg = do permissionDeniedI msg = do
mr <- getMessageRender mr <- getMessageRender
permissionDenied $ mr msg permissionDenied $ mr msg
@ -627,7 +628,7 @@ invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs invalidArgs = failure . InvalidArgs
-- | Return a 400 invalid arguments page. -- | Return a 400 invalid arguments page.
invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GGHandler s y mo a invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GHandlerT s y mo a
invalidArgsI msg = do invalidArgsI msg = do
mr <- getMessageRender mr <- getMessageRender
invalidArgs $ map mr msg invalidArgs $ map mr msg
@ -638,26 +639,26 @@ setCookie :: MonadIO mo
=> Int -- ^ minutes to timeout => Int -- ^ minutes to timeout
-> H.Ascii -- ^ key -> H.Ascii -- ^ key
-> H.Ascii -- ^ value -> H.Ascii -- ^ value
-> GGHandler sub master mo () -> GHandlerT sub master mo ()
setCookie a b = addHeader . AddCookie a b setCookie a b = addHeader . AddCookie a b
-- | Unset the cookie on the client. -- | Unset the cookie on the client.
deleteCookie :: MonadIO mo => H.Ascii -> GGHandler sub master mo () deleteCookie :: MonadIO mo => H.Ascii -> GHandlerT sub master mo ()
deleteCookie = addHeader . DeleteCookie deleteCookie = addHeader . DeleteCookie
-- | Set the language in the user session. Will show up in 'languages' on the -- | Set the language in the user session. Will show up in 'languages' on the
-- next request. -- next request.
setLanguage :: MonadIO mo => Text -> GGHandler sub master mo () setLanguage :: MonadIO mo => Text -> GHandlerT sub master mo ()
setLanguage = setSession langKey setLanguage = setSession langKey
-- | Set an arbitrary response header. -- | Set an arbitrary response header.
setHeader :: MonadIO mo setHeader :: MonadIO mo
=> CI H.Ascii -> H.Ascii -> GGHandler sub master mo () => CI H.Ascii -> H.Ascii -> GHandlerT sub master mo ()
setHeader a = addHeader . Header a setHeader a = addHeader . Header a
-- | Set the Cache-Control header to indicate this response should be cached -- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds. -- for the given number of seconds.
cacheSeconds :: MonadIO mo => Int -> GGHandler s m mo () cacheSeconds :: MonadIO mo => Int -> GHandlerT s m mo ()
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
[ "max-age=" [ "max-age="
, show i , show i
@ -666,16 +667,16 @@ cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
-- | Set the Expires header to some date in 2037. In other words, this content -- | Set the Expires header to some date in 2037. In other words, this content
-- is never (realistically) expired. -- is never (realistically) expired.
neverExpires :: MonadIO mo => GGHandler s m mo () neverExpires :: MonadIO mo => GHandlerT s m mo ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
-- | Set an Expires header in the past, meaning this content should not be -- | Set an Expires header in the past, meaning this content should not be
-- cached. -- cached.
alreadyExpired :: MonadIO mo => GGHandler s m mo () alreadyExpired :: MonadIO mo => GHandlerT s m mo ()
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date. -- | Set an Expires header to the given date.
expiresAt :: MonadIO mo => UTCTime -> GGHandler s m mo () expiresAt :: MonadIO mo => UTCTime -> GHandlerT s m mo ()
expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123 expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
-- | Set a variable in the user's session. -- | Set a variable in the user's session.
@ -686,18 +687,18 @@ expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
setSession :: MonadIO mo setSession :: MonadIO mo
=> Text -- ^ key => Text -- ^ key
-> Text -- ^ value -> Text -- ^ value
-> GGHandler sub master mo () -> GHandlerT sub master mo ()
setSession k = modify . modSession . Map.insert k setSession k = modify . modSession . Map.insert k
-- | Unsets a session variable. See 'setSession'. -- | Unsets a session variable. See 'setSession'.
deleteSession :: MonadIO mo => Text -> GGHandler sub master mo () deleteSession :: MonadIO mo => Text -> GHandlerT sub master mo ()
deleteSession = modify . modSession . Map.delete deleteSession = modify . modSession . Map.delete
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x } modSession f x = x { ghsSession = f $ ghsSession x }
-- | Internal use only, not to be confused with 'setHeader'. -- | Internal use only, not to be confused with 'setHeader'.
addHeader :: MonadIO mo => Header -> GGHandler sub master mo () addHeader :: MonadIO mo => Header -> GHandlerT sub master mo ()
addHeader = tell . Endo . (:) addHeader = tell . Endo . (:)
getStatus :: ErrorResponse -> H.Status getStatus :: ErrorResponse -> H.Status
@ -720,18 +721,18 @@ data RedirectType = RedirectPermanent
| RedirectSeeOther | RedirectSeeOther
deriving (Show, Eq) deriving (Show, Eq)
localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a localNoCurrent :: Monad mo => GHandlerT s m mo a -> GHandlerT s m mo a
localNoCurrent = localNoCurrent =
local (\hd -> hd { handlerRoute = Nothing }) local (\hd -> hd { handlerRoute = Nothing })
-- | Lookup for session data. -- | Lookup for session data.
lookupSession :: MonadIO mo => Text -> GGHandler s m mo (Maybe Text) lookupSession :: MonadIO mo => Text -> GHandlerT s m mo (Maybe Text)
lookupSession n = do lookupSession n = do
m <- liftM ghsSession get m <- liftM ghsSession get
return $ Map.lookup n m return $ Map.lookup n m
-- | Get all session variables. -- | Get all session variables.
getSession :: MonadIO mo => GGHandler s m mo SessionMap getSession :: MonadIO mo => GHandlerT s m mo SessionMap
getSession = liftM ghsSession get getSession = liftM ghsSession get
handlerToYAR :: (HasReps a, HasReps b) handlerToYAR :: (HasReps a, HasReps b)
@ -744,7 +745,7 @@ handlerToYAR :: (HasReps a, HasReps b)
-> Maybe (Route s) -> Maybe (Route s)
-> SessionMap -> SessionMap
-> GHandler s m b -> GHandler s m b
-> Iteratee ByteString IO YesodAppResult -> ResourceT IO YesodAppResult
handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h = handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
unYesodApp ya eh' rr types sessionMap unYesodApp ya eh' rr types sessionMap
where where
@ -766,8 +767,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
let hs' = maybe finalHeaders finalHeaders' mlen let hs' = maybe finalHeaders finalHeaders' mlen
in W.ResponseBuilder s hs' b in W.ResponseBuilder s hs' b
ContentFile fp p -> W.ResponseFile s finalHeaders fp p ContentFile fp p -> W.ResponseFile s finalHeaders fp p
ContentEnum e -> ContentSource body -> W.ResponseSource s finalHeaders body
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
where where
finalHeaders = renderHeaders hs ct sessionFinal finalHeaders = renderHeaders hs ct sessionFinal
finalHeaders' len = ("Content-Length", S8.pack $ show len) finalHeaders' len = ("Content-Length", S8.pack $ show len)
@ -822,7 +822,7 @@ headerToPair cp _ (DeleteCookie key) =
headerToPair _ _ (Header key value) = (key, value) headerToPair _ _ (Header key value) = (key, value)
-- | Get a unique identifier. -- | Get a unique identifier.
newIdent :: MonadIO mo => GGHandler sub master mo String -- FIXME use Text newIdent :: MonadIO mo => GHandlerT sub master mo String -- FIXME use Text
newIdent = do newIdent = do
x <- get x <- get
let i' = ghsIdent x + 1 let i' = ghsIdent x + 1
@ -830,8 +830,8 @@ newIdent = do
return $ 'h' : show i' return $ 'h' : show i'
liftIOHandler :: MonadIO mo liftIOHandler :: MonadIO mo
=> GGHandler sub master IO a => GHandlerT sub master IO a
-> GGHandler sub master mo a -> GHandlerT sub master mo a
liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
-- | Redirect to a POST resource. -- | Redirect to a POST resource.
@ -840,7 +840,7 @@ liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
-- POST form, and some Javascript to automatically submit the form. This can be -- 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 -- useful when you need to post a plain link somewhere that needs to cause
-- changes on the server. -- changes on the server.
redirectToPost :: MonadIO mo => Route master -> GGHandler sub master mo a redirectToPost :: MonadIO mo => Route master -> GHandlerT sub master mo a
redirectToPost dest = hamletToRepHtml redirectToPost dest = hamletToRepHtml
#if GHC7 #if GHC7
[hamlet| [hamlet|
@ -862,35 +862,35 @@ redirectToPost dest = hamletToRepHtml
-- | Converts the given Hamlet template into 'Content', which can be used in a -- | Converts the given Hamlet template into 'Content', which can be used in a
-- Yesod 'Response'. -- Yesod 'Response'.
hamletToContent :: Monad mo hamletToContent :: Monad mo
=> HtmlUrl (Route master) -> GGHandler sub master mo Content => HtmlUrl (Route master) -> GHandlerT sub master mo Content
hamletToContent h = do hamletToContent h = do
render <- getUrlRenderParams render <- getUrlRenderParams
return $ toContent $ h render return $ toContent $ h render
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: Monad mo hamletToRepHtml :: Monad mo
=> HtmlUrl (Route master) -> GGHandler sub master mo RepHtml => HtmlUrl (Route master) -> GHandlerT sub master mo RepHtml
hamletToRepHtml = liftM RepHtml . hamletToContent hamletToRepHtml = liftM RepHtml . hamletToContent
-- | Get the request\'s 'W.Request' value. -- | Get the request\'s 'W.Request' value.
waiRequest :: Monad mo => GGHandler sub master mo W.Request waiRequest :: Monad mo => GHandlerT sub master mo W.Request
waiRequest = reqWaiRequest `liftM` getRequest waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (Monad mo, RenderMessage master message) => GGHandler s master mo (message -> Text) getMessageRender :: (Monad mo, RenderMessage master message) => GHandlerT s master mo (message -> Text)
getMessageRender = do getMessageRender = do
m <- getYesod m <- getYesod
l <- reqLangs `liftM` getRequest l <- reqLangs `liftM` getRequest
return $ renderMessage m l return $ renderMessage m l
cacheLookup :: MonadIO mo => CacheKey a -> GGHandler sub master mo (Maybe a) cacheLookup :: MonadIO mo => CacheKey a -> GHandlerT sub master mo (Maybe a)
cacheLookup k = do cacheLookup k = do
gs <- get gs <- get
return $ Cache.lookup k $ ghsCache gs return $ Cache.lookup k $ ghsCache gs
cacheInsert :: MonadIO mo => CacheKey a -> a -> GGHandler sub master mo () cacheInsert :: MonadIO mo => CacheKey a -> a -> GHandlerT sub master mo ()
cacheInsert k v = modify $ \gs -> cacheInsert k v = modify $ \gs ->
gs { ghsCache = Cache.insert k v $ ghsCache gs } gs { ghsCache = Cache.insert k v $ ghsCache gs }
cacheDelete :: MonadIO mo => CacheKey a -> GGHandler sub master mo () cacheDelete :: MonadIO mo => CacheKey a -> GHandlerT sub master mo ()
cacheDelete k = modify $ \gs -> cacheDelete k = modify $ \gs ->
gs { ghsCache = Cache.delete k $ ghsCache gs } gs { ghsCache = Cache.delete k $ ghsCache gs }

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

@ -281,7 +281,7 @@ class RenderRoute (Route a) => Yesod a where
yepnopeJs _ = Nothing yepnopeJs _ = Nothing
messageLoggerHandler :: (Yesod m, MonadIO mo) messageLoggerHandler :: (Yesod m, MonadIO mo)
=> Loc -> LogLevel -> Text -> GGHandler s m mo () => Loc -> LogLevel -> Text -> GHandlerT s m mo ()
messageLoggerHandler loc level msg = do messageLoggerHandler loc level msg = do
y <- getYesod y <- getYesod
liftIO $ messageLogger y loc level msg liftIO $ messageLogger y loc level msg

12
yesod-core/Yesod/Internal/Dispatch.hs
View File

@ -30,7 +30,7 @@ import qualified Data.Text
Alright, let's explain how routing works. We want to take a [String] and found Alright, let's explain how routing works. We want to take a [String] and found
out which route it applies to. For static pieces, we need to ensure an exact out which route it applies to. For static pieces, we need to ensure an exact
match against the segment. For a single or multi piece, we need to check the match against the segment. For a single or multi piece, we need to check the
result of fromSinglePiece/fromMultiPiece, respectively. result of fromPathPiece/fromMultiPathPiece, respectively.
We want to create a tree of case statements basically resembling: We want to create a tree of case statements basically resembling:
@ -51,7 +51,7 @@ case segments of
case as of case as of
[] -> Nothing [] -> Nothing
b:bs -> b:bs ->
case fromSinglePiece b of case fromPathPiece b of
Left _ -> Nothing Left _ -> Nothing
Right name -> Right name ->
case bs of case bs of
@ -59,7 +59,7 @@ case segments of
case cs of case cs of
[] -> Nothing [] -> Nothing
d:ds -> d:ds ->
case fromSinglePiece d of case fromPathPiece d of
Left _ -> Nothing Left _ -> Nothing
Right age -> Right age ->
case ds of case ds of
@ -219,7 +219,7 @@ mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|] nothing <- [|Nothing|]
next <- newName "next" next <- newName "next"
fsp <- [|fromSinglePiece|] fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next) let exp' = CaseE (fsp `AppE` VarE next)
[ Match [ Match
(ConP (mkName "Nothing") []) (ConP (mkName "Nothing") [])
@ -243,7 +243,7 @@ mkSimpleExp segments [MultiPiece _] frontVars x = do
srest <- [|[]|] srest <- [|[]|]
innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|] nothing <- [|Nothing|]
fmp <- [|fromMultiPiece|] fmp <- [|fromPathMultiPiece|]
let exp = CaseE (fmp `AppE` segments) let exp = CaseE (fmp `AppE` segments)
[ Match [ Match
(ConP (mkName "Nothing") []) (ConP (mkName "Nothing") [])
@ -301,7 +301,7 @@ mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|] nothing <- [|Nothing|]
next <- newName "next" next <- newName "next"
fsp <- [|fromSinglePiece|] fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next) let exp' = CaseE (fsp `AppE` VarE next)
[ Match [ Match
(ConP (mkName "Nothing") []) (ConP (mkName "Nothing") [])

8
yesod-core/Yesod/Internal/RouteParsing.hs
View File

@ -85,7 +85,7 @@ createParse res = do
mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp) mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
mkPat' be [MultiPiece s] parse = do mkPat' be [MultiPiece s] parse = do
v <- newName $ "var" ++ s v <- newName $ "var" ++ s
fmp <- [|fromMultiPiece|] fmp <- [|fromPathMultiPiece|]
let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
return ([VarP v], parse') return ([VarP v], parse')
mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last" mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
@ -94,7 +94,7 @@ createParse res = do
let sp = LitP $ StringL s let sp = LitP $ StringL s
return (sp : x, parse') return (sp : x, parse')
mkPat' be (SinglePiece s:rest) parse = do mkPat' be (SinglePiece s:rest) parse = do
fsp <- [|fromSinglePiece|] fsp <- [|fromPathPiece|]
v <- newName $ "var" ++ s v <- newName $ "var" ++ s
let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
(x, parse'') <- mkPat' be rest parse' (x, parse'') <- mkPat' be rest parse'
@ -137,13 +137,13 @@ createRender = mapM go
return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs' return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
mkBod ((i, SinglePiece _):xs) = do mkBod ((i, SinglePiece _):xs) = do
let x' = VarE $ mkName $ "var" ++ show i let x' = VarE $ mkName $ "var" ++ show i
tsp <- [|toSinglePiece|] tsp <- [|toPathPiece|]
let x'' = tsp `AppE` x' let x'' = tsp `AppE` x'
xs' <- mkBod xs xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` x'' `AppE` xs' return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
mkBod ((i, MultiPiece _):_) = do mkBod ((i, MultiPiece _):_) = do
let x' = VarE $ mkName $ "var" ++ show i let x' = VarE $ mkName $ "var" ++ show i
tmp <- [|toMultiPiece|] tmp <- [|toPathMultiPiece|]
return $ tmp `AppE` x' return $ tmp `AppE` x'
-- | Whether the set of resources cover all possible URLs. -- | Whether the set of resources cover all possible URLs.

16
yesod-core/Yesod/Internal/TestApi.hs
View File

@ -6,22 +6,6 @@
-- --
module Yesod.Internal.TestApi module Yesod.Internal.TestApi
( randomString, parseWaiRequest' ( randomString, parseWaiRequest'
, catchIter
) where ) where
import Yesod.Internal.Request (randomString, parseWaiRequest') import Yesod.Internal.Request (randomString, parseWaiRequest')
import Control.Exception (Exception, catch)
import Data.Enumerator (Iteratee (..), Step (..))
import Data.ByteString (ByteString)
import Prelude hiding (catch)
catchIter :: Exception e
=> Iteratee ByteString IO a
-> (e -> Iteratee ByteString IO a)
-> Iteratee ByteString IO a
catchIter (Iteratee mstep) f = Iteratee $ do
step <- mstep `catch` (runIteratee . f)
return $ case step of
Continue k -> Continue $ \s -> catchIter (k s) f
Yield b s -> Yield b s
Error e -> Error e

10
yesod-core/Yesod/Request.hs
View File

@ -52,20 +52,20 @@ import Data.Text (Text)
-- * Accept-Language HTTP header. -- * Accept-Language HTTP header.
-- --
-- This is handled by parseWaiRequest (not exposed). -- This is handled by parseWaiRequest (not exposed).
languages :: Monad mo => GGHandler s m mo [Text] languages :: Monad mo => GHandlerT s m mo [Text]
languages = reqLangs `liftM` getRequest languages = reqLangs `liftM` getRequest
lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' :: Eq a => a -> [(a, b)] -> [b]
lookup' a = map snd . filter (\x -> a == fst x) lookup' a = map snd . filter (\x -> a == fst x)
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParams :: Monad mo => Text -> GGHandler s m mo [Text] lookupGetParams :: Monad mo => Text -> GHandlerT s m mo [Text]
lookupGetParams pn = do lookupGetParams pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqGetParams rr return $ lookup' pn $ reqGetParams rr
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParam :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupGetParam :: Monad mo => Text -> GHandlerT s m mo (Maybe Text)
lookupGetParam = liftM listToMaybe . lookupGetParams lookupGetParam = liftM listToMaybe . lookupGetParams
-- | Lookup for POST parameters. -- | Lookup for POST parameters.
@ -91,11 +91,11 @@ lookupFiles pn = do
return $ lookup' pn files return $ lookup' pn files
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookie :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupCookie :: Monad mo => Text -> GHandlerT s m mo (Maybe Text)
lookupCookie = liftM listToMaybe . lookupCookies lookupCookie = liftM listToMaybe . lookupCookies
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookies :: Monad mo => Text -> GGHandler s m mo [Text] lookupCookies :: Monad mo => Text -> GHandlerT s m mo [Text]
lookupCookies pn = do lookupCookies pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqCookies rr return $ lookup' pn $ reqCookies rr

10
yesod-core/Yesod/Widget.hs
View File

@ -64,7 +64,7 @@ import Text.Cassius
import Text.Julius import Text.Julius
import Text.Coffee import Text.Coffee
import Yesod.Handler import Yesod.Handler
(Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod (Route, GHandler, GHandlerT, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender, getUrlRenderParams , getMessageRender, getUrlRenderParams
) )
import Yesod.Message (RenderMessage) import Yesod.Message (RenderMessage)
@ -189,7 +189,7 @@ setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempt
-- | Set the page title. Calling 'setTitle' multiple times overrides previously -- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values. -- set values.
setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GGHandler sub master m) () setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GHandlerT sub master m) ()
setTitleI msg = do setTitleI msg = do
mr <- lift getMessageRender mr <- lift getMessageRender
setTitle $ toHtml $ mr msg setTitle $ toHtml $ mr msg
@ -280,7 +280,7 @@ addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavasc
-- | Add Coffesscript to the page's script tag. Requires the coffeescript -- | Add Coffesscript to the page's script tag. Requires the coffeescript
-- executable to be present at runtime. -- executable to be present at runtime.
addCoffee :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) () addCoffee :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GHandlerT sub master m) ()
addCoffee c = do addCoffee c = do
render <- lift getUrlRenderParams render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c t <- liftIO $ renderCoffee render c
@ -288,7 +288,7 @@ addCoffee c = do
-- | Add a new script tag to the body with the contents of this Coffesscript -- | Add a new script tag to the body with the contents of this Coffesscript
-- template. Requires the coffeescript executable to be present at runtime. -- template. Requires the coffeescript executable to be present at runtime.
addCoffeeBody :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) () addCoffeeBody :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GHandlerT sub master m) ()
addCoffeeBody c = do addCoffeeBody c = do
render <- lift getUrlRenderParams render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c t <- liftIO $ renderCoffee render c
@ -338,7 +338,7 @@ rules = do
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: (Monad mo, RenderMessage master message) ihamletToRepHtml :: (Monad mo, RenderMessage master message)
=> HtmlUrlI18n message (Route master) => HtmlUrlI18n message (Route master)
-> GGHandler sub master mo RepHtml -> GHandlerT sub master mo RepHtml
ihamletToRepHtml ih = do ihamletToRepHtml ih = do
urender <- getUrlRenderParams urender <- getUrlRenderParams
mrender <- getMessageRender mrender <- getMessageRender

13
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -11,10 +11,6 @@ import Network.Wai.Test
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Yesod.Internal.TestApi
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import Control.Exception (SomeException)
data App = App data App = App
@ -61,7 +57,6 @@ errorHandlingTest = describe "Test.ErrorHandling"
[ it "says not found" caseNotFound [ it "says not found" caseNotFound
, it "says 'There was an error' before runRequestBody" caseBefore , it "says 'There was an error' before runRequestBody" caseBefore
, it "says 'There was an error' after runRequestBody" caseAfter , it "says 'There was an error' after runRequestBody" caseAfter
, it "catchIter handles internal exceptions" caseCatchIter
] ]
runner :: Session () -> IO () runner :: Session () -> IO ()
@ -101,11 +96,3 @@ caseAfter = runner $ do
} }
assertStatus 500 res assertStatus 500 res
assertBodyContains "bin12345" res assertBodyContains "bin12345" res
caseCatchIter :: IO ()
caseCatchIter = E.run_ $ E.enumList 8 (replicate 1000 "foo") E.$$ flip catchIter ignorer $ do
_ <- EL.consume
error "foo"
where
ignorer :: SomeException -> E.Iteratee a IO ()
ignorer _ = return ()

1
yesod-core/test/YesodCoreTest/YesodTest.hs
View File

@ -6,7 +6,6 @@ module YesodCoreTest.YesodTest
, module Network.Wai , module Network.Wai
, module Network.Wai.Test , module Network.Wai.Test
, module Test.Hspec , module Test.Hspec
, module Test.Hspec.HUnit
) where ) where
import Yesod.Core hiding (Request) import Yesod.Core hiding (Request)

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

@ -79,6 +79,8 @@ library
, aeson >= 0.5 , aeson >= 0.5
, fast-logger >= 0.0.1 , fast-logger >= 0.0.1
, wai-logger >= 0.0.1 , wai-logger >= 0.0.1
, conduit >= 0.0 && < 0.1
, lifted-base >= 0.1 && < 0.2
exposed-modules: Yesod.Content exposed-modules: Yesod.Content
Yesod.Core Yesod.Core
@ -115,7 +117,7 @@ test-suite tests
main-is: test.hs main-is: test.hs
cpp-options: -DTEST cpp-options: -DTEST
build-depends: hspec >= 0.8 && < 0.10 build-depends: hspec >= 0.8 && < 0.10
,wai-test >= 0.1.2 && < 0.2 ,wai-test
,wai ,wai
,yesod-core ,yesod-core
,bytestring ,bytestring