snoyberg/keter
1
1
Fork 0
mirror of https://github.com/snoyberg/keter.git synced 2024-12-12 14:06:10 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #144 from tolysz/latest

Browse Source 
Initial implementation of SNI.
This commit is contained in:
Christopher Reichert 2016-05-27 07:57:29 -05:00
commit db77223b16
9 changed files with 112 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -14,7 +14,7 @@ matrix:
before_install:
- travis_retry sudo add-apt-repository -y ppa:hvr/ghc
- travis_retry sudo apt-get update
- travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
- travis_retry sudo apt-get install --force-yes -y cabal-install-$CABALVER ghc-$GHCVER
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH
- cabal --version

38
Keter/App.hs
View File

@ -28,7 +28,7 @@ import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Monoid ((<>), mempty)
import qualified Data.Set as Set
import Data.Text (pack, unpack)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
@ -49,6 +49,7 @@ import System.IO (hClose)
import System.Posix.Files (fileAccess)
import System.Posix.Types (EpochTime, GroupID, UserID)
import System.Timeout (timeout)
import qualified Network.TLS as TLS
data App = App
{ appModTime :: !(TVar (Maybe EpochTime))
@ -122,7 +123,7 @@ withConfig asc aid (AIBundle fp modtime) f = bracketOnError
withReservations :: AppStartConfig
-> AppId
-> BundleConfig
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a)
-> IO a
withReservations asc aid bconfig f = withActions asc bconfig $ \wacs backs actions -> bracketOnError
(reserveHosts (ascLog asc) (ascHostManager asc) aid $ Map.keysSet actions)
@ -131,20 +132,31 @@ withReservations asc aid bconfig f = withActions asc bconfig $ \wacs backs actio
withActions :: AppStartConfig
-> BundleConfig
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a)
-> IO a
withActions asc bconfig f =
loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty
where
loop [] wacs backs actions = f wacs backs actions
loop (Stanza (StanzaWebApp wac) rs:stanzas) wacs backs actions = bracketOnError
(getPort (ascLog asc) (ascPortPool asc) >>= either throwIO return)
(releasePort (ascPortPool asc))
(\port -> loop
(
getPort (ascLog asc) (ascPortPool asc) >>= either throwIO
(\p -> do
c <- case waconfigSsl wac of
-- todo: add loading from relative location
SSL certFile chainCertFiles keyFile ->
either (const mempty) (TLS.Credentials . (:[])) <$>
TLS.credentialLoadX509Chain certFile (V.toList chainCertFiles) keyFile
_ -> return mempty
return (p, c)
)
)
(\(port, cert) -> releasePort (ascPortPool asc) port)
(\(port, cert) -> loop
stanzas
(wac { waconfigPort = port } : wacs)
backs
(Map.unions $ actions : map (\host -> Map.singleton host (PAPort port (waconfigTimeout wac), rs)) hosts))
(Map.unions $ actions : map (\host -> Map.singleton host ((PAPort port (waconfigTimeout wac), rs), cert)) hosts))
where
hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)
loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 =
@ -152,19 +164,19 @@ withActions asc bconfig f =
where
actions = Map.unions
$ actions0
: map (\host -> Map.singleton host (PAStatic sfc, rs))
: map (\host -> Map.singleton host ((PAStatic sfc, rs), mempty))
(Set.toList (sfconfigHosts sfc))
loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 =
loop stanzas wacs backs actions
where
actions = Map.unions
$ actions0
: map (\host -> Map.singleton host (PARedirect red, rs))
: map (\host -> Map.singleton host ((PARedirect red, rs), mempty))
(Set.toList (redirconfigHosts red))
loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 =
loop stanzas wacs backs actions
where
actions = Map.insert (CI.mk $ reversingHost rev) (PAReverseProxy rev mid to, rs) actions0
actions = Map.insert (CI.mk $ reversingHost rev) ((PAReverseProxy rev mid to, rs), mempty) actions0
loop (Stanza (StanzaBackground back) _:stanzas) wacs backs actions =
loop stanzas wacs (back:backs) actions
@ -271,9 +283,9 @@ launchWebApp AppStartConfig {..} aid BundleConfig {..} mdir rlog WebAppConfig {.
let httpPort = kconfigExternalHttpPort ascKeterConfig
httpsPort = kconfigExternalHttpsPort ascKeterConfig
(scheme, extport) =
if waconfigSsl
then ("https://", if httpsPort == 443 then "" else ':' : show httpsPort)
else ("http://", if httpPort == 80 then "" else ':' : show httpPort)
if waconfigSsl == SSLFalse
then ("http://", if httpPort == 80 then "" else ':' : show httpPort)
else ("https://", if httpsPort == 443 then "" else ':' : show httpsPort)
env = Map.toList $ Map.unions
-- Ordering chosen specifically to precedence rules: app specific,
-- plugins, global, and then auto-set Keter variables.

23
Keter/HostManager.hs
View File

@ -28,10 +28,11 @@ import Keter.Types
import Keter.LabelMap (LabelMap)
import qualified Keter.LabelMap as LabelMap
import Prelude hiding (log)
import qualified Network.TLS as TLS
type HMState = LabelMap HostValue
data HostValue = HVActive !AppId !ProxyAction
data HostValue = HVActive !AppId !ProxyAction !TLS.Credentials
| HVReserved !AppId
newtype HostManager = HostManager (IORef HMState)
@ -77,7 +78,7 @@ reserveHosts log (HostManager mstate) aid hosts = do
Nothing -> Right $ Set.singleton host
Just (HVReserved aid') -> assert (aid /= aid')
$ Left (host, aid')
Just (HVActive aid' _)
Just (HVActive aid' _ _)
| aid == aid' -> Right Set.empty
| otherwise -> Left (host, aid')
where hostBS = encodeUtf8 $ CI.original host
@ -113,26 +114,26 @@ forgetReservations log (HostManager mstate) app hosts = do
activateApp :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Map.Map Host ProxyAction
-> Map.Map Host (ProxyAction, TLS.Credentials)
-> IO ()
activateApp log (HostManager mstate) app actions = do
log $ ActivatingApp app $ Map.keysSet actions
atomicModifyIORef mstate $ \state0 ->
(activateHelper app state0 actions, ())
activateHelper :: AppId -> HMState -> Map Host ProxyAction -> HMState
activateHelper :: AppId -> HMState -> Map Host (ProxyAction, TLS.Credentials) -> HMState
activateHelper app =
Map.foldrWithKey activate
where
activate host action state =
assert isOwnedByMe $ LabelMap.insert hostBS (HVActive app action) state
activate host (action, cr) state =
assert isOwnedByMe $ LabelMap.insert hostBS (HVActive app action cr) state
where
hostBS = encodeUtf8 $ CI.original host
isOwnedByMe = LabelMap.labelAssigned hostBS state &&
case LabelMap.lookup hostBS state of
Nothing -> False
Just (HVReserved app') -> app == app'
Just (HVActive app' _) -> app == app'
Just (HVActive app' _ _) -> app == app'
deactivateApp :: (LogMessage -> IO ())
-> HostManager
@ -155,13 +156,13 @@ deactivateHelper app =
isOwnedByMe = LabelMap.labelAssigned hostBS state &&
case LabelMap.lookup hostBS state of
Nothing -> False
Just (HVActive app' _) -> app == app'
Just (HVActive app' _ _) -> app == app'
Just HVReserved {} -> False
reactivateApp :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Map Host ProxyAction
-> Map Host (ProxyAction, TLS.Credentials)
-> Set Host
-> IO ()
reactivateApp log (HostManager mstate) app actions hosts = do
@ -171,10 +172,10 @@ reactivateApp log (HostManager mstate) app actions hosts = do
lookupAction :: HostManager
-> HostBS
-> IO (Maybe ProxyAction)
-> IO (Maybe (ProxyAction, TLS.Credentials))
lookupAction (HostManager mstate) host = do
state <- readIORef mstate
return $ case LabelMap.lookup (CI.original host) state of
Nothing -> Nothing
Just (HVActive _ action) -> Just action
Just (HVActive _ action cert) -> Just (action, cert)
Just (HVReserved _) -> Nothing

21
Keter/Proxy.hs
View File

@ -9,7 +9,7 @@ module Keter.Proxy
) where
import Blaze.ByteString.Builder (copyByteString)
import Control.Applicative ((<|>))
import Control.Applicative ((<$>), (<|>))
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@ -43,9 +43,10 @@ import qualified Network.Wai.Handler.WarpTLS as WarpTLS
import Network.Wai.Middleware.Gzip (gzip)
import Prelude hiding (FilePath, (++))
import WaiAppStatic.Listing (defaultListing)
import qualified Network.TLS as TLS
-- | Mapping from virtual hostname to port number.
type HostLookup = ByteString -> IO (Maybe ProxyAction)
type HostLookup = ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))
reverseProxy :: Bool
-> Int -> Manager -> HostLookup -> ListeningPort -> IO ()
@ -57,12 +58,24 @@ reverseProxy useHeader timeBound manager hostLookup listener =
case listener of
LPInsecure host port -> (Warp.runSettings (warp host port), False)
LPSecure host port cert chainCerts key -> (WarpTLS.runTLS
(WarpTLS.tlsSettingsChain
(connectClientCertificates hostLookup $ WarpTLS.tlsSettingsChain
cert
(V.toList chainCerts)
key)
(warp host port), True)
connectClientCertificates :: HostLookup -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings
connectClientCertificates hl s =
let
newHooks@TLS.ServerHooks{..} = WarpTLS.tlsServerHooks s
-- todo: add nested lookup
newOnServerNameIndication (Just n) =
maybe mempty snd <$> hl (S8.pack n)
newOnServerNameIndication Nothing =
return mempty -- we could return default certificate here
in
s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}}
withClient :: Bool -- ^ is secure?
-> Bool -- ^ use incoming request header for IP address
-> Int -- ^ time bound for connections
@ -120,7 +133,7 @@ withClient isSecure useHeader bound manager hostLookup =
else hostLookup host'
case mport of
Nothing -> return (def, WPRResponse $ unknownHostResponse host)
Just (action, requiresSecure)
Just ((action, requiresSecure), _)
| requiresSecure && not isSecure -> performHttpsRedirect host req
| otherwise -> performAction req action

1
Keter/Types.hs
View File

@ -22,5 +22,6 @@ import Keter.Types.V10 as X
, BackgroundConfig (..)
, RestartCount (..)
, RequiresSecure
, SSLConfig (..)
)
import Network.HTTP.ReverseProxy.Rewrite as X (ReverseProxyConfig (..), RewriteRule (..))

53
Keter/Types/V10.hs
View File

@ -8,8 +8,8 @@ module Keter.Types.V10 where
import Control.Applicative ((<$>), (<*>), (<|>))
import Data.Aeson (Object, ToJSON (..))
import Data.Aeson (FromJSON (..),
Value (Object, String),
withObject, (.!=), (.:),
Value (Object, String, Bool),
withObject, withBool, (.!=), (.:),
(.:?))
import Data.Aeson (Value (Bool), object, (.=))
import qualified Data.CaseInsensitive as CI
@ -251,7 +251,7 @@ instance ToCurrent StaticFilesConfig where
instance ParseYamlFile StaticFilesConfig where
parseYamlFile basedir = withObject "StaticFilesConfig" $ \o -> StaticFilesConfig
<$> lookupBase basedir o "root"
<*> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host")))))
<*> (Set.map CI.mk <$> (o .: "hosts" <|> (Set.singleton <$> (o .: "host"))))
<*> o .:? "directory-listing" .!= False
<*> o .:? "middleware" .!= []
<*> o .:? "connection-time-bound"
@ -341,13 +341,54 @@ instance ToJSON RedirectDest where
type IsSecure = Bool
data SSLConfig
= SSLFalse
| SSLTrue
| SSL !F.FilePath !(V.Vector F.FilePath) !F.FilePath
deriving (Show, Eq)
instance ParseYamlFile SSLConfig where
parseYamlFile _ v@(Bool _) =
withBool "ssl" ( \b ->
return (if b then SSLTrue else SSLFalse) ) v
parseYamlFile basedir v = withObject "ssl" ( \o -> do
mcert <- lookupBaseMaybe basedir o "certificate"
mkey <- lookupBaseMaybe basedir o "key"
case (mcert, mkey) of
(Just cert, Just key) -> do
chainCerts <- o .:? "chain-certificates"
>>= maybe (return V.empty) (parseYamlFile basedir)
return $ SSL cert chainCerts key
_ -> return SSLFalse
) v
instance ToJSON SSLConfig where
toJSON SSLTrue = Bool True
toJSON SSLFalse = Bool False
toJSON (SSL c cc k) = object [ "certificate" .= c
, "chain-certificates" .= cc
, "key" .= k
]
instance FromJSON SSLConfig where
parseJSON v@(Bool _) = withBool "ssl" ( \b ->
return (if b then SSLTrue else SSLFalse) ) v
parseJSON v = withObject "ssl" ( \o -> do
mcert <- o .:? "certificate"
mkey <- o .:? "key"
case (mcert, mkey) of
(Just cert, Just key) -> do
chainCerts <- o .:? "chain-certificates" .!= V.empty
return $ SSL cert chainCerts key
_ -> return SSLFalse -- fail "Must provide both certificate and key files"
) v
data WebAppConfig port = WebAppConfig
{ waconfigExec :: !F.FilePath
, waconfigArgs :: !(Vector Text)
, waconfigEnvironment :: !(Map Text Text)
, waconfigApprootHost :: !Host -- ^ primary host, used for approot
, waconfigHosts :: !(Set Host) -- ^ all hosts, not including the approot host
, waconfigSsl :: !Bool
, waconfigSsl :: !SSLConfig
, waconfigPort :: !port
, waconfigForwardEnv :: !(Set Text)
, waconfigTimeout :: !(Maybe Int)
@ -362,7 +403,7 @@ instance ToCurrent (WebAppConfig ()) where
, waconfigEnvironment = Map.empty
, waconfigApprootHost = CI.mk host
, waconfigHosts = Set.map CI.mk hosts
, waconfigSsl = ssl
, waconfigSsl = if ssl then SSLTrue else SSLFalse
, waconfigPort = ()
, waconfigForwardEnv = Set.empty
, waconfigTimeout = Nothing
@ -385,7 +426,7 @@ instance ParseYamlFile (WebAppConfig ()) where
<*> o .:? "env" .!= Map.empty
<*> return ahost
<*> return hosts
<*> o .:? "ssl" .!= False
<*> o .:? "ssl" .!= SSLFalse
<*> return ()
<*> o .:? "forward-env" .!= Set.empty
<*> o .:? "connection-time-bound"

7
incoming/foo1_0/config/keter.yaml
View File

@ -4,6 +4,13 @@ stanzas:
args:
- Hello World v1.0
#ssl : true
# ssl:
# key: /opt/keter/etc/cert/hello.key
# certificate: /opt/keter/etc/cert/hello.crt
# chain-certificates:
# - /opt/keter/etc/middle.crt
# - /opt/keter/etc/root.crt
env:
FROM_KETER_CONFIG: foo bar baz
forward-env:

1
keter.cabal
View File

@ -61,6 +61,7 @@ Library
, stm >= 2.4
, async
, lifted-base
, tls >= 1.3.4
if impl(ghc < 7.6)
build-depends: ghc-prim

2
stack.yaml
View File

@ -3,4 +3,4 @@ flags:
packages:
- '.'
extra-deps: []
resolver: lts-3.5
resolver: lts-5.0