keter 2.1.2 → 2.1.3

raw patch · 7 files changed

+79/−87 lines, 7 filesdep ~containersdep ~filepathdep ~tarPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: containers, filepath, tar

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−0
• keter.cabal +13/−16
• src/Keter/Common.hs +0/−1
• src/Keter/Config/V10.hs +9/−4
• src/Keter/Proxy.hs +35/−18
• src/Keter/TempTarball.hs +9/−47
• test/Spec.hs +2/−1

@@ -1,3 +1,14 @@+## 2.1.3++* Add `healthcheck-path` global config for Keter-only healthchecks. PR #283++* Fix config keys `unknown-host-response-file` and `missing-host-response-file`+  accidentally flipped. PR #282+* In case reading any one of `*-host-response-file` fails, keter now logs a warning,+  and falls back to builtin defaults. Before 2.1.3, this is a fatal error.+* Add support for tar 0.6, drop NIH tar unpack.++ Change CI to be cabal based instead of stack.+ ## 2.1.2  * Bump bounds:

@@ -1,20 +1,18 @@ cabal-version:      3.0 name:               keter-version:            2.1.2+version:            2.1.3 synopsis:-  Web application deployment manager, focusing on Haskell web frameworks+  Web application deployment manager, focusing on Haskell web frameworks. It mitigates downtime.  description:   Deployment system for web applications, originally intended for hosting Yesod-  applications. Keter does the following actions for your application:-  .-  * Binds to the main port (usually port 80) and reverse proxies requests to your application based on virtual hostnames.-  * Provides SSL support if requested.-  * Automatically launches applications, monitors processes, and relaunches any processes which die.-  * Provides graceful redeployment support, by launching a second copy of your application, performing a health check, and then switching reverse proxying to the new process.-  .-  Keter provides many more advanced features and extension points. It allows configuration of static hosts, redirect rules, management of PostgreSQL databases, and more. It supports a simple bundle format for applications which allows for easy management of your web apps.+  applications.+  It binds to the main port (usually port 80) and reverse proxies requests to your application based on virtual hostnames.+  It provides SSL support if requested.+  It automatically launches applications, monitors processes, and relaunches any processes which die.+  It also provides graceful redeployment support, which mitigates downtime. + homepage:           http://www.yesodweb.com/ license:            MIT license-file:       LICENSE@@ -26,8 +24,6 @@   ChangeLog.md   README.md ---Data-Files:        incoming/foo/bundle.sh, incoming/foo/config/keter.yaml- flag system-filepath   description: Use system-filepath   default:     False@@ -45,10 +41,10 @@       case-insensitive >=1.2.1 && <1.3,       conduit >=1.3.4 && <1.4,       conduit-extra >=1.3.5 && <1.4,-      containers >=0.6.4 && <0.7,+      containers >=0.6.4 && <0.7 || ^>=0.7,       directory >=1.3.6 && <1.4,       fast-logger >=3.0.0 && <4.0.0,-      filepath >=1.4.2 && <1.5,+      filepath >=1.4.2 && <1.6,       fsnotify >=0.3.0 && <0.5,       http-client >=0.7.11 && <0.8,       http-conduit >=2.3.8 && <2.4,@@ -64,14 +60,14 @@       random >=1.2.1 && <1.3,       regex-tdfa >=1.3.1 && <1.4,       stm >=2.5.0 && <2.6,-      tar >=0.5.1 && <0.6,+      tar >=0.5.1 && <0.7,       template-haskell >=2.17.0 && <3.0,       text >=1.2.5 && <3.0,       time >=1.9.3 && <2.0,       tls >=1.5.7 && <2.0,       tls-session-manager >=0.0.4 && <0.1,       transformers >=0.5.6 && <0.7,-      unix >=2.7.2 && <2.9, +      unix >=2.7.2 && <2.9,       unix-compat >=0.3 && <0.8,       unliftio-core >=0.2.0.0 && <0.3.0.0,       unordered-containers >=0.2.17 && <0.3,@@ -114,6 +110,7 @@     Keter.Yaml.FilePath    other-modules:    Keter.Aeson.KeyHelper+                    Paths_keter   ghc-options:      -Wall   c-sources:        cbits/process-tracker.c   hs-source-dirs:   src

