yesod-core 0.8.2 → 0.8.3
raw patch · 7 files changed
+73/−42 lines, 7 files
Files
- Yesod/Dispatch.hs +6/−9
- Yesod/Handler.hs +37/−23
- Yesod/Internal/Core.hs +5/−4
- Yesod/Internal/Dispatch.hs +1/−1
- Yesod/Internal/Request.hs +1/−1
- Yesod/Widget.hs +22/−3
- yesod-core.cabal +1/−1
Yesod/Dispatch.hs view
@@ -22,7 +22,8 @@ , toWaiAppPlain ) where -import Data.Either (partitionEithers)+import Data.Functor ((<$>))+import Data.Either (partitionEithers) import Prelude hiding (exp) import Yesod.Internal.Core import Yesod.Handler@@ -36,6 +37,7 @@ import qualified Network.Wai as W import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.Autohead import Data.ByteString.Lazy.Char8 () @@ -162,18 +164,13 @@ -- middlewares: GZIP compression, JSON-P and path cleaning. This is the -- recommended approach for most users. toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application-toWaiApp y = do- a <- toWaiAppPlain y- return $ gzip False- $ jsonp- a+toWaiApp y = gzip False . jsonp . autohead <$> toWaiAppPlain y -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it uses no middlewares. toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application-toWaiAppPlain a = do- key' <- encryptKey a- return $ toWaiApp' a key'+toWaiAppPlain a = toWaiApp' a <$> encryptKey a+ toWaiApp' :: (Yesod y, YesodDispatch y y) => y
Yesod/Handler.hs view
@@ -79,7 +79,9 @@ -- ** Ultimate destination , setUltDest , setUltDestString+ , setUltDestText , setUltDest'+ , setUltDestReferer , redirectUltDest , clearUltDest -- ** Messages@@ -120,7 +122,7 @@ import qualified Control.Exception as E import Control.Applicative -import Control.Monad (liftM, join)+import Control.Monad (liftM, join, MonadPlus) import Control.Monad.IO.Class import Control.Monad.Trans.Class@@ -146,16 +148,15 @@ import qualified Data.Map as Map import qualified Data.ByteString as S import Data.ByteString (ByteString)-import Data.Enumerator (Iteratee (..))+import Data.Enumerator (Iteratee (..), run_, ($$)) import Network.Wai.Parse (parseHttpAccept) import Yesod.Content import Data.Maybe (fromMaybe) import Web.Cookie (SetCookie (..), renderSetCookie)-import Data.Enumerator (run_, ($$)) import Control.Arrow (second, (***)) import qualified Network.Wai.Parse as NWP-import Data.Monoid (mappend, mempty)+import Data.Monoid (mappend, mempty, Endo (..)) import qualified Data.ByteString.Char8 as S8 import Data.CaseInsensitive (CI) import Blaze.ByteString.Builder (toByteString)@@ -169,11 +170,11 @@ fromSubRoute :: s -> y -> Route s -> Route y data HandlerData sub master = HandlerData- { handlerRequest :: Request- , handlerSub :: sub- , handlerMaster :: master- , handlerRoute :: Maybe (Route sub)- , handlerRender :: (Route master -> [(Text, Text)] -> Text)+ { handlerRequest :: Request+ , handlerSub :: sub+ , handlerMaster :: master+ , handlerRoute :: Maybe (Route sub)+ , handlerRender :: Route master -> [(Text, Text)] -> Text , handlerToMaster :: Route sub -> Route master } @@ -220,9 +221,7 @@ instance (master ~ master' ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where- runSubsiteGetter getter = do- y <- getYesod- return $ getter y+ runSubsiteGetter getter = getter <$> getYesod instance (anySub ~ anySub' ,master ~ master'@@ -246,7 +245,7 @@ GHandler { unGHandler :: GHInner sub master m a }- deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO)+ deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, MonadPlus) instance MonadTrans (GGHandler s m) where lift = GHandler . lift . lift . lift . lift@@ -269,8 +268,6 @@ type SessionMap = Map.Map Text Text -type Endo a = a -> a- -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as -- the 'GHandler' monad and template haskell code should hide it away.@@ -387,24 +384,24 @@ $ runErrorT $ flip runReaderT hd $ unGHandler handler- ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession))+ ) (\e -> return ((Left $ HCError $ toErrorHandler e, mempty), initSession)) let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession case yar of YARPlain _ hs ct c sess ->- let hs' = headers hs+ let hs' = appEndo headers hs in return $ YARPlain (getStatus e) hs' ct c sess YARWai _ -> return yar let sendFile' ct fp p =- return $ YARPlain H.status200 (headers []) ct (ContentFile fp p) finalSession+ return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession case contents of HCContent status a -> do- (ct, c) <- liftIO $ chooseRep a cts- return $ YARPlain status (headers []) ct c finalSession+ (ct, c) <- liftIO $ a cts+ return $ YARPlain status (appEndo headers []) ct c finalSession HCError e -> handleError e HCRedirect rt loc -> do- let hs = Header "Location" (encodeUtf8 loc) : headers []+ let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] return $ YARPlain (getRedirectStatus rt) hs typePlain emptyContent finalSession@@ -412,7 +409,7 @@ (sendFile' ct fp p) (handleError . toErrorHandler) HCCreated loc -> do- let hs = Header "Location" (encodeUtf8 loc) : headers []+ let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] return $ YARPlain H.status201 hs@@ -468,8 +465,12 @@ setUltDestString $ render dest -- | Same as 'setUltDest', but use the given string.+setUltDestText :: Monad mo => Text -> GGHandler sub master mo ()+setUltDestText = setSession ultDestKey+ setUltDestString :: Monad mo => Text -> GGHandler sub master mo () setUltDestString = setSession ultDestKey+{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-} -- | Same as 'setUltDest', but uses the current page. --@@ -486,6 +487,19 @@ render <- getUrlRenderParams setUltDestString $ render (tm r) gets' +-- | Sets the ultimate destination to the referer request header, if present.+--+-- This function will not overwrite an existing ultdest.+setUltDestReferer :: Monad mo => GGHandler sub master mo ()+setUltDestReferer = do+ mdest <- lookupSession ultDestKey+ maybe+ (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)+ (const $ return ())+ mdest+ where+ setUltDestBS = setUltDestText . T.pack . S8.unpack+ -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. --@@ -670,7 +684,7 @@ -- | Internal use only, not to be confused with 'setHeader'. addHeader :: Monad mo => Header -> GGHandler sub master mo ()-addHeader = GHandler . lift . lift . tell . (:)+addHeader = GHandler . lift . lift . tell . Endo . (:) getStatus :: ErrorResponse -> H.Status getStatus NotFound = H.status404
Yesod/Internal/Core.hs view
@@ -33,6 +33,7 @@ import Yesod.Handler import Control.Arrow ((***))+import Control.Monad (forM) import qualified Paths_yesod_core import Data.Version (showVersion) import Yesod.Widget@@ -175,7 +176,7 @@ isWriteRequest :: Route a -> GHandler s a Bool isWriteRequest _ = do wai <- waiRequest- return $ not $ W.requestMethod wai `elem`+ return $ W.requestMethod wai `notElem` ["GET", "HEAD", "OPTIONS", "TRACE"] -- | The default route for authentication.@@ -494,7 +495,7 @@ Nothing -> Nothing Just (Left s) -> Just s Just (Right (u, p)) -> Just $ render u p- css <- flip mapM (Map.toList style) $ \(mmedia, content) -> do+ css <- forM (Map.toList style) $ \(mmedia, content) -> do let rendered = renderCassius render content x <- addStaticContent "css" "text/css; charset=utf-8" $ encodeUtf8 rendered@@ -531,8 +532,6 @@ #else [$hamlet| #endif-$forall s <- scripts- ^{mkScriptTag s} $forall s <- stylesheets ^{mkLinkTag s} $forall s <- css@@ -546,6 +545,8 @@ <style media=#{media}>#{content} $nothing <style>#{content}+$forall s <- scripts+ ^{mkScriptTag s} $maybe j <- jscript $maybe s <- jsLoc <script src="#{s}">
Yesod/Internal/Dispatch.hs view
@@ -172,7 +172,7 @@ return $ Match (VarP x) (GuardedB- [ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ (LitE $ StringL m)) -- FIXME need to pack, right?+ [ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ LitE $ StringL m) -- FIXME need to pack, right? , runHandlerVars $ map toLower m ++ constr ) ])
Yesod/Internal/Request.hs view
@@ -37,7 +37,7 @@ -> IO Request parseWaiRequest env session' key' = do let gets' = queryToQueryText $ W.queryString env- let reqCookie = maybe mempty id $ lookup "Cookie"+ let reqCookie = fromMaybe mempty $ lookup "Cookie" $ W.requestHeaders env cookies' = parseCookiesText reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env
Yesod/Widget.hs view
@@ -38,6 +38,8 @@ -- ** Javascript , addJulius , addJuliusBody+ , addCoffee+ , addCoffeeBody , addScript , addScriptAttrs , addScriptRemote@@ -54,14 +56,15 @@ import Text.Cassius import Text.Lucius (Lucius) import Text.Julius+import Text.Coffee import Yesod.Handler (Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod- , getMessageRender+ , getMessageRender, getUrlRenderParams ) import Yesod.Message (RenderMessage) import Yesod.Content (RepHtml (..), toContent) import Control.Applicative (Applicative)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Yesod.Internal import Control.Monad (liftM)@@ -69,10 +72,10 @@ import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)-import Yesod.Handler (getUrlRenderParams) import Control.Monad.IO.Control (MonadControlIO) import qualified Text.Hamlet.NonPoly as NP+import Data.Text.Lazy.Builder (fromLazyText) -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of@@ -208,6 +211,22 @@ -- template. addJuliusBody :: Monad m => Julius (Route master) -> GGWidget master m () addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJulius r j++-- | Add Coffesscript to the page's script tag. Requires the coffeescript+-- executable to be present at runtime.+addCoffee :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()+addCoffee c = do+ render <- lift getUrlRenderParams+ t <- liftIO $ renderCoffee render c+ addJulius $ const $ Javascript $ fromLazyText t++-- | 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 => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()+addCoffeeBody c = do+ render <- lift getUrlRenderParams+ t <- liftIO $ renderCoffee render c+ addJuliusBody $ const $ Javascript $ fromLazyText t -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 0.8.2+version: 0.8.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>