{-# LANGUAGE CPP #-}
module Network.Wai.Middleware.CleanPath
    ( cleanPath
    ) where

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

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 -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ 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