keter/Keter/Proxy.hs

197 lines
8.5 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
2013-07-28 14:41:42 +04:00
{-# LANGUAGE RecordWildCards #-}
-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
( reverseProxy
, HostLookup
2013-07-10 10:57:38 +04:00
, TLSConfig (..)
) where
2013-07-28 14:41:42 +04:00
import Blaze.ByteString.Builder (copyByteString)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
2014-09-21 11:42:26 +04:00
import qualified Data.CaseInsensitive as CI
import Data.Default (Default(..))
2014-10-20 09:24:23 +04:00
import Data.Monoid (mappend, mempty)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
2013-07-28 14:41:42 +04:00
import qualified Data.Vector as V
import qualified Filesystem.Path.CurrentOS as F
import Keter.Types
2014-12-12 19:09:07 +03:00
import Keter.Types.Middleware
2013-07-28 14:41:42 +04:00
import Network.HTTP.Conduit (Manager)
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
SetIpHeader (..),
WaiProxyResponse (..),
waiProxyToSettings,
wpsSetIpHeader)
2013-07-25 15:18:32 +04:00
import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite
2013-07-28 14:41:42 +04:00
import Network.HTTP.Types (mkStatus, status200,
status301, status302,
status303, status307,
2013-11-07 18:52:02 +04:00
status404, status500)
2013-07-28 14:41:42 +04:00
import qualified Network.Wai as Wai
2014-12-15 20:25:11 +03:00
import Network.Wai.Application.Static (defaultFileServerSettings,
2013-07-28 14:41:42 +04:00
ssListing, staticApp)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WarpTLS as WarpTLS
import Network.Wai.Middleware.Gzip (gzip)
2013-07-28 14:41:42 +04:00
import Prelude hiding (FilePath, (++))
import WaiAppStatic.Listing (defaultListing)
2013-11-07 18:52:02 +04:00
import System.Timeout.Lifted (timeout)
-- | Mapping from virtual hostname to port number.
type HostLookup = ByteString -> IO (Maybe ProxyAction)
2014-07-24 10:42:13 +04:00
reverseProxy :: Bool
-> Manager -> HostLookup -> ListeningPort -> IO ()
2013-07-25 18:55:45 +04:00
reverseProxy useHeader manager hostLookup listener =
2014-10-20 09:24:23 +04:00
run $ gzip def $ withClient isSecure useHeader manager hostLookup
2013-07-25 18:55:45 +04:00
where
2014-06-09 14:30:54 +04:00
warp host port = Warp.setHost host $ Warp.setPort port Warp.defaultSettings
2014-10-20 09:24:23 +04:00
(run, isSecure) =
2013-07-25 18:55:45 +04:00
case listener of
2014-10-20 09:24:23 +04:00
LPInsecure host port -> (Warp.runSettings (warp host port), False)
LPSecure host port cert key -> (WarpTLS.runTLS
2013-07-25 18:55:45 +04:00
(WarpTLS.tlsSettings (F.encodeString cert) (F.encodeString key))
2014-10-20 09:24:23 +04:00
(warp host port), True)
2012-08-09 19:12:32 +04:00
2014-10-20 09:24:23 +04:00
withClient :: Bool -- ^ is secure?
-> Bool -- ^ use incoming request header for IP address
2013-06-03 15:45:52 +04:00
-> Manager
-> HostLookup
2013-06-03 15:15:13 +04:00
-> Wai.Application
2014-10-20 09:24:23 +04:00
withClient isSecure useHeader manager portLookup req0 sendResponse =
2014-06-09 14:22:06 +04:00
timeBound (5 * 60 * 1000 * 1000) (waiProxyToSettings getDest def
2013-06-03 15:45:52 +04:00
{ wpsSetIpHeader =
if useHeader
then SIHFromHeader
else SIHFromSocket
2014-06-09 14:30:54 +04:00
} manager req0 sendResponse)
where
2014-10-20 09:24:23 +04:00
protocol
| isSecure = "https"
| otherwise = "http"
2013-11-07 18:52:02 +04:00
-- FIXME This is a temporary 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.
2014-06-09 14:30:54 +04:00
timeBound us f = do
2013-11-07 18:52:02 +04:00
mres <- timeout us f
case mres of
Just res -> return res
2014-06-09 14:22:06 +04:00
Nothing -> sendResponse $ Wai.responseLBS status500 [] "timeBound"
getDest :: Wai.Request -> IO WaiProxyResponse
getDest req =
2014-07-24 10:42:22 +04:00
case Wai.requestHeaderHost req of
Nothing -> return $ WPRResponse missingHostResponse
Just host -> processHost req host
2014-06-09 14:22:06 +04:00
processHost :: Wai.Request -> S.ByteString -> IO WaiProxyResponse
processHost req host = do
2014-11-07 03:05:49 +03:00
-- Perform two levels of lookup. First: look up the entire host. If
-- that fails, try stripping off any port number and try again.
mport <- liftIO $ do
mport1 <- portLookup host
case mport1 of
Just _ -> return mport1
Nothing -> do
let host' = S.takeWhile (/= 58) host
if host' == host
then return Nothing
else portLookup host'
case mport of
Nothing -> return $ WPRResponse $ unknownHostResponse host
2014-10-20 09:24:23 +04:00
Just (action, requiresSecure)
| requiresSecure && not isSecure -> performHttpsRedirect host req
| otherwise -> performAction req action
performHttpsRedirect host =
return . WPRResponse . redirectApp config
where
host' = CI.mk $ decodeUtf8With lenientDecode host
config = RedirectConfig
{ redirconfigHosts = mempty
, redirconfigStatus = 301
, redirconfigActions = V.singleton $ RedirectAction SPAny
$ RDPrefix True host' Nothing
}
2012-10-21 09:07:26 +04:00
2014-07-24 10:42:13 +04:00
performAction req (PAPort port) =
return $ WPRModifiedRequest req' $ ProxyDest "127.0.0.1" port
where
req' = req
{ Wai.requestHeaders = ("X-Forwarded-Proto", protocol)
: Wai.requestHeaders req
}
2014-06-09 14:22:06 +04:00
performAction _ (PAStatic StaticFilesConfig {..}) = do
2014-12-12 19:09:07 +03:00
return $ WPRApplication $ processMiddleware sfconfigMiddleware $ staticApp (defaultFileServerSettings sfconfigRoot)
2013-07-25 17:18:23 +04:00
{ ssListing =
if sfconfigListings
then Just defaultListing
else Nothing
2014-06-09 14:22:06 +04:00
}
2013-07-25 17:18:23 +04:00
performAction req (PARedirect config) = return $ WPRResponse $ redirectApp config req
2014-06-09 14:22:06 +04:00
performAction _ (PAReverseProxy config) = return $ WPRApplication $ Rewrite.simpleReverseProxy manager config
2013-07-25 17:18:23 +04:00
redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response
redirectApp RedirectConfig {..} req =
V.foldr checkAction noAction redirconfigActions
2012-10-21 09:07:26 +04:00
where
2013-07-25 17:18:23 +04:00
checkAction (RedirectAction SPAny dest) _ = sendTo $ mkUrl dest
checkAction (RedirectAction (SPSpecific path) dest) other
| encodeUtf8 path == Wai.rawPathInfo req = sendTo $ mkUrl dest
| otherwise = other
2013-11-10 19:04:26 +04:00
noAction = Wai.responseBuilder
2013-07-25 17:18:23 +04:00
status404
[("Content-Type", "text/plain")]
(copyByteString "File not found")
2013-11-10 19:04:26 +04:00
sendTo url = Wai.responseBuilder
2013-07-25 17:18:23 +04:00
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
2013-08-12 18:05:07 +04:00
mkUrl (RDPrefix isSecure host mport) = S.concat
2013-07-25 17:18:23 +04:00
[ if isSecure then "https://" else "http://"
2014-09-21 11:42:26 +04:00
, encodeUtf8 $ CI.original host
2013-08-12 18:05:07 +04:00
, case mport of
Nothing -> ""
Just port
| isSecure && port == 443 -> ""
| not isSecure && port == 80 -> ""
| otherwise -> S8.pack $ ':' : show port
2012-10-21 09:07:26 +04:00
, Wai.rawPathInfo req
, Wai.rawQueryString req
]
missingHostResponse :: Wai.Response
2013-11-10 19:04:26 +04:00
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
2013-11-10 19:04:26 +04:00
unknownHostResponse host = Wai.responseBuilder
2013-06-03 15:15:13 +04:00
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>")