Add per bundle certificates for static files and redirects.

ChangeLog.md

@@ -1,3 +1,8 @@
+## 1.5
+
+* Builds with `process` 1.6
+* add dependency for `tls-session-manager`
+
 ## 1.4.3.1
 
 * Add cabal flag `system-filepath` for compatibility with older versions of fsnotify.

Data/Conduit/Process/Unix.hs

@@ -61,7 +61,9 @@ import           System.Process.Internals        (ProcessHandle (..),
                                                   ProcessHandle__ (..))
 
 processHandleMVar :: ProcessHandle -> MVar ProcessHandle__
-#if MIN_VERSION_process(1, 2, 0)
+#if MIN_VERSION_process(1, 6, 0)
+processHandleMVar (ProcessHandle m _ _) = m
+#elif MIN_VERSION_process(1, 2, 0)
 processHandleMVar (ProcessHandle m _) = m
 #else
 processHandleMVar (ProcessHandle m) = m

Keter/App.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TupleSections       #-}
 module Keter.App
     ( App
     , AppStartConfig (..)
@@ -132,51 +133,51 @@ withReservations asc aid bconfig f = withActions asc bconfig $ \wacs backs actio
 
 withActions :: AppStartConfig
             -> BundleConfig
-            -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> 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
+    -- todo: add loading from relative location
+    loadCert (SSL certFile chainCertFiles keyFile) =
+         either (const mempty) (TLS.Credentials . (:[]))
+            <$> TLS.credentialLoadX509Chain certFile (V.toList chainCertFiles) keyFile
+    loadCert _ = return mempty
+
     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
-             (\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)
-             )
+        (getPort (ascLog asc) (ascPortPool asc) >>= either throwIO
+             (\p -> fmap (p,) <$> loadCert $ waconfigSsl wac)
         )
-        (\(port, cert) -> releasePort (ascPortPool asc) port)
+        (\(port, _)    -> 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), cert)) hosts))
       where
         hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)
-    loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 =
-        loop stanzas wacs backs actions
+    loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 = do
+        cert <- loadCert $ sfconfigSsl sfc
+        loop stanzas wacs backs (actions cert)
       where
-        actions = Map.unions
+        actions cert = Map.unions
                 $ actions0
-                : map (\host -> Map.singleton host ((PAStatic sfc, rs), mempty))
+                : map (\host -> Map.singleton host ((PAStatic sfc, rs), cert))
                   (Set.toList (sfconfigHosts sfc))
-    loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 =
-        loop stanzas wacs backs actions
+    loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 = do
+        cert <- loadCert $ redirconfigSsl red
+        loop stanzas wacs backs (actions cert)
       where
-        actions = Map.unions
+        actions cert = Map.unions
                 $ actions0
-                : map (\host -> Map.singleton host ((PARedirect red, rs), mempty))
+                : map (\host -> Map.singleton host ((PARedirect red, rs), cert))
                   (Set.toList (redirconfigHosts red))
-    loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 =
-        loop stanzas wacs backs actions
+    loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 = do
+        cert <- loadCert $ reverseUseSSL rev
+        loop stanzas wacs backs (actions cert)
       where
-        actions = Map.insert (CI.mk $ reversingHost rev) ((PAReverseProxy rev mid to, rs), mempty) actions0
+        actions cert = Map.insert (CI.mk $ reversingHost rev) ((PAReverseProxy rev mid to, rs), cert) actions0
     loop (Stanza (StanzaBackground back) _:stanzas) wacs backs actions =
         loop stanzas wacs (back:backs) actions
 

Keter/Proxy.hs

@@ -40,7 +40,8 @@ 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)
+import qualified Network.TLS.SessionManager        as TLSSession
+import           Network.Wai.Middleware.Gzip       (gzip, GzipSettings(..), GzipFiles(..))
 import           Prelude                           hiding (FilePath, (++))
 import           WaiAppStatic.Listing              (defaultListing)
 import qualified Network.TLS as TLS
@@ -51,21 +52,21 @@ type HostLookup = ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))
 reverseProxy :: Bool
              -> Int -> Manager -> HostLookup -> ListeningPort -> IO ()
 reverseProxy useHeader timeBound manager hostLookup listener =
-    run $ gzip def $ withClient isSecure useHeader timeBound manager hostLookup
+    run $ gzip def{gzipFiles = GzipPreCompressed GzipIgnore} $ withClient isSecure useHeader timeBound manager hostLookup
   where
     warp host port = Warp.setHost host $ Warp.setPort port Warp.defaultSettings
     (run, isSecure) =
         case listener of
             LPInsecure host port -> (Warp.runSettings (warp host port), False)
