keter/Keter/Proxy.hs

173 lines
7.4 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
2013-07-28 14:41:42 +04:00
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)
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
import Network.Wai.Application.Static (defaultFileServerSettings,
ssListing, staticApp)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WarpTLS as WarpTLS
2014-06-16 15:43:01 +04:00
import Network.Wai.Middleware.Gzip (gzip, def)
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-07-24 10:42:13 +04:00
run $ gzip def $ withClient useHeader protocol 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
2013-07-25 18:55:45 +04:00
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)
2014-07-24 10:42:13 +04:00
protocol =
case listener of
LPInsecure _ _ -> "http"
LPSecure _ _ _ _ -> "https"
2012-08-09 19:12:32 +04:00
2013-06-03 15:45:52 +04:00
withClient :: Bool -- ^ use incoming request header for IP address
2014-07-24 10:42:13 +04:00
-> ByteString -- ^ protocol, for X-Forwarded-Proto
2013-06-03 15:45:52 +04:00
-> Manager
-> HostLookup
2013-06-03 15:15:13 +04:00
-> Wai.Application
2014-07-24 10:42:13 +04:00
withClient useHeader protocol 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
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-09-21 14:00:20 +04:00
-- Take the host name up until the port number.
mport <- liftIO $ portLookup $ S.takeWhile (/= 58) host
case mport of
Nothing -> return $ WPRResponse $ unknownHostResponse host
2013-07-25 17:18:23 +04:00
Just action -> performAction req action
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
return $ WPRApplication $ 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>")