module Keter.Proxy
( reverseProxy
, HostLookup
, TLSConfig (..)
) where
import Blaze.ByteString.Builder (copyByteString)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Default
import Data.Monoid (mappend)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Vector as V
import qualified Filesystem.Path.CurrentOS as F
import Keter.Types
import Network.HTTP.Conduit (Manager)
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
SetIpHeader (..),
WaiProxyResponse (..),
waiProxyToSettings,
wpsSetIpHeader)
import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite
import Network.HTTP.Types (mkStatus, status200,
status301, status302,
status303, status307,
status404, status500)
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 Network.Wai.Middleware.Gzip (gzip, def)
import Prelude hiding (FilePath, (++))
import WaiAppStatic.Listing (defaultListing)
import System.Timeout.Lifted (timeout)
type HostLookup = ByteString -> IO (Maybe ProxyAction)
reverseProxy :: Bool -> Manager -> HostLookup -> ListeningPort -> IO ()
reverseProxy useHeader manager hostLookup listener =
run $ gzip def $ withClient useHeader manager hostLookup
where
warp host port = Warp.setHost host $ Warp.setPort port Warp.defaultSettings
run =
case listener of
LPInsecure host port -> Warp.runSettings (warp host port)
LPSecure host port cert key -> WarpTLS.runTLS
(WarpTLS.tlsSettings (F.encodeString cert) (F.encodeString key))
(warp host port)
withClient :: Bool
-> Manager
-> HostLookup
-> Wai.Application
withClient useHeader manager portLookup req0 sendResponse =
timeBound (5 * 60 * 1000 * 1000) (waiProxyToSettings getDest def
{ wpsSetIpHeader =
if useHeader
then SIHFromHeader
else SIHFromSocket
} manager req0 sendResponse)
where
timeBound us f = do
mres <- timeout us f
case mres of
Just res -> return res
Nothing -> sendResponse $ Wai.responseLBS status500 [] "timeBound"
getDest :: Wai.Request -> IO WaiProxyResponse
getDest req =
case lookup "host" $ Wai.requestHeaders req of
Nothing -> return $ WPRResponse missingHostResponse
Just host -> processHost req host
processHost :: Wai.Request -> S.ByteString -> IO WaiProxyResponse
processHost req host = do
mport <- liftIO $ portLookup host
case mport of
Nothing -> return $ WPRResponse $ unknownHostResponse host
Just action -> performAction req action
performAction _ (PAPort port) =
return $ WPRProxyDest $ ProxyDest "127.0.0.1" port
performAction _ (PAStatic StaticFilesConfig {..}) = do
return $ WPRApplication $ staticApp (defaultFileServerSettings sfconfigRoot)
{ ssListing =
if sfconfigListings
then Just defaultListing
else Nothing
}
performAction req (PARedirect config) = return $ WPRResponse $ redirectApp config req
performAction _ (PAReverseProxy config) = return $ WPRApplication $ Rewrite.simpleReverseProxy manager config
redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response
redirectApp RedirectConfig {..} req =
V.foldr checkAction noAction redirconfigActions
where
checkAction (RedirectAction SPAny dest msecure) other
| checkSecure msecure req = sendTo $ mkUrl dest
| otherwise = other
checkAction (RedirectAction (SPSpecific path) dest msecure) other
| encodeUtf8 path == Wai.rawPathInfo req && checkSecure msecure req =
sendTo $ mkUrl dest
| otherwise = other
checkSecure Nothing _ = True
checkSecure (Just needsSecure) req = needsSecure == Wai.isSecure req
noAction = Wai.responseBuilder
status404
[("Content-Type", "text/plain")]
(copyByteString "File not found")
sendTo url = Wai.responseBuilder
status
[("Location", url)]
(copyByteString url)
status =
case redirconfigStatus of
301 -> status301
302 -> status302
303 -> status303
307 -> status307
i -> mkStatus i $ S8.pack $ show i
mkUrl (RDUrl url) = encodeUtf8 url
mkUrl (RDPrefix isSecure host mport) = S.concat
[ if isSecure then "https://" else "http://"
, encodeUtf8 host
, case mport of
Nothing -> ""
Just port
| isSecure && port == 443 -> ""
| not isSecure && port == 80 -> ""
| otherwise -> S8.pack $ ':' : show port
, Wai.rawPathInfo req
, Wai.rawQueryString req
]
missingHostResponse :: Wai.Response
missingHostResponse = Wai.responseBuilder
status200
[("Content-Type", "text/html; charset=utf-8")]
$ copyByteString "<!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 host = Wai.responseBuilder
status200
[("Content-Type", "text/html; charset=utf-8")]
(copyByteString "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>"
`mappend` copyByteString host
`mappend` copyByteString "</code>, is not recognized.</p></body></html>")