@@ -1,5 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.Middleware.Vhost (vhost, redirectWWW) where
2+module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectLogged) where
4import Network.Wai
4import Network.Wai
@@ -7,6 +7,7 @@ import Network.HTTP.Types as H
7import qualified Data.Text.Encoding as TE
7import qualified Data.Text.Encoding as TE
8import Data.Text (Text)
8import Data.Text (Text)
9import qualified Data.ByteString as BS
9import qualified Data.ByteString as BS
10+import Data.Monoid (mappend)
11vhost :: [(Request -> Bool, Application)] -> Application -> Application
12vhost :: [(Request -> Bool, Application)] -> Application -> Application
12vhost vhosts def req =
13vhost vhosts def req =
@@ -15,9 +16,20 @@ vhost vhosts def req =
15 (_, app):_ -> app req
16 (_, app):_ -> app req
17redirectWWW :: Text -> Application -> Application -- W.MiddleWare
18redirectWWW :: Text -> Application -> Application -- W.MiddleWare
18−redirectWWW home app req =
19+redirectWWW home =
19− if maybe True (BS.isPrefixOf "www") $ lookup "host" $ requestHeaders req
20+ redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)
20− then return $ responseLBS H.status301
21+
21− [ ("Content-Type", "text/plain") , ("Location", TE.encodeUtf8 home) ] "Redirect"
22+redirectIf :: Text -> (Request -> Bool) -> Application -> Application
23+redirectIf home cond app req =
25+ then return $ redirectTo $ TE.encodeUtf8 home
22 else app req
26 else app req
28+redirectTo :: BS.ByteString -> Response
29+redirectTo location = responseLBS H.status301
30+ [ ("Content-Type", "text/plain") , ("Location", location) ] "Redirect"
32+redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response
33+redirectToLogged logger loc = do
34+ logger $ "redirecting to: " `mappend` TE.decodeUtf8 loc
35+ return $ redirectTo loc