@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-}  -- | Provides logging, versioning and some type aliases

@@ -112,7 +112,9 @@     , kconfigUnknownHostResponse  :: !(Maybe F.FilePath)     , kconfigMissingHostResponse  :: !(Maybe F.FilePath)     , kconfigProxyException       :: !(Maybe F.FilePath)+     , kconfigRotateLogs           :: !Bool+    , kconfigHealthcheckPath      :: !(Maybe Text)     }  instance ToCurrent KeterConfig where@@ -129,10 +131,11 @@         , kconfigEnvironment = Map.empty         , kconfigConnectionTimeBound = connectionTimeBound         , kconfigCliPort             = Nothing-        , kconfigUnknownHostResponse  = Nothing+        , kconfigUnknownHostResponse = Nothing         , kconfigMissingHostResponse = Nothing-        , kconfigProxyException      = Nothing+        , kconfigProxyException = Nothing         , kconfigRotateLogs = True+        , kconfigHealthcheckPath = Nothing         }       where         getSSL Nothing = V.empty@@ -161,6 +164,7 @@         , kconfigMissingHostResponse = Nothing         , kconfigProxyException = Nothing         , kconfigRotateLogs = True+        , kconfigHealthcheckPath = Nothing         }  instance ParseYamlFile KeterConfig where@@ -182,10 +186,11 @@             <*> o .:? "env" .!= Map.empty             <*> o .:? "connection-time-bound" .!= V04.fiveMinutes             <*> o .:? "cli-port"-            <*> o .:? "missing-host-response-file"             <*> o .:? "unknown-host-response-file"+            <*> o .:? "missing-host-response-file"             <*> o .:? "proxy-exception-response-file"             <*> o .:? "rotate-logs" .!= True+            <*> o .:? "app-crash-hook"  -- | Whether we should force redirect to HTTPS routes. type RequiresSecure = Bool@@ -316,7 +321,7 @@  instance ParseYamlFile RedirectConfig where     parseYamlFile _ = withObject "RedirectConfig" $ \o -> RedirectConfig-        <$> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host")))))+        <$> (Set.map CI.mk <$> (o .: "hosts" <|> Set.singleton <$> o .: "host"))         <*> o .:? "status" .!= 303         <*> o .: "actions"         <*> o .:? "ssl" .!= SSLFalse

