← Back to branch summary

~ubuntu-branches/ubuntu/vivid/haskell-wai-extra/vivid-proposed

« back to all changes in this revision

Viewing changes to Network/Wai/Middleware/Vhost.hs

  • Committer: Package Import Robot
  • Author(s): Joachim Breitner
  • Date: 2014-05-03 10:15:30 UTC
  • mfrom: (2.2.6 sid)
  • Revision ID: package-import@ubuntu.com-20140503101530-9e99lxx6x6xd2o9o
Tags: 2.1.1-1
New upstream release

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Middleware/Vhost.hs
1
1
{-# LANGUAGE OverloadedStrings #-}
2
 
module Network.Wai.Middleware.Vhost (vhost, redirectWWW) where
 
2
module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where
3
3
 
4
4
import Network.Wai
5
5
 
7
7
import qualified Data.Text.Encoding as TE
8
8
import Data.Text (Text)
9
9
import qualified Data.ByteString as BS
 
10
import Data.Monoid (mappend)
10
11
 
11
12
vhost :: [(Request -> Bool, Application)] -> Application -> Application
12
13
vhost vhosts def req =
15
16
        (_, app):_ -> app req
16
17
 
17
18
redirectWWW :: Text -> Application -> Application -- W.MiddleWare
18
 
redirectWWW home app req =
19
 
  if BS.isPrefixOf "www" $ serverName req
20
 
    then return $ responseLBS H.status301
21
 
          [ ("Content-Type", "text/plain") , ("Location", TE.encodeUtf8 home) ] "Redirect"
 
19
redirectWWW home =
 
20
  redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)
 
21
 
 
22
redirectIf :: Text -> (Request -> Bool) -> Application -> Application
 
23
redirectIf home cond app req =
 
24
  if cond req
 
25
    then return $ redirectTo $ TE.encodeUtf8 home
22
26
    else app req
23
27
 
 
28
redirectTo :: BS.ByteString -> Response
 
29
redirectTo location = responseLBS H.status301
 
30
    [ ("Content-Type", "text/plain") , ("Location", location) ] "Redirect"
 
31
 
 
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