{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE CPP #-}
-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
    ( reverseProxy
    , HostLookup
    , TLSConfig (..)
    ) where

import           Blaze.ByteString.Builder          (copyByteString)
import           Control.Applicative               ((<$>), (<|>))
import           Control.Monad.IO.Class            (liftIO)
import qualified Data.ByteString                   as S
import qualified Data.ByteString.Char8             as S8
import qualified Data.CaseInsensitive              as CI
#if MIN_VERSION_http_reverse_proxy(0,6,0)
import           Network.Wai.Middleware.Gzip       (def)
#else
import           Data.Default                      (Default (..))
#endif
import           Data.Monoid                       (mappend, mempty)
import           Data.Text.Encoding                (decodeUtf8With, encodeUtf8)
import           Data.Text.Encoding.Error          (lenientDecode)
import qualified Data.Vector                       as V
import           Keter.Types
import           Keter.Types.Middleware
import           Network.HTTP.Conduit              (Manager)

#if MIN_VERSION_http_reverse_proxy(0,4,2)
import           Network.HTTP.ReverseProxy         (defaultLocalWaiProxySettings)
#endif

#if MIN_VERSION_http_reverse_proxy(0,6,0)
import           Network.HTTP.ReverseProxy         (defaultWaiProxySettings)
#endif

import           Network.HTTP.ReverseProxy         (ProxyDest (ProxyDest),
                                                    SetIpHeader (..),
                                                    WaiProxyResponse (..),
                                                    LocalWaiProxySettings,
                                                    setLpsTimeBound,
                                                    waiProxyToSettings,
                                                    wpsSetIpHeader,
                                                    wpsGetDest)
import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite
import           Network.HTTP.Types                (mkStatus, status200,
                                                    status301, status302,
                                                    status303, status307,
                                                    status404)
import qualified Network.Wai                       as Wai
import           Network.Wai.Application.Static    (defaultFileServerSettings,
                                                    ssListing, staticApp)
import qualified Network.Wai.Handler.Warp          as Warp
import qualified Network.Wai.Handler.WarpTLS       as WarpTLS
import qualified Network.TLS.SessionManager        as TLSSession
import           Network.Wai.Middleware.Gzip       (gzip, GzipSettings(..), GzipFiles(..))
import           Prelude                           hiding (FilePath, (++))
import           WaiAppStatic.Listing              (defaultListing)
import qualified Network.TLS as TLS

#if !MIN_VERSION_http_reverse_proxy(0,6,0)
defaultWaiProxySettings = def
#endif

#if !MIN_VERSION_http_reverse_proxy(0,4,2)
defaultLocalWaiProxySettings = def
#endif


-- | Mapping from virtual hostname to port number.
type HostLookup = ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))

reverseProxy :: Bool
             -> Int -> Manager -> HostLookup -> ListeningPort -> IO ()
reverseProxy :: Bool -> Int -> Manager -> HostLookup -> ListeningPort -> IO ()
reverseProxy Bool
useHeader Int
timeBound Manager
manager HostLookup
hostLookup ListeningPort
listener =
    Application -> IO ()
