@@ -1,21 +1,32 @@
1+{-# LANGUAGE TupleSections #-}
2+
13module Network.Wai.Middleware.Rewrite
2− ( rewrite, rewritePure
4+ ( rewrite
5+ , rewritePure
6+ , rewriteWithQueries
7+ , rewritePureWithQueries
8+ , rewriteRequest
9+ , rewriteRequestPure
310 ) where
411
512import Network.Wai
613import Control.Monad.IO.Class (liftIO)
714import Data.Text (Text)
15+import Data.Functor.Identity (Identity(..))
816import qualified Data.Text.Encoding as TE
917import qualified Data.Text as T
1018import Network.HTTP.Types as H
1119
20+-- | A tuple of the path sections as '[Text]' and query parameters as
21+-- 'H.QueryText'.
22+type PathsAndQueries = ([Text], H.QueryText)
1223
1324-- | rewrite based on your own conversion rules
1425rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware
1526rewrite convert app req sendResponse = do
16− newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)
17− let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo
18− app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } sendResponse
27+ let convertIO = pathsOnly . curry $ liftIO . uncurry convert
28+ newReq <- rewriteRequestRawM convertIO req
29+ app newReq sendResponse
1930
2031-- | rewrite based on your own conversion rules
2132-- Example convert function:
@@ -27,6 +38,78 @@ rewrite convert app req sendResponse = do
2738-- piecesConvert route@("pages":_) = "static":"html":route
2839rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware
2940rewritePure convert app req =
30− let pInfo = convert (pathInfo req) (requestHeaders req)
31− rawPInfo = TE.encodeUtf8 $ T.intercalate "/" pInfo
32− in app req { pathInfo = pInfo, rawPathInfo = rawPInfo }
41+ let convertPure = pathsOnly . curry $ Identity . uncurry convert
42+ newReq = runIdentity $ rewriteRequestRawM convertPure req
43+ in app newReq
44+
45+-- | rewrite based on your own conversion rules
46+-- Example convert function:
47+
48+-- staticConvert :: [Text] -> H.RequestHeaders -> [Text]
49+-- staticConvert pieces _ = piecesConvert pieces
50+-- where
51+-- piecesConvert [] = ["static", "html", "pages.html"]
52+-- piecesConvert route@("pages":_) = "static":"html":route
53+rewriteWithQueries :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)
54+ -> Middleware
55+rewriteWithQueries convert app req sendResponse = do
56+ newReq <- rewriteRequestM convert req
57+ app newReq sendResponse
58+
59+-- | rewrite based on your own conversion rules
60+-- Example convert function:
61+
62+-- staticConvert :: [Text] -> H.RequestHeaders -> [Text]
63+-- staticConvert pieces _ = piecesConvert pieces
64+-- where
65+-- piecesConvert [] = ["static", "html", "pages.html"]
66+-- piecesConvert route@("pages":_) = "static":"html":route
67+rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)
68+ -> Middleware
69+rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req
70+
71+-- | Modify a 'Request' using the supplied function in 'IO'. This is suitable for
72+-- the reverse proxy example.
73+rewriteRequest :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)
74+ -> Request -> IO Request
75+rewriteRequest convert req =
76+ let convertIO = curry $ liftIO . uncurry convert
77+ in rewriteRequestRawM convertIO req
78+
79+-- | Modify a 'Request' using the pure supplied function. This is suitable for
80+-- the reverse proxy example.
81+rewriteRequestPure :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)
82+ -> Request -> Request
83+rewriteRequestPure convert req =
84+ let convertPure = curry $ Identity . uncurry convert
85+ in runIdentity $ rewriteRequestRawM convertPure req
86+
87+-- | This helper function factors out the common behaviour of rewriting requests.
88+rewriteRequestM :: Monad m
89+ => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)
90+ -> Request -> m Request
91+rewriteRequestM convert req = do
92+ (pInfo, qText) <- curry convert (pathInfo req) (H.queryToQueryText . queryString $ req) (requestHeaders req)
93+ pure req {pathInfo = pInfo, queryString = H.queryTextToQuery qText}
94+ -- rawPInfo = toS . toLazyByteString $ encodePathSegmentsRelative pInfo
95+ -- rawQString = toS . toLazyByteString $ renderQueryText True qText
96+
97+-- | This helper function preserves the semantics of wai-extra <= 3.0, in
98+-- which the rewrite functions modify the `rawPathInfo` parameter. Note
99+-- that this has not been extended to modify the `rawQueryInfo` as
100+-- modifying either of these values has been deprecated.
101+rewriteRequestRawM :: Monad m
102+ => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)
103+ -> Request -> m Request
104+rewriteRequestRawM convert req = do
105+ newReq <- rewriteRequestM convert req
106+ let rawPInfo = TE.encodeUtf8 . T.intercalate "/" . pathInfo $ newReq
107+ pure newReq { rawPathInfo = rawPInfo }
108+
109+-- | Produce a function that works on 'PathsandQueries' from one working
110+-- only on paths.
111+pathsOnly :: Monad m
112+ => ([Text] -> H.RequestHeaders -> m [Text])
113+ -> PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries
114+pathsOnly convert paths headers = (,[]) <$> convert (fst paths) headers
115+{-# INLINE pathsOnly #-}