{-# LANGUAGE CPP #-}

module Network.Wai.Middleware.CleanPath (
    cleanPath,
) where

import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mconcat)
#endif
import Data.Text (Text)
import Network.HTTP.Types (hLocation, status301)
import Network.Wai (Application, pathInfo, rawQueryString, responseLBS)

cleanPath
    :: ([Text] -> Either B.ByteString [Text])
    -> B.ByteString
    -> ([Text] -> Application)
    -> Application
cleanPath :: ([Text] -> Either ByteString [Text])
-> ByteString -> ([Text] -> Application) -> Application
cleanPath [Text] -> Either ByteString [Text]
splitter ByteString
prefix [Text] -> Application
app Request
env Response -> IO ResponseReceived
sendResponse =
    case [Text] -> Either ByteString [Text]
splitter ([Text] -> Either ByteString [Text])
-> [Text] -> Either ByteString [Text]
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
env of
        Right [Text]
pieces -> [Text] -> Application
app [Text]
pieces Request
env Response -> IO ResponseReceived
sendResponse
        Left ByteString
p ->
            Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
                Status -> ResponseHeaders -> ByteString -> Response
responseLBS
                    Status
status301
                    [(HeaderName
hLocation, [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString
prefix, ByteString
p, ByteString
suffix])]
                    ByteString
L.empty
  where
    -- include the query string if present
    suffix :: ByteString
suffix =
        case ByteString -> Maybe (Char, ByteString)
B.uncons (ByteString -> Maybe (Char, ByteString))
-> ByteString -> Maybe (Char, ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawQueryString Request
env of
            Maybe (Char, ByteString)
Nothing -> ByteString
B.empty
            Just (Char
'?', ByteString
_) -> Request -> ByteString
rawQueryString Request
env
            Maybe (Char, ByteString)
_ -> Char -> ByteString -> ByteString
B.cons Char
'?' (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawQueryString Request
env