1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
{-# LANGUAGE OverloadedStrings #-}
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
import Data.Monoid (mappend)
vhost :: [(Request -> Bool, Application)] -> Application -> Application
vhost vhosts def req =
case filter (\(b, _) -> b req) vhosts of
[] -> def req
(_, app):_ -> app req
redirectWWW :: Text -> Application -> Application -- W.MiddleWare
redirectWWW home =
redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)
redirectIf :: Text -> (Request -> Bool) -> Application -> Application
redirectIf home cond app req sendResponse =
if cond req
then sendResponse $ redirectTo $ TE.encodeUtf8 home
else app req sendResponse
redirectTo :: BS.ByteString -> Response
redirectTo location = responseLBS H.status301
[ ("Content-Type", "text/plain") , ("Location", location) ] "Redirect"
redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response
redirectToLogged logger loc = do
logger $ "redirecting to: " `mappend` TE.decodeUtf8 loc
return $ redirectTo loc
|
