diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 3.0.17 + +* Gzip pre compressed [#580](https://github.com/yesodweb/wai/pull/580) + ## 3.0.16.1 * Fix the way the header length is checked (for limiting the max header length) diff --git a/Network/Wai/Middleware/Gzip.hs b/Network/Wai/Middleware/Gzip.hs --- a/Network/Wai/Middleware/Gzip.hs +++ b/Network/Wai/Middleware/Gzip.hs @@ -58,6 +58,10 @@ -- platforms. | GzipCacheFolder FilePath -- ^ Compress files, caching them in -- some directory. + | GzipPreCompressed GzipFiles -- ^ If we use compression then try to use the filename with ".gz" + -- appended to it, if the file is missing then try next action + -- + -- @since 3.0.17 deriving (Show, Eq, Read) -- | Use default MIME settings; /do not/ compress files. @@ -92,13 +96,23 @@ ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res) then - case (res, gzipFiles set) of - (ResponseFile s hs file Nothing, GzipCacheFolder cache) -> - case lookup hContentType hs of - Just m - | gzipCheckMime set m -> compressFile s hs file cache sendResponse - _ -> sendResponse res - _ -> compressE set res sendResponse + let runAction x = case x of + (ResponseFile s hs file Nothing, GzipPreCompressed nextAction) -> + let + compressedVersion = file ++ ".gz" + in + doesFileExist compressedVersion >>= \x -> + if x + then (sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing) + else (runAction (ResponseFile s hs file Nothing, nextAction)) + (ResponseFile s hs file Nothing, GzipCacheFolder cache) -> + case lookup hContentType hs of + Just m + | gzipCheckMime set m -> compressFile s hs file cache sendResponse + _ -> sendResponse res + (ResponseFile {}, GzipIgnore) -> sendResponse res + _ -> compressE set res sendResponse + in runAction (res, gzipFiles set) else sendResponse res where enc = fromMaybe [] $ (splitCommas . S8.unpack) diff --git a/Network/Wai/Middleware/Rewrite.hs b/Network/Wai/Middleware/Rewrite.hs --- a/Network/Wai/Middleware/Rewrite.hs +++ b/Network/Wai/Middleware/Rewrite.hs @@ -1,32 +1,323 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} + module Network.Wai.Middleware.Rewrite - ( rewrite, rewritePure + ( -- * How to use this module + -- $howto + + -- ** A note on semantics + + -- $semantics + + -- ** Paths and Queries + + -- $pathsandqueries + PathsAndQueries + + -- ** An example rewriting paths with queries + + -- $takeover + + -- ** Upgrading from wai-extra ≤ 3.0.16.1 + + -- $upgrading + + -- * 'Middleware' + + -- ** Recommended functions + , rewriteWithQueries + , rewritePureWithQueries + + -- ** Deprecated + , rewrite + , rewritePure + + -- * Operating on 'Request's + + , rewriteRequest + , rewriteRequestPure ) where import Network.Wai import Control.Monad.IO.Class (liftIO) import Data.Text (Text) +import Data.Functor.Identity (Identity(..)) import qualified Data.Text.Encoding as TE import qualified Data.Text as T import Network.HTTP.Types as H +-- GHC ≤ 7.10 does not export Applicative functions from the prelude. +#if __GLASGOW_HASKELL__ <= 710 +import Control.Applicative +#endif --- | rewrite based on your own conversion rules -rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware -rewrite convert app req sendResponse = do - newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req) - let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo - app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } sendResponse +-- $howto +-- This module provides 'Middleware' to rewrite URL paths. It also provides +-- functions that will convert a 'Request' to a modified 'Request'. +-- Both operations require a function that takes URL parameters and +-- headers, and returns new URL parameters. Parameters are pieces of URL +-- paths and query parameters. +-- +-- If you are a new user of the library, use 'rewriteWithQueries' or +-- 'rewritePureWithQueries' for middleware. For modifying 'Request's +-- directly, use 'rewriteRequest' or 'rewriteRequestPure'. --- | rewrite based on your own conversion rules --- Example convert function: +-- $semantics +-- +-- Versions of this library in wai-extra ≤ 3.0.16.1 exported only +-- 'rewrite' and 'rewritePure' and both modified 'rawPathInfo' of the +-- underlying requests. Such modification has been proscribed. The +-- semantics of these functions have not changed; instead the recommended +-- approach is to use 'rewriteWithQueries' and 'rewritePureWithQueries'. +-- The new functions are slightly different, as described in the section +-- on upgrading; code for previous library versions can be upgraded with +-- a single change, and as the type of the new function is different the +-- compiler will indicate where this change must be made. +-- +-- The 'rewriteRequest' and 'rewriteRequestPure' functions use the new +-- semantics, too. --- staticConvert :: [Text] -> H.RequestHeaders -> [Text] --- staticConvert pieces _ = piecesConvert pieces +-- $pathsandqueries +-- +-- This library defines the type synonym `PathsAndQueries` to make code +-- handling paths and queries easier to read. +-- +-- /e.g./ /\/foo\/bar/ would look like +-- +-- > ["foo", "bar"] :: Text +-- +-- /?bar=baz/ would look like +-- +-- > [("bar", Just "baz")] :: QueryText +-- +-- Together, +-- +-- /\/foo?bar=baz/ would look like +-- +-- > (["foo"],[("bar", Just "baz")]) :: PathsAndQueries + +-- $takeover +-- Let’s say we want to replace a website written in PHP with one written +-- using WAI. We’ll use the +-- +-- package to serve the old +-- site from the new site, but there’s a problem. The old site uses pages like +-- +-- @ +-- index.php?page=/page/ +-- @ +-- +-- whereas the new site would look like +-- +-- @ +-- index\//page/ +-- @ +-- +-- In doing this, we want to separate the migration code from our new +-- website. So we’d like to handle links internally using the path +-- formulation, but externally have the old links still work. +-- +-- Therefore, we will use middleware ('rewritePureWithQueries') from this +-- module to rewrite incoming requests from the query formulation to the +-- paths formulation. +-- +-- > {-# LANGUAGE ViewPatterns #-} +-- > +-- > rewritePathFromPhp :: Middleware +-- > rewritePathFromPhp = rewritePureWithQueries pathFromPhp +-- > +-- > pathFromPhp :: PathsAndQueries -> H.RequestHeaders -> PathsAndQueries +-- > pathFromPhp (pieces, queries) _ = piecesConvert pieces queries +-- > where +-- > piecesConvert :: [Text] -> H.Query -> PathsAndQueries +-- > piecesConvert ["index.php"] qs@(join . lookup "page" -> Just page) = +-- > ( ["index", TE.decodeUtf8With TE.lenientDecode page] +-- > , delete ("page", pure page) qs +-- > ) +-- > piecesConvert ps qs = (ps, qs) +-- +-- On the other side, we will use 'rewriteRequestPure' to rewrite outgoing +-- requests to the original website from the reverse proxy code (using the +-- 'Network.HTTP.ReverseProxy.WPRModifiedRequest' or +-- 'Network.HTTP.ReverseProxy.WPRModifiedRequestSecure' constructors. Note, +-- these links will only work if the haddock documentation for +-- +-- is installed). +-- +-- > rewritePhpFromPath :: Request -> Request +-- > rewritePhpFromPath = rewriteRequestPure phpFromPath +-- > +-- > phpFromPath :: PathsAndQueries -> H.RequestHeaders -> PathsAndQueries +-- > phpFromPath (pieces, queries) _ = piecesConvert pieces queries +-- > where +-- > piecesConvert :: [Text] -> H.Query -> PathsAndQueries +-- > piecesConvert ["index", page] qs = ( ["index.php"], ("page", pure . TE.encodeUtf8 $ page) : qs ) +-- > piecesConvert ps qs = (ps, qs) +-- +-- For the whole example, see +-- . + +-- $upgrading +-- It is quite simple to upgrade from 'rewrite' and 'rewritePure', to +-- 'rewriteWithQueries' and 'rewritePureWithQueries'. +-- Insert 'Data.Bifunctor.first', which specialises to +-- +-- @ +-- 'Data.Bifunctor.first' :: (['Text'] -> ['Text']) -> 'PathsAndQueries' -> 'PathsAndQueries' +-- @ +-- +-- as the following example demonstrates. +-- +-- Old versions of the libary could only handle path pieces, not queries. +-- This could have been supplied to 'rewritePure'. +-- +-- @ +-- staticConvert' :: [Text] -> H.RequestHeaders -> [Text] +-- staticConvert' pieces _ = piecesConvert pieces -- where -- piecesConvert [] = ["static", "html", "pages.html"] -- piecesConvert route@("pages":_) = "static":"html":route +-- @ +-- +-- Instead, use this function, supplied to 'rewritePureWithQueries'. +-- +-- @ +-- staticConvert :: 'PathsAndQueries' -> H.RequestHeaders -> 'PathsAndQueries' +-- staticConvert pathsAndQueries _ = 'Data.Bifunctor.first' piecesConvert pathsAndQueries +-- where +-- piecesConvert [] = ["static", "html", "pages.html"] +-- piecesConvert route@("pages":_) = "static":"html":route +-- @ +-- +-- The former formulation is deprecated for two reasons: +-- +-- 1. The original formulation of 'rewrite' modified 'rawPathInfo', which +-- is deprecated behaviour. +-- +-- 2. The original formulation did not allow query parameters to +-- influence the path. +-- +-- Concerning the first point, take care with semantics of your program when +-- upgrading as the upgraded functions no longer modify 'rawPathInfo'. + +-------------------------------------------------- +-- * Types +-------------------------------------------------- + +-- | A tuple of the path sections as ['Text'] and query parameters as +-- 'H.Query'. This makes writing type signatures for the conversion +-- function far more pleasant. +-- +-- Note that this uses 'H.Query' not 'H.QueryText' to more accurately +-- reflect the paramaters that can be supplied in URLs. It may be safe to +-- treat parameters as text; use the 'H.queryToQueryText' and +-- 'H.queryTextToQuery' functions to interconvert. +type PathsAndQueries = ([Text], H.Query) + +-------------------------------------------------- +-- * Rewriting 'Middleware' +-------------------------------------------------- + +-- | Rewrite based on your own conversion function for paths only, to be +-- supplied by users of this library (with the conversion operating in 'IO'). +-- +-- For new code, use 'rewriteWithQueries' instead. +rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware +rewrite convert app req sendResponse = do + let convertIO = pathsOnly . curry $ liftIO . uncurry convert + newReq <- rewriteRequestRawM convertIO req + app newReq sendResponse +{-# WARNING rewrite [ + "This modifies the 'rawPathInfo' field of a 'Request'." + , " This is not recommended behaviour; it is however how" + , " this function has worked in the past." + , " Use 'rewriteWithQueries' instead"] #-} + +-- | Rewrite based on pure conversion function for paths only, to be +-- supplied by users of this library. +-- +-- For new code, use 'rewritePureWithQueries' instead. rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware rewritePure convert app req = - let pInfo = convert (pathInfo req) (requestHeaders req) - rawPInfo = TE.encodeUtf8 $ T.intercalate "/" pInfo - in app req { pathInfo = pInfo, rawPathInfo = rawPInfo } + let convertPure = pathsOnly . curry $ Identity . uncurry convert + newReq = runIdentity $ rewriteRequestRawM convertPure req + in app newReq +{-# WARNING rewritePure [ + "This modifies the 'rawPathInfo' field of a 'Request'." + , " This is not recommended behaviour; it is however how" + , " this function has worked in the past." + , " Use 'rewritePureWithQueries' instead"] #-} + +-- | Rewrite based on your own conversion function for paths and queries. +-- This function is to be supplied by users of this library, and operates +-- in 'IO'. +rewriteWithQueries :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries) + -> Middleware +rewriteWithQueries convert app req sendResponse = do + newReq <- rewriteRequestM convert req + app newReq sendResponse + +-- | Rewrite based on pure conversion function for paths and queries. This +-- function is to be supplied by users of this library. +rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries) + -> Middleware +rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req + +-------------------------------------------------- +-- * Modifying 'Request's directly +-------------------------------------------------- + +-- | Modify a 'Request' using the supplied function in 'IO'. This is suitable for +-- the reverse proxy example. +rewriteRequest :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries) + -> Request -> IO Request +rewriteRequest convert req = + let convertIO = curry $ liftIO . uncurry convert + in rewriteRequestRawM convertIO req + +-- | Modify a 'Request' using the pure supplied function. This is suitable for +-- the reverse proxy example. +rewriteRequestPure :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries) + -> Request -> Request +rewriteRequestPure convert req = + let convertPure = curry $ Identity . uncurry convert + in runIdentity $ rewriteRequestRawM convertPure req + +-------------------------------------------------- +-- * Helper functions +-------------------------------------------------- + +-- | This helper function factors out the common behaviour of rewriting requests. +rewriteRequestM :: (Applicative m, Monad m) + => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries) + -> Request -> m Request +rewriteRequestM convert req = do + (pInfo, qByteStrings) <- curry convert (pathInfo req) (queryString req) (requestHeaders req) + pure req {pathInfo = pInfo, queryString = qByteStrings} + +-- | This helper function preserves the semantics of wai-extra ≤ 3.0, in +-- which the rewrite functions modify the 'rawPathInfo' parameter. Note +-- that this has not been extended to modify the 'rawQueryInfo' as +-- modifying either of these values has been deprecated. +rewriteRequestRawM :: (Applicative m, Monad m) + => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries) + -> Request -> m Request +rewriteRequestRawM convert req = do + newReq <- rewriteRequestM convert req + let rawPInfo = TE.encodeUtf8 . T.intercalate "/" . pathInfo $ newReq + pure newReq { rawPathInfo = rawPInfo } +{-# WARNING rewriteRequestRawM [ + "This modifies the 'rawPathInfo' field of a 'Request'." + , " This is not recommended behaviour; it is however how" + , " this function has worked in the past." + , " Use 'rewriteRequestM' instead"] #-} + +-- | Produce a function that works on 'PathsAndQueries' from one working +-- only on paths. This is not exported, as it is only needed to handle +-- code written for versions ≤ 3.0 of the library; see the +-- example above using 'Data.Bifunctor.first' to do something similar. +pathsOnly :: (Applicative m, Monad m) + => ([Text] -> H.RequestHeaders -> m [Text]) + -> PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries +pathsOnly convert psAndQs headers = (,[]) <$> convert (fst psAndQs) headers +{-# INLINE pathsOnly #-} diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 3.0.16.1 +Version: 3.0.17 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: