{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
module Network.Wai.Middleware.Rewrite
(
PathsAndQueries
, rewriteWithQueries
, rewritePureWithQueries
, rewriteRoot
, rewrite
, rewritePure
, 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
#if __GLASGOW_HASKELL__ <= 710
import Control.Applicative
#endif
type PathsAndQueries = ([Text], H.Query)
rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware
rewrite :: ([Text] -> RequestHeaders -> IO [Text]) -> Middleware
rewrite [Text] -> RequestHeaders -> IO [Text]
convert Application
app Request
req Response -> IO ResponseReceived
sendResponse = do
let convertIO :: PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
convertIO = ([Text] -> RequestHeaders -> IO [Text])
-> PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
forall (m :: * -> *).
(Applicative m, Monad m) =>
([Text] -> RequestHeaders -> m [Text])
-> PathsAndQueries -> RequestHeaders -> m PathsAndQueries
pathsOnly (([Text] -> RequestHeaders -> IO [Text])
-> PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> ((([Text], RequestHeaders) -> IO [Text])
-> [Text] -> RequestHeaders -> IO [Text])
-> (([Text], RequestHeaders) -> IO [Text])
-> PathsAndQueries
-> RequestHeaders
-> IO PathsAndQueries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Text], RequestHeaders) -> IO [Text])
-> [Text] -> RequestHeaders -> IO [Text]
forall a b c. ((a, b) -> c) -> a -> b -> c
curry ((([Text], RequestHeaders) -> IO [Text])
-> PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> (([Text], RequestHeaders) -> IO [Text])
-> PathsAndQueries
-> RequestHeaders
-> IO PathsAndQueries
forall a b. (a -> b) -> a -> b
$ IO [Text] -> IO [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> IO [Text])
-> (([Text], RequestHeaders) -> IO [Text])
-> ([Text], RequestHeaders)
-> IO [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> RequestHeaders -> IO [Text])
-> ([Text], RequestHeaders) -> IO [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Text] -> RequestHeaders -> IO [Text]
convert
Request
newReq <- (PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> Request -> IO Request
forall (m :: * -> *).
(Applicative m, Monad m) =>
(PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestRawM PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
convertIO Request
req
Application
app Request
newReq Response -> IO ResponseReceived
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"] #-}
rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware
rewritePure :: ([Text] -> RequestHeaders -> [Text]) -> Middleware
rewritePure [Text] -> RequestHeaders -> [Text]
convert Application
app Request
req =
let convertPure :: PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries
convertPure = ([Text] -> RequestHeaders -> Identity [Text])
-> PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries
forall (m :: * -> *).
(Applicative m, Monad m) =>
([Text] -> RequestHeaders -> m [Text])
-> PathsAndQueries -> RequestHeaders -> m PathsAndQueries
pathsOnly (([Text] -> RequestHeaders -> Identity [Text])
-> PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries)
-> ((([Text], RequestHeaders) -> Identity [Text])
-> [Text] -> RequestHeaders -> Identity [Text])
-> (([Text], RequestHeaders) -> Identity [Text])
-> PathsAndQueries
-> RequestHeaders
-> Identity PathsAndQueries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Text], RequestHeaders) -> Identity [Text])
-> [Text] -> RequestHeaders -> Identity [Text]
forall a b c. ((a, b) -> c) -> a -> b -> c
curry ((([Text], RequestHeaders) -> Identity [Text])
-> PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries)
-> (([Text], RequestHeaders) -> Identity [Text])
-> PathsAndQueries
-> RequestHeaders
-> Identity PathsAndQueries
forall a b. (a -> b) -> a -> b
$ [Text] -> Identity [Text]
forall a. a -> Identity a
Identity ([Text] -> Identity [Text])
-> (([Text], RequestHeaders) -> [Text])
-> ([Text], RequestHeaders)
-> Identity [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> RequestHeaders -> [Text])
-> ([Text], RequestHeaders) -> [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Text] -> RequestHeaders -> [Text]
convert
newReq :: Request
newReq = Identity Request -> Request
forall a. Identity a -> a
runIdentity (Identity Request -> Request) -> Identity Request -> Request
forall a b. (a -> b) -> a -> b
$ (PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries)
-> Request -> Identity Request
forall (m :: * -> *).
(Applicative m, Monad m) =>
(PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestRawM PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries
convertPure Request
req
in Application
app Request
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"] #-}
rewriteWithQueries :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)
-> Middleware
rewriteWithQueries :: (PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> Middleware
rewriteWithQueries PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
convert Application
app Request
req Response -> IO ResponseReceived
sendResponse = do
Request
newReq <- (PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> Request -> IO Request
forall (m :: * -> *).
(Applicative m, Monad m) =>
(PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestM PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
convert Request
req
Application
app Request
newReq Response -> IO ResponseReceived
sendResponse
rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)
-> Middleware
rewritePureWithQueries :: (PathsAndQueries -> RequestHeaders -> PathsAndQueries)
-> Middleware
rewritePureWithQueries PathsAndQueries -> RequestHeaders -> PathsAndQueries
convert Application
app Request
req = Application
app Middleware
forall a b. (a -> b) -> a -> b
$ (PathsAndQueries -> RequestHeaders -> PathsAndQueries)
-> Request -> Request
rewriteRequestPure PathsAndQueries -> RequestHeaders -> PathsAndQueries
convert Request
req
rewriteRoot :: Text -> Middleware
rewriteRoot :: Text -> Middleware
rewriteRoot Text
root = (PathsAndQueries -> RequestHeaders -> PathsAndQueries)
-> Middleware
rewritePureWithQueries PathsAndQueries -> RequestHeaders -> PathsAndQueries
forall b p. ([Text], b) -> p -> ([Text], b)
onlyRoot
where
onlyRoot :: ([Text], b) -> p -> ([Text], b)
onlyRoot ([], b
q) p
_ = ([Text
root], b
q)
onlyRoot ([Text], b)
paths p
_ = ([Text], b)
paths
rewriteRequest :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)
-> Request -> IO Request
rewriteRequest :: (PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> Request -> IO Request
rewriteRequest PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
convert Request
req =
let convertIO :: PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
convertIO = ((PathsAndQueries, RequestHeaders) -> IO PathsAndQueries)
-> PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((PathsAndQueries, RequestHeaders) -> IO PathsAndQueries)
-> PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> ((PathsAndQueries, RequestHeaders) -> IO PathsAndQueries)
-> PathsAndQueries
-> RequestHeaders
-> IO PathsAndQueries
forall a b. (a -> b) -> a -> b
$ IO PathsAndQueries -> IO PathsAndQueries
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PathsAndQueries -> IO PathsAndQueries)
-> ((PathsAndQueries, RequestHeaders) -> IO PathsAndQueries)
-> (PathsAndQueries, RequestHeaders)
-> IO PathsAndQueries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> (PathsAndQueries, RequestHeaders) -> IO PathsAndQueries
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
convert
in (PathsAndQueries -> RequestHeaders -> IO PathsAndQueries)
-> Request -> IO Request
forall (m :: * -> *).
(Applicative m, Monad m) =>
(PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestRawM PathsAndQueries -> RequestHeaders -> IO PathsAndQueries
convertIO Request
req
rewriteRequestPure :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)
-> Request -> Request
rewriteRequestPure :: (PathsAndQueries -> RequestHeaders -> PathsAndQueries)
-> Request -> Request
rewriteRequestPure PathsAndQueries -> RequestHeaders -> PathsAndQueries
convert Request
req =
let convertPure :: PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries
convertPure = ((PathsAndQueries, RequestHeaders) -> Identity PathsAndQueries)
-> PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((PathsAndQueries, RequestHeaders) -> Identity PathsAndQueries)
-> PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries)
-> ((PathsAndQueries, RequestHeaders) -> Identity PathsAndQueries)
-> PathsAndQueries
-> RequestHeaders
-> Identity PathsAndQueries
forall a b. (a -> b) -> a -> b
$ PathsAndQueries -> Identity PathsAndQueries
forall a. a -> Identity a
Identity (PathsAndQueries -> Identity PathsAndQueries)
-> ((PathsAndQueries, RequestHeaders) -> PathsAndQueries)
-> (PathsAndQueries, RequestHeaders)
-> Identity PathsAndQueries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathsAndQueries -> RequestHeaders -> PathsAndQueries)
-> (PathsAndQueries, RequestHeaders) -> PathsAndQueries
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PathsAndQueries -> RequestHeaders -> PathsAndQueries
convert
in Identity Request -> Request
forall a. Identity a -> a
runIdentity (Identity Request -> Request) -> Identity Request -> Request
forall a b. (a -> b) -> a -> b
$ (PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries)
-> Request -> Identity Request
forall (m :: * -> *).
(Applicative m, Monad m) =>
(PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestRawM PathsAndQueries -> RequestHeaders -> Identity PathsAndQueries
convertPure Request
req
rewriteRequestM :: (Applicative m, Monad m)
=> (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestM :: (PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestM PathsAndQueries -> RequestHeaders -> m PathsAndQueries
convert Request
req = do
([Text]
pInfo, Query
qByteStrings) <- (PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> [Text] -> Query -> RequestHeaders -> m PathsAndQueries
forall a b c. ((a, b) -> c) -> a -> b -> c
curry PathsAndQueries -> RequestHeaders -> m PathsAndQueries
convert (Request -> [Text]
pathInfo Request
req) (Request -> Query
queryString Request
req) (Request -> RequestHeaders
requestHeaders Request
req)
Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req {pathInfo :: [Text]
pathInfo = [Text]
pInfo, queryString :: Query
queryString = Query
qByteStrings}
rewriteRequestRawM :: (Applicative m, Monad m)
=> (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestRawM :: (PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestRawM PathsAndQueries -> RequestHeaders -> m PathsAndQueries
convert Request
req = do
Request
newReq <- (PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
forall (m :: * -> *).
(Applicative m, Monad m) =>
(PathsAndQueries -> RequestHeaders -> m PathsAndQueries)
-> Request -> m Request
rewriteRequestM PathsAndQueries -> RequestHeaders -> m PathsAndQueries
convert Request
req
let rawPInfo :: ByteString
rawPInfo = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> (Request -> Text) -> Request -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> (Request -> [Text]) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo (Request -> ByteString) -> Request -> ByteString
forall a b. (a -> b) -> a -> b
$ Request
newReq
Request -> m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
newReq { rawPathInfo :: ByteString
rawPathInfo = ByteString
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"] #-}
pathsOnly :: (Applicative m, Monad m)
=> ([Text] -> H.RequestHeaders -> m [Text])
-> PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries
pathsOnly :: ([Text] -> RequestHeaders -> m [Text])
-> PathsAndQueries -> RequestHeaders -> m PathsAndQueries
pathsOnly [Text] -> RequestHeaders -> m [Text]
convert PathsAndQueries
psAndQs RequestHeaders
headers = (,[]) ([Text] -> PathsAndQueries) -> m [Text] -> m PathsAndQueries
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> RequestHeaders -> m [Text]
convert (PathsAndQueries -> [Text]
forall a b. (a, b) -> a
fst PathsAndQueries
psAndQs) RequestHeaders
headers
{-# INLINE pathsOnly #-}