@@ -13,6 +13,7 @@  import qualified Network.HTTP.Conduit      as HTTP import qualified Data.CaseInsensitive      as CI+import           Data.Functor ((<&>)) import qualified Keter.HostManager         as HostMan import           Blaze.ByteString.Builder          (copyByteString, toByteString) import           Blaze.ByteString.Builder.Html.Word(fromHtmlEscapedByteString)@@ -26,10 +27,11 @@ import           Network.Wai.Middleware.Gzip       (def) #endif import           Data.Monoid                       (mappend, mempty)-import           Data.Text                         (pack)+import           Data.Text                         as T (Text, pack, unwords) import           Data.Text.Encoding                (decodeUtf8With, encodeUtf8) import           Data.Text.Encoding.Error          (lenientDecode) import qualified Data.Vector                       as V+import           GHC.Exts (fromString) import           Keter.Config import           Keter.Config.Middleware import           Network.HTTP.Conduit              (Manager)@@ -58,6 +60,7 @@ import           Control.Monad.Logger import           Control.Exception          (SomeException) import           Network.HTTP.Types                (mkStatus,+                                                    status200,                                                     status301, status302,                                                     status303, status307,                                                     status404, status502)@@ -74,6 +77,9 @@ import qualified System.Directory as Dir import Keter.Context +import           Data.Version (showVersion)+import qualified Paths_keter as Pkg+ #if !MIN_VERSION_http_reverse_proxy(0,6,0) defaultWaiProxySettings = def #endif@@ -89,7 +95,8 @@   , psManager        :: !Manager   , psIpFromHeader   :: Bool   , psConnectionTimeBound :: Int-  , psUnkownHost     :: ByteString -> ByteString+  , psHealthcheckPath :: !(Maybe ByteString)+  , psUnknownHost    :: ByteString -> ByteString   , psMissingHost    :: ByteString   , psProxyException :: ByteString   }@@ -98,30 +105,29 @@ makeSettings hostman = do     KeterConfig{..} <- ask     psManager <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings-    psMissingHost <- case kconfigMissingHostResponse of-      Nothing -> pure defaultMissingHostBody-      Just x -> liftIO $ taggedReadFile "unknown-host-response-file" x-    psUnkownHost <- case kconfigUnknownHostResponse  of-                Nothing -> pure defaultUnknownHostBody-                Just x ->  fmap const $ liftIO $ taggedReadFile "missing-host-response-file" x-    psProxyException <- case kconfigProxyException of-                Nothing -> pure defaultProxyException-                Just x -> liftIO $ taggedReadFile "proxy-exception-response-file" x+    psMissingHost <- taggedReadFile "missing-host-response-file" kconfigMissingHostResponse defaultMissingHostBody id+    psUnknownHost <- taggedReadFile "unknown-host-response-file" kconfigUnknownHostResponse defaultUnknownHostBody const+    psProxyException <- taggedReadFile "proxy-exception-response-file" kconfigProxyException defaultProxyException id     -- calculate the number of microseconds since the     -- configuration option is in milliseconds     let psConnectionTimeBound = kconfigConnectionTimeBound * 1000     let psIpFromHeader = kconfigIpFromHeader+    let psHealthcheckPath = encodeUtf8 <$> kconfigHealthcheckPath     pure $ MkProxySettings{..}     where         psHostLookup = HostMan.lookupAction hostman . CI.mk  -taggedReadFile :: String -> FilePath -> IO ByteString-taggedReadFile tag file = do-        isExist <- Dir.doesFileExist file-        if isExist then S.readFile file else do-          wd <- Dir.getCurrentDirectory-          error $ "could not find " <> tag <> " on path '" <> file <> "' with working dir '" <> wd <> "'"+taggedReadFile :: Text -> Maybe FilePath -> r -> (ByteString -> r) -> KeterM KeterConfig r+taggedReadFile _    Nothing    fallback _               = pure fallback+taggedReadFile tag (Just file) fallback processContents = do+  isExist <- liftIO $ Dir.doesFileExist file+  if isExist then liftIO (S.readFile file) <&> processContents else do+    wd <- liftIO Dir.getCurrentDirectory+    logWarnN . T.unwords $ ["could not find", tag, "on path", quote file, "with working dir", quote wd]+    return fallback+  where+    quote = ("'" <>) . (<> "'") . fromString  reverseProxy :: ListeningPort -> KeterM ProxySettings () reverseProxy listener = do@@ -178,6 +184,10 @@       getDest :: ProxySettings -> Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)+    -- respond to healthckecks, regardless of Host header value and presence+    getDest MkProxySettings{..} req | psHealthcheckPath == Just (Wai.rawPathInfo req)+      = return (defaultLocalWaiProxySettings, WPRResponse healthcheckResponse)+    -- inspect Host header to determine which App to proxy to     getDest cfg@MkProxySettings{..} req =         case Wai.requestHeaderHost req of             Nothing -> do@@ -199,7 +209,7 @@                         else psHostLookup host'         case mport of             Nothing -> do -- we don't know the host that was asked for-              return (defaultLocalWaiProxySettings, WPRResponse $ unknownHostResponse host (psUnkownHost host))+              return (defaultLocalWaiProxySettings, WPRResponse $ unknownHostResponse host (psUnknownHost host))             Just ((action, requiresSecure), _)                 | requiresSecure && not isSecure -> performHttpsRedirect cfg host req                 | otherwise -> performAction psManager isSecure psConnectionTimeBound req action@@ -302,6 +312,13 @@ handleProxyException handleException onexceptBody except req respond = do   handleException req except   respond $ missingHostResponse onexceptBody++healthcheckResponse :: Wai.Response+healthcheckResponse = Wai.responseBuilder+    status200+    [("Content-Type", "text/plain; charset=utf-8")]+    $ "Keter " <> (copyByteString . S8.pack . showVersion) Pkg.version+               <> " is doing okay!\n"  defaultProxyException :: ByteString defaultProxyException = "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>There was a proxy error, check the keter logs for details.</p></body></html>"

