{-# LANGUAGE CPP #-}
 module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where

import Network.Wai

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

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 (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