run (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ GzipSettings -> Middleware
gzip GzipSettings
forall a. Default a => a
def{gzipFiles :: GzipFiles
gzipFiles = GzipFiles -> GzipFiles
GzipPreCompressed GzipFiles
GzipIgnore} Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Int -> Manager -> HostLookup -> Application
withClient Bool
isSecure Bool
useHeader Int
timeBound Manager
manager HostLookup
hostLookup
  where
    warp :: HostPreference -> Int -> Settings
warp HostPreference
host Int
port = HostPreference -> Settings -> Settings
Warp.setHost HostPreference
host (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Int -> Settings -> Settings
Warp.setPort Int
port Settings
Warp.defaultSettings
    (Application -> IO ()
run, Bool
isSecure) =
        case ListeningPort
listener of
            LPInsecure HostPreference
host Int
port -> (Settings -> Application -> IO ()
Warp.runSettings (HostPreference -> Int -> Settings
warp HostPreference
host Int
port), Bool
False)
            LPSecure HostPreference
host Int
port FilePath
cert Vector FilePath
chainCerts FilePath
key Bool
session -> (TLSSettings -> Settings -> Application -> IO ()
WarpTLS.runTLS
                (HostLookup -> Bool -> TLSSettings -> TLSSettings
connectClientCertificates HostLookup
hostLookup Bool
session (TLSSettings -> TLSSettings) -> TLSSettings -> TLSSettings
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath -> TLSSettings
WarpTLS.tlsSettingsChain
                    FilePath
cert
                    (Vector FilePath -> [FilePath]
forall a. Vector a -> [a]
V.toList Vector FilePath
chainCerts)
                    FilePath
key)
                (HostPreference -> Int -> Settings
warp HostPreference
host Int
port), Bool
True)

connectClientCertificates :: HostLookup -> Bool -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings
connectClientCertificates :: HostLookup -> Bool -> TLSSettings -> TLSSettings
connectClientCertificates HostLookup
hl Bool
session TLSSettings
s =
    let
        newHooks :: ServerHooks
newHooks@TLS.ServerHooks{Maybe ([ByteString] -> IO ByteString)
IO Bool
[ExtensionRaw] -> IO [ExtensionRaw]
Maybe FilePath -> IO Credentials
CertificateChain -> IO CertificateUsage
Version -> [Cipher] -> Cipher
Measurement -> IO Bool
onClientCertificate :: ServerHooks -> CertificateChain -> IO CertificateUsage
onUnverifiedClientCert :: ServerHooks -> IO Bool
onCipherChoosing :: ServerHooks -> Version -> [Cipher] -> Cipher
onServerNameIndication :: ServerHooks -> Maybe FilePath -> IO Credentials
onNewHandshake :: ServerHooks -> Measurement -> IO Bool
onALPNClientSuggest :: ServerHooks -> Maybe ([ByteString] -> IO ByteString)
onEncryptedExtensionsCreating :: ServerHooks -> [ExtensionRaw] -> IO [ExtensionRaw]
onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw]
onALPNClientSuggest :: Maybe ([ByteString] -> IO ByteString)
onNewHandshake :: Measurement -> IO Bool
onServerNameIndication :: Maybe FilePath -> IO Credentials
onCipherChoosing :: Version -> [Cipher] -> Cipher
onUnverifiedClientCert :: IO Bool
onClientCertificate :: CertificateChain -> IO CertificateUsage
..} = TLSSettings -> ServerHooks
WarpTLS.tlsServerHooks TLSSettings
s
        -- todo: add nested lookup
        newOnServerNameIndication :: Maybe FilePath -> IO Credentials
newOnServerNameIndication (Just FilePath
n) =
             Credentials
-> ((ProxyAction, Credentials) -> Credentials)
-> Maybe (ProxyAction, Credentials)
-> Credentials
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Credentials
forall a. Monoid a => a
mempty (ProxyAction, Credentials) -> Credentials
forall a b. (a, b) -> b
snd (Maybe (ProxyAction, Credentials) -> Credentials)
-> IO (Maybe (ProxyAction, Credentials)) -> IO Credentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostLookup
hl (FilePath -> ByteString
S8.pack FilePath
n)
        newOnServerNameIndication Maybe FilePath
Nothing =
             Credentials -> IO Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials
forall a. Monoid a => a
mempty -- we could return default certificate here
    in
        TLSSettings
s { tlsServerHooks :: ServerHooks
WarpTLS.tlsServerHooks = ServerHooks
newHooks{onServerNameIndication :: Maybe FilePath -> IO Credentials
TLS.onServerNameIndication = Maybe FilePath -> IO Credentials
newOnServerNameIndication}
          , tlsSessionManagerConfig :: Maybe Config
WarpTLS.tlsSessionManagerConfig = if Bool
session then (Config -> Maybe Config
forall a. a -> Maybe a
Just Config
TLSSession.defaultConfig) else Maybe Config
forall a. Maybe a
Nothing }

withClient :: Bool -- ^ is secure?
           -> Bool -- ^ use incoming request header for IP address
           -> Int  -- ^ time bound for connections
           -> Manager
           -> HostLookup
           -> Wai.Application
withClient :: Bool -> Bool -> Int -> Manager -> HostLookup -> Application
withClient Bool
isSecure Bool
useHeader Int
bound Manager
manager HostLookup
hostLookup =
    (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings
       (FilePath -> Request -> IO WaiProxyResponse
forall a. HasCallStack => FilePath -> a
error FilePath
"First argument to waiProxyToSettings forced, even thought wpsGetDest provided")
       WaiProxySettings
defaultWaiProxySettings
        { wpsSetIpHeader :: SetIpHeader
wpsSetIpHeader =
            if Bool
useHeader
                then SetIpHeader
SIHFromHeader
                else SetIpHeader
SIHFromSocket
        ,  wpsGetDest :: Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest = (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
forall a. a -> Maybe a
Just Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
getDest
        } Manager
manager
  where
    protocol :: ByteString
protocol
        | Bool
isSecure = ByteString
"https"
        | Bool
otherwise = ByteString
"http"

    -- FIXME This is a workaround for
    -- https://github.com/snoyberg/keter/issues/29. After some research, it
    -- seems like Warp is behaving properly here. I'm still not certain why the
    -- http call (from http-conduit) inside waiProxyToSettings could ever block
    -- infinitely without the server it's connecting to going down, so that
    -- requires more research. Meanwhile, this prevents the file descriptor
    -- leak from occurring.

    addjustGlobalBound :: Maybe Int -> LocalWaiProxySettings
    addjustGlobalBound :: Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Maybe Int
to = Maybe Int
go Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings
`setLpsTimeBound` LocalWaiProxySettings
defaultLocalWaiProxySettings
      where
        go :: Maybe Int
go = case Maybe Int
to Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
bound of
               Just Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
               Maybe Int
_              -> Maybe Int
forall a. Maybe a
Nothing

    getDest :: Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
    getDest :: Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
getDest Request
req =
        case Request -> Maybe ByteString
Wai.requestHeaderHost Request
req of
            Maybe ByteString
Nothing -> (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse Response
missingHostResponse)
            Just ByteString
host -> Request
-> ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)
processHost Request
req ByteString
host

    processHost :: Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)
    processHost :: Request
-> ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)
processHost Request
req ByteString
host = do
        -- Perform two levels of lookup. First: look up the entire host. If
        -- that fails, try stripping off any port number and try again.
        Maybe (ProxyAction, Credentials)