@@ -15,7 +15,7 @@ import qualified Codec.Archive.Tar.Entry   as Tar import           Codec.Compression.GZip    (decompress) import           Control.Exception         (bracket, bracketOnError, throwIO)-import           Control.Monad             (unless, when)+import           Control.Monad             (unless, when, forM) import qualified Data.ByteString.Lazy      as L import           Data.ByteString.Unsafe    (unsafeUseAsCStringLen) import qualified Data.IORef                as I@@ -67,51 +67,13 @@ unpackTempTar muid tf bundle appname withDir = do     lbs <- L.readFile bundle     bracketOnError (getFolder muid tf appname) D.removeDirectoryRecursive $ \dir -> do-        unpackTar muid dir $ Tar.read $ decompress lbs+        D.createDirectoryIfMissing True dir+        let entries = Tar.read $ decompress lbs+        Tar.unpack dir entries+        _ <- forM muid $ \perms ->+          Tar.foldEntries (setEntryPermission perms) (pure ()) throwIO entries         withDir dir -unpackTar :: Maybe (UserID, GroupID)-          -> FilePath-          -> Tar.Entries Tar.FormatError-          -> IO ()-unpackTar muid dir =-    loop . Tar.checkSecurity-  where-    loop Tar.Done = return ()-    loop (Tar.Fail e) = either throwIO throwIO e-    loop (Tar.Next e es) = go e >> loop es--    go e = do-        let fp = dir </> Tar.entryPath e-        case Tar.entryContent e of-            Tar.NormalFile lbs _ -> do-                case muid of-                    Nothing -> D.createDirectoryIfMissing True $ F.takeDirectory fp-                    Just (uid, gid) -> createTreeUID uid gid $ F.takeDirectory fp-                let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do-                        _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len)-                        return ()-                bracket-                    (do-                        fd <- createFile fp $ Tar.entryPermissions e-                        setFdOption fd CloseOnExec True-                        case muid of-                            Nothing -> return ()-                            Just (uid, gid) -> setFdOwnerAndGroup fd uid gid-                        return fd)-                    closeFd-                    (\fd -> mapM_ (write fd) (L.toChunks lbs))-            _ -> return ()---- | Create a directory tree, setting the uid and gid of all newly created--- folders.-createTreeUID :: UserID -> GroupID -> FilePath -> IO ()-createTreeUID uid gid =-    go-  where-    go fp = do-        exists <- D.doesDirectoryExist fp-        unless exists $ do-            go $ F.takeDirectory fp-            D.createDirectoryIfMissing False fp-            setOwnerAndGroup fp uid gid+setEntryPermission :: (UserID, GroupID) -> Tar.Entry ->  IO () -> IO ()+setEntryPermission (uid, gid) entry io =+  io >> setOwnerAndGroup (Tar.entryPath entry) uid gid

@@ -93,9 +93,10 @@     settings manager = MkProxySettings {         psHostLookup     = const $ pure $ Just ((PAPort 6781 Nothing, False), error "unused tls certificate")       , psManager        = manager-      , psUnkownHost     = const ""+      , psUnknownHost    = const ""       , psMissingHost    = ""       , psProxyException = ""       , psIpFromHeader   = False       , psConnectionTimeBound = 5 * 60 * 1000+      , psHealthcheckPath = Nothing       }