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.Lazy.Encoding
import Data.Enumerator (Enumerator)
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import Data.Monoid (mempty)
@ -62,9 +61,10 @@ import Text.Hamlet (Html)
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import Data.String (IsString (fromString))
import Network.Wai (FilePart)
import Data.Conduit (Source)
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)
-- | Zero-length enumerator.

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

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

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

@ -15,8 +15,8 @@ module Yesod.Dispatch
, mkYesodDispatch
, mkYesodSubDispatch
-- ** Path pieces
, SinglePiece (..)
, MultiPiece (..)
, PathPiece (..)
, PathMultiPiece (..)
, Texts
-- * Convert to WAI
, toWaiApp
@ -31,7 +31,7 @@ import Yesod.Handler
import Yesod.Internal.Dispatch
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 Language.Haskell.TH.Syntax

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

@ -28,7 +28,7 @@ module Yesod.Handler
, YesodSubRoute (..)
-- * Handler monad
, GHandler
, GGHandler
, GHandlerT
-- ** Read information from handler
, getYesod
, getYesodSub
@ -148,8 +148,6 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Map as Map
import qualified Data.ByteString as S
import Data.ByteString (ByteString)
import Data.Enumerator (Iteratee (..), run_, ($$))
import Network.Wai.Parse (parseHttpAccept)
import Yesod.Content
@ -165,12 +163,15 @@ import Data.Text (Text)
import Yesod.Message (RenderMessage (..))
import Text.Blaze (toHtml, preEscapedText)
import Yesod.Internal.TestApi (catchIter)
import qualified Yesod.Internal.Cache as Cache
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
import Data.Typeable (Typeable)
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.
type family Route a
@ -206,22 +207,22 @@ handlerSubDataMaybe tm ts route hd = hd
, handlerRoute = route
}
get :: MonadIO monad => GGHandler sub master monad GHState
get :: MonadIO monad => GHandlerT sub master monad GHState
get = do
hd <- ask
liftIO $ I.readIORef $ handlerState hd
put :: MonadIO monad => GHState -> GGHandler sub master monad ()
put :: MonadIO monad => GHState -> GHandlerT sub master monad ()
put g = do
hd <- ask
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
hd <- ask
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 }
-- | 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)
-> (master -> sub)
-> Route sub
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
-> GHandlerT sub master mo a
-> GHandlerT sub' master mo a
toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)
toMasterHandlerDyn :: Monad mo
=> (Route sub -> Route master)
-> GGHandler sub' master mo sub
-> GHandlerT sub' master mo sub
-> Route sub
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
-> GHandlerT sub master mo a
-> GHandlerT sub' master mo a
toMasterHandlerDyn tm getSub route h = do
sub <- getSub
withReaderT (handlerSubData tm (const sub) route) h
@ -258,8 +259,8 @@ instance (anySub ~ anySub'
toMasterHandlerMaybe :: (Route sub -> Route master)
-> (master -> sub)
-> Maybe (Route sub)
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
-> GHandlerT sub master mo a
-> GHandlerT sub' master mo a
toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
-- | 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
-- special responses. It is declared as a newtype to make compiler errors more
-- 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
{ ghsSession :: SessionMap
@ -290,7 +291,7 @@ newtype YesodApp = YesodApp
-> Request
-> [ContentType]
-> SessionMap
-> Iteratee ByteString IO YesodAppResult
-> ResourceT IO YesodAppResult
}
data YesodAppResult
@ -310,10 +311,10 @@ instance Show HandlerContents where
show _ = "Cannot show a HandlerContents"
instance Exception HandlerContents
getRequest :: Monad mo => GGHandler s m mo Request
getRequest :: Monad mo => GHandlerT s m mo Request
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
runRequestBody :: GHandler s m RequestBodyContents
@ -327,9 +328,9 @@ runRequestBody = do
put x { ghsRBC = Just rbc }
return rbc
rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents
rbHelper :: W.Request -> ResourceT IO RequestBodyContents
rbHelper req =
(map fix1 *** map fix2) <$> iter
(map fix1 *** map fix2) <$> (requestBody req $$ iter)
where
iter = NWP.parseRequestBody NWP.lbsSink req
fix1 = go *** go
@ -338,15 +339,15 @@ rbHelper req =
go = decodeUtf8With lenientDecode
-- | 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
-- | 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
-- | 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
x <- handlerRender `liftM` ask
return $ flip x []
@ -354,17 +355,17 @@ getUrlRender = do
-- | The URL rendering function with query-string parameters.
getUrlRenderParams
:: Monad m
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
=> GHandlerT sub master m (Route master -> [(Text, Text)] -> Text)
getUrlRenderParams = handlerRender `liftM` ask
-- | 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 :: Monad m => GGHandler sub master m (Maybe (Route sub))
getCurrentRoute :: Monad m => GHandlerT sub master m (Maybe (Route sub))
getCurrentRoute = handlerRoute `liftM` ask
-- | Get the function to promote a route for a subsite to a route for the
-- 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
-- | Function used internally by Yesod in the process of converting a
@ -399,7 +400,7 @@ runHandler handler mrender sroute tomr master sub =
, handlerToMaster = tomr
, handlerState = istate
}
contents' <- catchIter (fmap Right $ runReaderT handler hd)
contents' <- catch (fmap Right $ runReaderT handler hd)
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
$ fromException e)
state <- liftIO $ I.readIORef istate
@ -425,7 +426,7 @@ runHandler handler mrender sroute tomr master sub =
return $ YARPlain
(getRedirectStatus rt $ reqWaiRequest rr) hs typePlain emptyContent
finalSession
HCSendFile ct fp p -> catchIter
HCSendFile ct fp p -> catch
(sendFile' ct fp p)
(handleError . toErrorHandler)
HCCreated loc -> do
@ -449,19 +450,19 @@ safeEh er = YesodApp $ \_ _ _ session -> do
session
-- | 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 []
-- | Redirects to the given route with the associated query-string parameters.
redirectParams :: MonadIO mo
=> RedirectType -> Route master -> [(Text, Text)]
-> GGHandler sub master mo a
-> GHandlerT sub master mo a
redirectParams rt url params = do
r <- getUrlRenderParams
redirectString rt $ r url params
-- | 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
redirectString = redirectText
{-# DEPRECATED redirectString "Use redirectText instead" #-}
@ -473,16 +474,16 @@ ultDestKey = "_ULT"
--
-- An ultimate destination is stored in the user session and can be loaded
-- later by 'redirectUltDest'.
setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo ()
setUltDest :: MonadIO mo => Route master -> GHandlerT sub master mo ()
setUltDest dest = do
render <- getUrlRender
setUltDestString $ render dest
-- | 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
setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo ()
setUltDestString :: MonadIO mo => Text -> GHandlerT sub master mo ()
setUltDestString = setSession ultDestKey
{-# 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
-- nothing.
setUltDest' :: MonadIO mo => GGHandler sub master mo ()
setUltDest' :: MonadIO mo => GHandlerT sub master mo ()
setUltDest' = do
route <- getCurrentRoute
case route of
@ -504,7 +505,7 @@ setUltDest' = do
-- | Sets the ultimate destination to the referer request header, if present.
--
-- This function will not overwrite an existing ultdest.
setUltDestReferer :: MonadIO mo => GGHandler sub master mo ()
setUltDestReferer :: MonadIO mo => GHandlerT sub master mo ()
setUltDestReferer = do
mdest <- lookupSession ultDestKey
maybe
@ -521,14 +522,14 @@ setUltDestReferer = do
redirectUltDest :: MonadIO mo
=> RedirectType
-> Route master -- ^ default destination if nothing in session
-> GGHandler sub master mo a
-> GHandlerT sub master mo a
redirectUltDest rt def = do
mdest <- lookupSession ultDestKey
deleteSession ultDestKey
maybe (redirect rt def) (redirectText rt) mdest
-- | 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
msgKey :: Text
@ -537,13 +538,13 @@ msgKey = "_MSG"
-- | Sets a message in the user's session.
--
-- 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
-- | Sets a message in the user's session.
--
-- 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
mr <- getMessageRender
setMessage $ toHtml $ mr msg
@ -552,7 +553,7 @@ setMessageI msg = do
-- variable.
--
-- See 'setMessage'.
getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html)
getMessage :: MonadIO mo => GHandlerT sub master mo (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey
@ -562,7 +563,7 @@ 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 :: 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
-- | Same as 'sendFile', but only sends part of a file.
@ -571,25 +572,25 @@ sendFilePart :: MonadIO mo
-> FilePath
-> Integer -- ^ offset
-> Integer -- ^ count
-> GGHandler sub master mo a
-> GHandlerT sub master mo a
sendFilePart ct fp off count =
liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
-- | Bypass remaining handler code and output the given content with a 200
-- 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
. chooseRep
-- | Bypass remaining handler code and output the given content with the given
-- 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
. chooseRep
-- | Send a 201 "Created" response with the given route as the Location
-- 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
r <- getUrlRender
liftIO . throwIO $ HCCreated $ r url
@ -599,7 +600,7 @@ 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 :: MonadIO mo => W.Response -> GGHandler s m mo b
sendWaiResponse :: MonadIO mo => W.Response -> GHandlerT s m mo b
sendWaiResponse = liftIO . throwIO . HCWai
-- | Return a 404 not found page. Also denotes no handler available.
@ -607,7 +608,7 @@ notFound :: Failure ErrorResponse m => m a
notFound = failure NotFound
-- | 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
w <- waiRequest
failure $ BadMethod $ W.requestMethod w
@ -617,7 +618,7 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a
permissionDenied = failure . PermissionDenied
-- | 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
mr <- getMessageRender
permissionDenied $ mr msg
@ -627,7 +628,7 @@ invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs
-- | 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
mr <- getMessageRender
invalidArgs $ map mr msg
@ -638,26 +639,26 @@ setCookie :: MonadIO mo
=> Int -- ^ minutes to timeout
-> H.Ascii -- ^ key
-> H.Ascii -- ^ value
-> GGHandler sub master mo ()
-> GHandlerT sub master mo ()
setCookie a b = addHeader . AddCookie a b
-- | 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
-- | Set the language in the user session. Will show up in 'languages' on the
-- next request.
setLanguage :: MonadIO mo => Text -> GGHandler sub master mo ()
setLanguage :: MonadIO mo => Text -> GHandlerT sub master mo ()
setLanguage = setSession langKey
-- | Set an arbitrary response header.
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
-- | Set the Cache-Control header to indicate this response should be cached
-- 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
[ "max-age="
, 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
-- 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"
-- | Set an Expires header in the past, meaning this content should not be
-- 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"
-- | 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
-- | Set a variable in the user's session.
@ -686,18 +687,18 @@ expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
setSession :: MonadIO mo
=> Text -- ^ key
-> Text -- ^ value
-> GGHandler sub master mo ()
-> GHandlerT sub master mo ()
setSession k = modify . modSession . Map.insert k
-- | 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
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x }
-- | 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 . (:)
getStatus :: ErrorResponse -> H.Status
@ -720,18 +721,18 @@ data RedirectType = RedirectPermanent
| RedirectSeeOther
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 =
local (\hd -> hd { handlerRoute = Nothing })
-- | 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
m <- liftM ghsSession get
return $ Map.lookup n m
-- | Get all session variables.
getSession :: MonadIO mo => GGHandler s m mo SessionMap
getSession :: MonadIO mo => GHandlerT s m mo SessionMap
getSession = liftM ghsSession get
handlerToYAR :: (HasReps a, HasReps b)
@ -744,7 +745,7 @@ handlerToYAR :: (HasReps a, HasReps b)
-> Maybe (Route s)
-> SessionMap
-> GHandler s m b
-> Iteratee ByteString IO YesodAppResult
-> ResourceT IO YesodAppResult
handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
unYesodApp ya eh' rr types sessionMap
where
@ -766,8 +767,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
let hs' = maybe finalHeaders finalHeaders' mlen
in W.ResponseBuilder s hs' b
ContentFile fp p -> W.ResponseFile s finalHeaders fp p
ContentEnum e ->
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
ContentSource body -> W.ResponseSource s finalHeaders body
where
finalHeaders = renderHeaders hs ct sessionFinal
finalHeaders' len = ("Content-Length", S8.pack $ show len)
@ -822,7 +822,7 @@ headerToPair cp _ (DeleteCookie key) =
headerToPair _ _ (Header key value) = (key, value)
-- | 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
x <- get
let i' = ghsIdent x + 1
@ -830,8 +830,8 @@ newIdent = do
return $ 'h' : show i'
liftIOHandler :: MonadIO mo
=> GGHandler sub master IO a
-> GGHandler sub master mo a
=> GHandlerT sub master IO a
-> GHandlerT sub master mo a
liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
-- | 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
-- useful when you need to post a plain link somewhere that needs to cause
-- 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
#if GHC7
[hamlet|
@ -862,35 +862,35 @@ redirectToPost dest = hamletToRepHtml
-- | Converts the given Hamlet template into 'Content', which can be used in a
-- Yesod 'Response'.
hamletToContent :: Monad mo
=> HtmlUrl (Route master) -> GGHandler sub master mo Content
=> HtmlUrl (Route master) -> GHandlerT sub master mo Content
hamletToContent h = do
render <- getUrlRenderParams
return $ toContent $ h render
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: Monad mo
=> HtmlUrl (Route master) -> GGHandler sub master mo RepHtml
=> HtmlUrl (Route master) -> GHandlerT sub master mo RepHtml
hamletToRepHtml = liftM RepHtml . hamletToContent
-- | 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
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
m <- getYesod
l <- reqLangs `liftM` getRequest
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
gs <- get
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 ->
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 ->
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
messageLoggerHandler :: (Yesod m, MonadIO mo)
=> Loc -> LogLevel -> Text -> GGHandler s m mo ()
=> Loc -> LogLevel -> Text -> GHandlerT s m mo ()
messageLoggerHandler loc level msg = do
y <- getYesod
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
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
result of fromSinglePiece/fromMultiPiece, respectively.
result of fromPathPiece/fromMultiPathPiece, respectively.
We want to create a tree of case statements basically resembling:
@ -51,7 +51,7 @@ case segments of
case as of
[] -> Nothing
b:bs ->
case fromSinglePiece b of
case fromPathPiece b of
Left _ -> Nothing
Right name ->
case bs of
@ -59,7 +59,7 @@ case segments of
case cs of
[] -> Nothing
d:ds ->
case fromSinglePiece d of
case fromPathPiece d of
Left _ -> Nothing
Right age ->
case ds of
@ -219,7 +219,7 @@ mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
next <- newName "next"
fsp <- [|fromSinglePiece|]
fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next)
[ Match
(ConP (mkName "Nothing") [])
@ -243,7 +243,7 @@ mkSimpleExp segments [MultiPiece _] frontVars x = do
srest <- [|[]|]
innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
fmp <- [|fromMultiPiece|]
fmp <- [|fromPathMultiPiece|]
let exp = CaseE (fmp `AppE` segments)
[ Match
(ConP (mkName "Nothing") [])
@ -301,7 +301,7 @@ mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
next <- newName "next"
fsp <- [|fromSinglePiece|]
fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next)
[ Match
(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' be [MultiPiece s] parse = do
v <- newName $ "var" ++ s
fmp <- [|fromMultiPiece|]
fmp <- [|fromPathMultiPiece|]
let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
return ([VarP v], parse')
mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
@ -94,7 +94,7 @@ createParse res = do
let sp = LitP $ StringL s
return (sp : x, parse')
mkPat' be (SinglePiece s:rest) parse = do
fsp <- [|fromSinglePiece|]
fsp <- [|fromPathPiece|]
v <- newName $ "var" ++ s
let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
(x, parse'') <- mkPat' be rest parse'
@ -137,13 +137,13 @@ createRender = mapM go
return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
mkBod ((i, SinglePiece _):xs) = do
let x' = VarE $ mkName $ "var" ++ show i
tsp <- [|toSinglePiece|]
tsp <- [|toPathPiece|]
let x'' = tsp `AppE` x'
xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
mkBod ((i, MultiPiece _):_) = do
let x' = VarE $ mkName $ "var" ++ show i
tmp <- [|toMultiPiece|]
tmp <- [|toPathMultiPiece|]
return $ tmp `AppE` x'
-- | 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
( randomString, parseWaiRequest'
, catchIter
) where
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.
--
-- 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
lookup' :: Eq a => a -> [(a, b)] -> [b]
lookup' a = map snd . filter (\x -> a == fst x)
-- | 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
rr <- getRequest
return $ lookup' pn $ reqGetParams rr
-- | 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
-- | Lookup for POST parameters.
@ -91,11 +91,11 @@ lookupFiles pn = do
return $ lookup' pn files
-- | 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
-- | 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
rr <- getRequest
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.Coffee
import Yesod.Handler
(Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
(Route, GHandler, GHandlerT, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender, getUrlRenderParams
)
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 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
mr <- lift getMessageRender
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
-- 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
render <- lift getUrlRenderParams
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
-- 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
render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c
@ -338,7 +338,7 @@ rules = do
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: (Monad mo, RenderMessage master message)
=> HtmlUrlI18n message (Route master)
-> GGHandler sub master mo RepHtml
-> GHandlerT sub master mo RepHtml
ihamletToRepHtml ih = do
urender <- getUrlRenderParams
mrender <- getMessageRender

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

@ -11,10 +11,6 @@ import Network.Wai.Test
import Text.Hamlet (hamlet)
import qualified Data.ByteString.Lazy as L
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
@ -61,7 +57,6 @@ errorHandlingTest = describe "Test.ErrorHandling"
[ it "says not found" caseNotFound
, it "says 'There was an error' before runRequestBody" caseBefore
, it "says 'There was an error' after runRequestBody" caseAfter
, it "catchIter handles internal exceptions" caseCatchIter
]
runner :: Session () -> IO ()
@ -101,11 +96,3 @@ caseAfter = runner $ do
}
assertStatus 500 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.Test
, module Test.Hspec
, module Test.Hspec.HUnit
) where
import Yesod.Core hiding (Request)

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

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