mport <- IO (Maybe (ProxyAction, Credentials))
-> IO (Maybe (ProxyAction, Credentials))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ProxyAction, Credentials))
 -> IO (Maybe (ProxyAction, Credentials)))
-> IO (Maybe (ProxyAction, Credentials))
-> IO (Maybe (ProxyAction, Credentials))
forall a b. (a -> b) -> a -> b
$ do
            Maybe (ProxyAction, Credentials)
mport1 <- HostLookup
hostLookup ByteString
host
            case Maybe (ProxyAction, Credentials)
mport1 of
                Just (ProxyAction, Credentials)
_ -> Maybe (ProxyAction, Credentials)
-> IO (Maybe (ProxyAction, Credentials))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ProxyAction, Credentials)
mport1
                Maybe (ProxyAction, Credentials)
Nothing -> do
                    let host' :: ByteString
host' = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
58) ByteString
host
                    if ByteString
host' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
host
                        then Maybe (ProxyAction, Credentials)
-> IO (Maybe (ProxyAction, Credentials))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ProxyAction, Credentials)
forall a. Maybe a
Nothing
                        else HostLookup
hostLookup ByteString
host'
        case Maybe (ProxyAction, Credentials)
mport of
            Maybe (ProxyAction, Credentials)
Nothing -> (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse) -> Response -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> Response
unknownHostResponse ByteString
host)
            Just ((ProxyActionRaw
action, Bool
requiresSecure), Credentials
_)
                | Bool
requiresSecure Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSecure -> ByteString
-> Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *).
Monad m =>
ByteString
-> Request -> m (LocalWaiProxySettings, WaiProxyResponse)
performHttpsRedirect ByteString
host Request
req
                | Bool
otherwise -> Request
-> ProxyActionRaw -> IO (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *).
Monad m =>
Request
-> ProxyActionRaw -> m (LocalWaiProxySettings, WaiProxyResponse)
performAction Request
req ProxyActionRaw
action

    performHttpsRedirect :: ByteString
-> Request -> m (LocalWaiProxySettings, WaiProxyResponse)
performHttpsRedirect ByteString
host =
        (LocalWaiProxySettings, WaiProxyResponse)
-> m (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocalWaiProxySettings, WaiProxyResponse)
 -> m (LocalWaiProxySettings, WaiProxyResponse))
-> (Request -> (LocalWaiProxySettings, WaiProxyResponse))
-> Request
-> m (LocalWaiProxySettings, WaiProxyResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Maybe Int
forall a. Maybe a
Nothing,) (WaiProxyResponse -> (LocalWaiProxySettings, WaiProxyResponse))
-> (Request -> WaiProxyResponse)
-> Request
-> (LocalWaiProxySettings, WaiProxyResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse)
-> (Request -> Response) -> Request -> WaiProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedirectConfig -> Request -> Response
redirectApp RedirectConfig
config
      where
        host' :: CI Text
host' = Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Text -> CI Text) -> Text -> CI Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
host
        config :: RedirectConfig
config = RedirectConfig :: Set (CI Text)
-> Int -> Vector RedirectAction -> SSLConfig -> RedirectConfig
RedirectConfig
            { redirconfigHosts :: Set (CI Text)
redirconfigHosts = Set (CI Text)
forall a. Monoid a => a
mempty
            , redirconfigStatus :: Int
redirconfigStatus = Int
301
            , redirconfigActions :: Vector RedirectAction
redirconfigActions = RedirectAction -> Vector RedirectAction
forall a. a -> Vector a
V.singleton (RedirectAction -> Vector RedirectAction)
-> RedirectAction -> Vector RedirectAction
forall a b. (a -> b) -> a -> b
$ SourcePath -> RedirectDest -> RedirectAction
RedirectAction SourcePath
SPAny
                                 (RedirectDest -> RedirectAction) -> RedirectDest -> RedirectAction
forall a b. (a -> b) -> a -> b
$ Bool -> CI Text -> Maybe Int -> RedirectDest
RDPrefix Bool
True CI Text
host' Maybe Int
forall a. Maybe a
Nothing
            , redirconfigSsl :: SSLConfig
redirconfigSsl = SSLConfig
SSLTrue
            }

    performAction :: Request
-> ProxyActionRaw -> m (LocalWaiProxySettings, WaiProxyResponse)
performAction Request
req (PAPort Int
port Maybe Int
tbound) =
        (LocalWaiProxySettings, WaiProxyResponse)
-> m (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Maybe Int
tbound, Request -> ProxyDest -> WaiProxyResponse
WPRModifiedRequest Request
req' (ProxyDest -> WaiProxyResponse) -> ProxyDest -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ProxyDest
ProxyDest ByteString
"127.0.0.1" Int
port)
      where
        req' :: Request
req' = Request
req
            { requestHeaders :: RequestHeaders
Wai.requestHeaders = (HeaderName
"X-Forwarded-Proto", ByteString
protocol)
                                 (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: Request -> RequestHeaders
Wai.requestHeaders Request
req
            }
    performAction Request
_ (PAStatic StaticFilesConfig {Bool
FilePath
[MiddlewareConfig]
Maybe Int
Set (CI Text)
SSLConfig
sfconfigSsl :: StaticFilesConfig -> SSLConfig
sfconfigTimeout :: StaticFilesConfig -> Maybe Int
sfconfigMiddleware :: StaticFilesConfig -> [MiddlewareConfig]
sfconfigListings :: StaticFilesConfig -> Bool
sfconfigHosts :: StaticFilesConfig -> Set (CI Text)
sfconfigRoot :: StaticFilesConfig -> FilePath
sfconfigSsl :: SSLConfig
sfconfigTimeout :: Maybe Int
sfconfigMiddleware :: [MiddlewareConfig]
sfconfigListings :: Bool
sfconfigHosts :: Set (CI Text)
sfconfigRoot :: FilePath
..}) =
        (LocalWaiProxySettings, WaiProxyResponse)
-> m (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Maybe Int
sfconfigTimeout, Application -> WaiProxyResponse
WPRApplication (Application -> WaiProxyResponse)
-> Application -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ [MiddlewareConfig] -> Middleware
processMiddleware [MiddlewareConfig]
sfconfigMiddleware Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp (FilePath -> StaticSettings
defaultFileServerSettings FilePath
sfconfigRoot)
            { ssListing :: Maybe Listing
ssListing =
                if Bool
sfconfigListings
                    then Listing -> Maybe Listing
forall a. a -> Maybe a
Just Listing
defaultListing
                    else Maybe Listing
forall a. Maybe a
Nothing
            })
    performAction Request
req (PARedirect RedirectConfig
config) = (LocalWaiProxySettings, WaiProxyResponse)
-> m (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Maybe Int
forall a. Maybe a
Nothing, Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse) -> Response -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ RedirectConfig -> Request -> Response
redirectApp RedirectConfig
config Request
req)
    performAction Request
_ (PAReverseProxy ReverseProxyConfig
config [MiddlewareConfig]
rpconfigMiddleware Maybe Int
tbound) =
       (LocalWaiProxySettings, WaiProxyResponse)
