{-# LANGUAGE CPP #-}

module Network.Wai.Middleware.Vhost (
    vhost,
    redirectWWW,
    redirectTo,
    redirectToLogged,
) where

import qualified Data.ByteString as BS
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mappend)
#endif
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import Network.HTTP.Types as H
import Network.Wai

vhost :: [(Request -> Bool, Application)] -> Application -> Application
vhost :: [(Request -> Bool, Application)] -> Application -> Application
vhost [(Request -> Bool, Application)]
vhosts Application
def Request
req =
    case ((Request -> Bool, Application) -> Bool)
-> [(Request -> Bool, Application)]
-> [(Request -> Bool, Application)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Request -> Bool
b, Application
_) -> Request -> Bool
b Request
req) [(Request -> Bool, Application)]
vhosts of
        [] -> Application
def Request
req
        (Request -> Bool
_, Application
app) : [(Request -> Bool, Application)]
_ -> Application
app Request
req

redirectWWW :: Text -> Application -> Application -- W.MiddleWare
redirectWWW :: Text -> Application -> Application
redirectWWW Text
home =
    Text -> (Request -> Bool) -> Application -> Application
redirectIf
        Text
home
        (Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (ByteString -> ByteString -> Bool
BS.isPrefixOf ByteString
"www") (Maybe ByteString -> Bool)
-> (Request -> Maybe ByteString) -> Request -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"host" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
requestHeaders)

redirectIf :: Text -> (Request -> Bool) -> Application -> Application
redirectIf :: Text -> (Request -> Bool) -> Application -> Application
redirectIf Text
home Request -> Bool
cond Application
app Request
req Response -> IO ResponseReceived
sendResponse =
    if Request -> Bool
cond Request
req
        then Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ByteString -> Response
redirectTo (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
home
        else Application
app Request
req Response -> IO ResponseReceived
sendResponse

redirectTo :: BS.ByteString -> Response
redirectTo :: ByteString -> Response
redirectTo ByteString
location =
    Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS
        Status
H.status301
        [(HeaderName
H.hContentType, ByteString
"text/plain"), (HeaderName
H.hLocation, ByteString
location)]
        ByteString
"Redirect"

redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response
redirectToLogged :: (Text -> IO ()) -> ByteString -> IO Response
redirectToLogged Text -> IO ()
logger ByteString
loc = do
    Text -> IO ()
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"redirecting to: " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Text
TE.decodeUtf8 ByteString
loc
    Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ ByteString -> Response
redirectTo ByteString
loc