-            LPSecure host port cert chainCerts key -> (WarpTLS.runTLS
-                (connectClientCertificates hostLookup $ WarpTLS.tlsSettingsChain
+            LPSecure host port cert chainCerts key session -> (WarpTLS.runTLS
+                (connectClientCertificates hostLookup session $ WarpTLS.tlsSettingsChain
                     cert
                     (V.toList chainCerts)
                     key)
                 (warp host port), True)
 
-connectClientCertificates :: HostLookup -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings
-connectClientCertificates hl s =
+connectClientCertificates :: HostLookup -> Bool -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings
+connectClientCertificates hl session s =
     let
         [email protected]{..} = WarpTLS.tlsServerHooks s
         -- todo: add nested lookup
@@ -74,7 +75,8 @@ connectClientCertificates hl s =
         newOnServerNameIndication Nothing =
              return mempty -- we could return default certificate here
     in
-        s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}}
+        s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}
+          , WarpTLS.tlsSessionManagerConfig = if session then (Just TLSSession.defaultConfig) else Nothing }
 
 withClient :: Bool -- ^ is secure?
            -> Bool -- ^ use incoming request header for IP address
@@ -146,6 +148,7 @@ withClient isSecure useHeader bound manager hostLookup =
             , redirconfigStatus = 301
             , redirconfigActions = V.singleton $ RedirectAction SPAny
                                  $ RDPrefix True host' Nothing
+            , redirconfigSsl = SSLTrue
             }
 
     performAction req (PAPort port tbound) =

Keter/Types.hs

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

Keter/Types/Common.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE OverloadedStrings  #-}
+
 module Keter.Types.Common
     ( module Keter.Types.Common
     , FilePath
@@ -13,18 +15,23 @@ module Keter.Types.Common
     ) where
 
 import           Control.Exception          (Exception, SomeException)
-import           Data.Aeson                 (Object)
+import           Data.Aeson                 (Object, FromJSON, ToJSON,
+                                            Value(Bool), (.=), (.!=), (.:?),
+                                            withObject, withBool, object)
 import           Data.ByteString            (ByteString)
 import           Data.CaseInsensitive       (CI, original)
 import           Data.Map                   (Map)
 import           Data.Set                   (Set)
 import qualified Data.Set                   as Set
 import           Data.Text                  (Text, pack, unpack)
 import           Data.Typeable              (Typeable)
+import           Data.Yaml.FilePath
+import           Data.Vector                (Vector)
+import qualified Data.Vector                as V
 import qualified Data.Yaml
 import qualified Language.Haskell.TH.Syntax as TH
 import           System.Exit                (ExitCode)
-import           System.FilePath            (takeBaseName)
+import           System.FilePath            (FilePath, takeBaseName)
 
 -- | Name of the application. Should just be the basename of the application
 -- file.
@@ -164,3 +171,44 @@ data AppId = AIBuiltin | AINamed !Appname
 instance Show AppId where
     show AIBuiltin = "/builtin/"
     show (AINamed t) = unpack t
+
+data SSLConfig
+    = SSLFalse
+    | SSLTrue
+    | SSL !FilePath !(Vector FilePath) !FilePath
+    deriving (Show, Eq, Ord)
+
+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

Keter/Types/V04.hs

@@ -5,6 +5,7 @@ module Keter.Types.V04 where
 
 import           Control.Applicative
 import           Data.Aeson
+import           Data.Bool
 import           Data.Conduit.Network              (HostPreference)
 import           Data.Default
 import qualified Data.Set                          as Set
@@ -15,6 +16,7 @@ import           Keter.Types.Common
 import           Network.HTTP.ReverseProxy.Rewrite
 import qualified Network.Wai.Handler.Warp          as Warp
 import qualified Network.Wai.Handler.WarpTLS       as WarpTLS
+import qualified Network.TLS.SessionManager        as TLSSession
 import           Prelude                           hiding (FilePath)
 
 data AppConfig = AppConfig
@@ -121,13 +123,15 @@ instance ParseYamlFile TLSConfig where
         key <- lookupBase basedir o "key"
         host <- (fmap fromString <$> o .:? "host") .!= "*"
         port <- o .:? "port" .!= 443
+        session <- bool Nothing (Just TLSSession.defaultConfig) <$> o .:? "session" .!= False
         return $! TLSConfig
             ( Warp.setHost host
             $ Warp.setPort port
               Warp.defaultSettings)
             WarpTLS.defaultTlsSettings
                 { WarpTLS.certFile = cert
                 , WarpTLS.keyFile = key
+                , WarpTLS.tlsSessionManagerConfig = session
                 }
 
 -- | Controls execution of the nginx thread. Follows the settings type pattern.