diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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: diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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 diff --git a/src/Keter/Common.hs b/src/Keter/Common.hs --- a/src/Keter/Common.hs +++ b/src/Keter/Common.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Provides logging, versioning and some type aliases diff --git a/src/Keter/Config/V10.hs b/src/Keter/Config/V10.hs --- a/src/Keter/Config/V10.hs +++ b/src/Keter/Config/V10.hs @@ -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 diff --git a/src/Keter/Proxy.hs b/src/Keter/Proxy.hs --- a/src/Keter/Proxy.hs +++ b/src/Keter/Proxy.hs @@ -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 = "\nWelcome to Keter

Welcome to Keter

There was a proxy error, check the keter logs for details.

" diff --git a/src/Keter/TempTarball.hs b/src/Keter/TempTarball.hs --- a/src/Keter/TempTarball.hs +++ b/src/Keter/TempTarball.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 }