parent 8f71e01

author Marcin Tolysz <tolysz@gmail.com> 1514741013 +0000
committer Akos Marton <makos999@protonmail.ch> 1582496404 +0100

Squashed rebase from Marcin Tolysz, tolysz/modernize.

* Builds with `process` 1.6
* add dependency for `tls-session-manager`
* bump resolver

Add per bundle certificates for static files and redirects.

update sample configuration

add reverse proxy

* Builds with `process` 1.6
* add dependency for `tls-session-manager`
* bump resolver

fix reverse proxy for non http1.1 connections

Make it compile against more resolvers:
resolver: lts-13.8
resolver: lts-12.8
resolver: lts-11.8
resolver: lts-10.8

Delete stack.yaml

Update .gitignore

Update README.md

Update README.md

clean

Update setup-keter.sh

Update PortPool.hs

Update PortPool.hs

Update PortPool.hs

Update PortPool.hs

Update App.hs

Update App.hs

Update App.hs

Update App.hs

Update App.hs

Update App.hs

Update App.hs

Update App.hs

Update App.hs

Update LabelMapSpec.hs

Update LabelMapSpec.hs

Update keter.cabal

Update keter.cabal

.gitignore

@@ -21,3 +21,4 @@ log/
 .stack-work/
 cabal.sandbox.config
 *.sublime-*
+stack.yaml

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