-> m (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Maybe Int
tbound, Application -> WaiProxyResponse
WPRApplication (Application -> WaiProxyResponse)
-> Application -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ [MiddlewareConfig] -> Middleware
processMiddleware [MiddlewareConfig]
rpconfigMiddleware Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Manager -> ReverseProxyConfig -> Application
Rewrite.simpleReverseProxy Manager
manager ReverseProxyConfig
config)

redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response
redirectApp :: RedirectConfig -> Request -> Response
redirectApp RedirectConfig {Int
Set (CI Text)
Vector RedirectAction
SSLConfig
redirconfigSsl :: SSLConfig
redirconfigActions :: Vector RedirectAction
redirconfigStatus :: Int
redirconfigHosts :: Set (CI Text)
redirconfigSsl :: RedirectConfig -> SSLConfig
redirconfigActions :: RedirectConfig -> Vector RedirectAction
redirconfigStatus :: RedirectConfig -> Int
redirconfigHosts :: RedirectConfig -> Set (CI Text)
..} Request
req =
    (RedirectAction -> Response -> Response)
-> Response -> Vector RedirectAction -> Response
forall a b. (a -> b -> b) -> b -> Vector a -> b
V.foldr RedirectAction -> Response -> Response
checkAction Response
noAction Vector RedirectAction
redirconfigActions
  where
    checkAction :: RedirectAction -> Response -> Response
checkAction (RedirectAction SourcePath
SPAny RedirectDest
dest) Response
_ = ByteString -> Response
sendTo (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ RedirectDest -> ByteString
mkUrl RedirectDest
dest
    checkAction (RedirectAction (SPSpecific Text
path) RedirectDest
dest) Response
other
        | Text -> ByteString
encodeUtf8 Text
path ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Request -> ByteString
Wai.rawPathInfo Request
req = ByteString -> Response
sendTo (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ RedirectDest -> ByteString
mkUrl RedirectDest
dest
        | Bool
otherwise = Response
other

    noAction :: Response
noAction = Status -> RequestHeaders -> Builder -> Response
Wai.responseBuilder
        Status
status404
        [(HeaderName
"Content-Type", ByteString
"text/plain")]
        (ByteString -> Builder
copyByteString ByteString
"File not found")

    sendTo :: ByteString -> Response
sendTo ByteString
url = Status -> RequestHeaders -> Builder -> Response
Wai.responseBuilder
        Status
status
        [(HeaderName
"Location", ByteString
url)]
        (ByteString -> Builder
copyByteString ByteString
url)

    status :: Status
status =
        case Int
redirconfigStatus of
            Int
301 -> Status
status301
            Int
302 -> Status
status302
            Int
303 -> Status
status303
            Int
307 -> Status
status307
            Int
i   -> Int -> ByteString -> Status
mkStatus Int
i (ByteString -> Status) -> ByteString -> Status
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
S8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i

    mkUrl :: RedirectDest -> ByteString
mkUrl (RDUrl Text
url) = Text -> ByteString
encodeUtf8 Text
url
    mkUrl (RDPrefix Bool
isSecure CI Text
host Maybe Int
mport) = [ByteString] -> ByteString
S.concat
        [ if Bool
isSecure then ByteString
"https://" else ByteString
"http://"
        , Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ CI Text -> Text
forall s. CI s -> s
CI.original CI Text
host
        , case Maybe Int
mport of
            Maybe Int
Nothing -> ByteString
""
            Just Int
port
                | Bool
isSecure Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 -> ByteString
""
                | Bool -> Bool
not Bool
isSecure Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
80 -> ByteString
""
                | Bool
otherwise -> FilePath -> ByteString
S8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ Char
':' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Int -> FilePath
forall a. Show a => a -> FilePath
show Int
port
        , Request -> ByteString
Wai.rawPathInfo Request
req
        , Request -> ByteString
Wai.rawQueryString Request
req
        ]

missingHostResponse :: Wai.Response
missingHostResponse :: Response
missingHostResponse = Status -> RequestHeaders -> Builder -> Response
Wai.responseBuilder
    Status
status200
    [(HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")]
    (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
copyByteString ByteString
"<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You did not provide a virtual hostname for this request.</p></body></html>"

unknownHostResponse :: ByteString -> Wai.Response
unknownHostResponse :: ByteString -> Response
unknownHostResponse ByteString
host = Status -> RequestHeaders -> Builder -> Response
Wai.responseBuilder
    Status
status200
    [(HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")]
    (ByteString -> Builder
copyByteString ByteString
"<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>"
     Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
copyByteString ByteString
host
     Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
copyByteString ByteString
"</code>, is not recognized.</p></body></html>")