2012-08-06 18:44:41 +04:00
{- # LANGUAGE OverloadedStrings # -}
2013-07-28 14:41:42 +04:00
{- # LANGUAGE RecordWildCards # -}
2012-08-06 18:44:41 +04:00
-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
( reverseProxy
2013-07-25 16:44:23 +04:00
, HostLookup
2013-07-10 10:57:38 +04:00
, TLSConfig ( .. )
2012-08-06 18:44:41 +04:00
) 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
2014-11-15 00:37:18 +03:00
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
2014-11-15 00:37:18 +03:00
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 )
2012-08-06 18:44:41 +04:00
-- | Mapping from virtual hostname to port number.
2013-07-25 16:44:23 +04:00
type HostLookup = ByteString -> IO ( Maybe ProxyAction )
2012-08-06 18:44:41 +04:00
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
2013-07-25 16:44:23 +04:00
-> 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 )
2012-08-06 18:44:41 +04:00
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
2013-07-25 16:44:23 +04:00
getDest req =
2014-07-24 10:42:22 +04:00
case Wai . requestHeaderHost req of
2013-07-25 16:44:23 +04:00
Nothing -> return $ WPRResponse missingHostResponse
Just host -> processHost req host
2014-06-09 14:22:06 +04:00
processHost :: Wai . Request -> S . ByteString -> IO WaiProxyResponse
2013-07-25 16:44:23 +04:00
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'
2012-10-02 23:57:27 +04:00
case mport of
2013-07-25 16:44:23 +04:00
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
]
2012-08-06 18:44:41 +04:00
2013-07-25 16:44:23 +04:00
missingHostResponse :: Wai . Response
2013-11-10 19:04:26 +04:00
missingHostResponse = Wai . responseBuilder
2013-07-25 16:44:23 +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>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 " ) ]
2013-07-25 16:44:23 +04:00
( 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> " )