@@ -33,7 +33,7 @@ import           Control.Exception               (Exception, SomeException,
 import           Control.Monad                   (void)
 import           Data.ByteString                 (ByteString)
 import qualified Data.ByteString.Char8           as S8
-import           Data.Conduit                    (Source, ($$))
+import           Data.Conduit                    (ConduitT, (.|), runConduit)
 import           Data.Conduit.Binary             (sinkHandle, sourceHandle)
 import qualified Data.Conduit.List               as CL
 import           Data.IORef                      (IORef, newIORef, readIORef,
@@ -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
@@ -189,7 +191,7 @@ forkExecuteLog :: ByteString -- ^ command
                -> [ByteString] -- ^ args
                -> Maybe [(ByteString, ByteString)] -- ^ environment
                -> Maybe ByteString -- ^ working directory
-               -> Maybe (Source IO ByteString) -- ^ stdin
+               -> Maybe (ConduitT () ByteString IO ()) -- ^ stdin
                -> (ByteString -> IO ()) -- ^ both stdout and stderr will be sent to this location
                -> IO ProcessHandle
 forkExecuteLog cmd args menv mwdir mstdin rlog = bracketOnError
@@ -213,6 +215,7 @@ forkExecuteLog cmd args menv mwdir mstdin rlog = bracketOnError
             , std_err = UseHandle writerH
             , close_fds = True
             , create_group = True
+            , use_process_jobs = False
 #if MIN_VERSION_process(1, 2, 0)
             , delegate_ctlc = False
 #endif
@@ -228,10 +231,10 @@ forkExecuteLog cmd args menv mwdir mstdin rlog = bracketOnError
             }
         ignoreExceptions $ addAttachMessage pipes ph
         void $ forkIO $ ignoreExceptions $
-            (sourceHandle readerH $$ CL.mapM_ rlog) `finally` hClose readerH
+            (runConduit $ sourceHandle readerH .| CL.mapM_ rlog) `finally` hClose readerH
         case (min, mstdin) of
             (Just h, Just source) -> void $ forkIO $ ignoreExceptions $
-                (source $$ sinkHandle h) `finally` hClose h
+                (runConduit $ source .| sinkHandle h) `finally` hClose h
             (Nothing, Nothing) -> return ()
             _ -> error $ "Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog"
         return ph

Keter/App.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TupleSections       #-}
 module Keter.App
     ( App
     , AppStartConfig (..)
@@ -17,8 +18,8 @@ import           Control.Arrow             ((***))
 import           Control.Concurrent        (forkIO, threadDelay)
 import           Control.Concurrent.STM
 import           Control.Exception         (IOException, bracketOnError,
-                                            throwIO, try)
-import           Control.Monad             (void, when)
+                                            throwIO, try, catch)
+import           Control.Monad             (void, when, liftM)
 import qualified Data.CaseInsensitive      as CI
 import           Data.Conduit.LogFile      (RotatingLog)
 import qualified Data.Conduit.LogFile      as LogFile
@@ -42,10 +43,10 @@ import           System.Directory          (canonicalizePath, doesFileExist,
 import           Keter.HostManager         hiding (start)
 import           Keter.PortPool            (PortPool, getPort, releasePort)
 import           Keter.Types
-import qualified Network
+import           Network.Socket
 import           Prelude                   hiding (FilePath)
 import           System.Environment        (getEnvironment)
-import           System.IO                 (hClose)
+import           System.IO                 (hClose, IOMode(..))
 import           System.Posix.Files        (fileAccess)
 import           System.Posix.Types        (EpochTime, GroupID, UserID)
 import           System.Timeout            (timeout)
@@ -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 $ reversingUseSSL 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
 
@@ -337,12 +338,39 @@ ensureAlive RunningWebApp {..} = do
       where
         testApp' = do
             threadDelay $ 2 * 1000 * 1000
-            eres <- try $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port
+            eres <- try $ connectTo "127.0.0.1" $ show port
             case eres of
                 Left (_ :: IOException) -> testApp'
                 Right handle -> do
                     hClose handle
                     return True
+        connectTo host serv = do
+            let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]
+                                     , addrSocketType = Stream }
+            addrs <- getAddrInfo (Just hints) (Just host) (Just serv)
+            firstSuccessful $ map tryToConnect addrs
+            where
+              tryToConnect addr =
+                bracketOnError
+                  (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
+                  (close)  -- only done if there's an error
+                  (\sock -> do
+                    connect sock (addrAddress addr)
+                    socketToHandle sock ReadWriteMode
+                  )
+              firstSuccessful = go Nothing
+                where
+                  go _ (p:ps) = do
+                    r <- tryIO p
+                    case r of
+                          Right x -> return x
+                          Left  e -> go (Just e) ps
+                 -- All operations failed, throw error if one exists
+                  go Nothing  [] = ioError $ userError $ "connectTo firstSuccessful: empty list"
+                  go (Just e) [] = throwIO e
+                  tryIO :: IO a -> IO (Either IOException a)
+                  tryIO m = catch (liftM Right m) (return . Left)
+
 
 withBackgroundApps :: AppStartConfig
                    -> AppId

Keter/Main.hs

@@ -38,7 +38,8 @@ import           Data.Text.Encoding        (encodeUtf8)
 import qualified Data.Text.Read
 import           Data.Time                 (getCurrentTime)
 import           Data.Yaml.FilePath
-import qualified Network.HTTP.Conduit      as HTTP (tlsManagerSettings,newManager)
+import qualified Network.HTTP.Conduit      as HTTP (tlsManagerSettings,
+                                                    newManager)
 import           Prelude                   hiding (FilePath, log)
 import           System.Directory          (createDirectoryIfMissing,
                                             createDirectoryIfMissing,
@@ -151,20 +152,26 @@ getIncoming kc = kconfigDir kc </> "incoming"
 isKeter :: FilePath -> Bool
 isKeter fp = takeExtension fp == ".keter"
 
+#if MIN_VERSION_fsnotify(3,0,0)
+#define IGNORE _
+#else
+#define IGNORE
+#endif
+
 startWatching :: KeterConfig -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO ()
 startWatching kc@KeterConfig {..} appMan log = do
     -- File system watching
     wm <- FSN.startManager
     _ <- FSN.watchTree wm (fromString incoming) (const True) $ \e -> do
         e' <-
             case e of
-                FSN.Removed fp _ -> do
+                FSN.Removed fp _ IGNORE -> do
                     log $ WatchedFile "removed" (fromFilePath fp)
                     return $ Left $ fromFilePath fp
-                FSN.Added fp _ -> do
+                FSN.Added fp _ IGNORE -> do
                     log $ WatchedFile "added" (fromFilePath fp)
                     return $ Right $ fromFilePath fp
-                FSN.Modified fp _ -> do
+                FSN.Modified fp _ IGNORE -> do
                     log $ WatchedFile "modified" (fromFilePath fp)
                     return $ Right $ fromFilePath fp
         case e' of

Keter/PortPool.hs

@@ -16,7 +16,7 @@ import           Control.Applicative     ((<$>))
 import           Control.Concurrent.MVar
 import           Control.Exception
 import           Keter.Types
-import qualified Network
+import           Network.Socket
 import           Prelude                 hiding (log)
 
 data PPState = PPState
@@ -38,13 +38,13 @@ getPort log (PortPool mstate) =
         case ppAvail of
             p:ps -> do
                 let next = PPState ps ppRecycled
-                res <- try $ Network.listenOn $ Network.PortNumber $ fromIntegral p
+                res <- try $ listenOn $ show p
                 case res of
                     Left (_ :: SomeException) -> do
                         log $ RemovingPort p
                         loop next
-                    Right socket -> do
-                        res' <- try $ Network.sClose socket
+                    Right socket' -> do
+                        res' <- try $ close socket'
                         case res' of
                             Left e -> do
                                 $logEx log e
@@ -56,6 +56,22 @@ getPort log (PortPool mstate) =
                     [] -> return (PPState [] id, Left $ toException NoPortsAvailable)
                     ps -> loop $ PPState ps id
 
+    listenOn port = do
+        let hints = defaultHints {
+                addrFlags = [AI_PASSIVE]
+              , addrSocketType = Stream
+              }
+        addr:_ <- getAddrInfo (Just hints) Nothing (Just port)
+        bracketOnError
+             (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
+             (close)
+             (\sock -> do
+                 setSocketOption sock ReuseAddr 1
+                 bind sock (addrAddress addr)
+                 listen sock maxListenQueue
+                 return sock
+             )
+
 -- | Return a port to the recycled collection of the pool.  Note that recycling
 -- puts the new ports at the end of the queue (FIFO), so that if an application
 -- holds onto the port longer than expected, there should be no issues.

Keter/Proxy.hs

@@ -27,10 +27,15 @@ import qualified Data.Vector                       as V
 import           Keter.Types
 import           Keter.Types.Middleware
 import           Network.HTTP.Conduit              (Manager)
+
+#if MIN_VERSION_http_reverse_proxy(0,4,2)
+import           Network.HTTP.ReverseProxy         (defaultLocalWaiProxySettings)
+#endif
+
 #if MIN_VERSION_http_reverse_proxy(0,6,0)
-import           Network.HTTP.ReverseProxy         (defaultWaiProxySettings,
-                                                    defaultLocalWaiProxySettings)
+import           Network.HTTP.ReverseProxy         (defaultWaiProxySettings)
 #endif
+
 import           Network.HTTP.ReverseProxy         (ProxyDest (ProxyDest),
                                                     SetIpHeader (..),
                                                     WaiProxyResponse (..),
@@ -49,13 +54,17 @@ 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 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
 
 #if !MIN_VERSION_http_reverse_proxy(0,6,0)
 defaultWaiProxySettings = def
+#endif
+
+#if !MIN_VERSION_http_reverse_proxy(0,4,2)
 defaultLocalWaiProxySettings = def
 #endif
 
@@ -72,15 +81,15 @@ reverseProxy useHeader timeBound manager hostLookup listener =
     (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
         newHooks@TLS.ServerHooks{..} = WarpTLS.tlsServerHooks s
         -- todo: add nested lookup
@@ -89,7 +98,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
@@ -161,6 +171,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 (..))