From 0acfd3685cdf114d07fe87b76cb3af0bc2e15b7a Mon Sep 17 00:00:00 2001 From: Stanislav Smirnov Date: Thu, 2 Apr 2026 01:45:45 +0300 Subject: [PATCH] Add lifecycle hook for deployment notification #331 --- src/Keter/AppManager.hs | 48 +++++++++++++++++++++++++++---- src/Keter/Conduit/Process/Unix.hs | 1 + src/Keter/Config/V10.hs | 5 ++++ 3 files changed, 49 insertions(+), 5 deletions(-) diff --git a/src/Keter/AppManager.hs b/src/Keter/AppManager.hs index 47ffbaa..96dcb82 100644 --- a/src/Keter/AppManager.hs +++ b/src/Keter/AppManager.hs @@ -31,7 +31,7 @@ import Control.Monad (forM_, void, when, unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (withRunInIO) import Control.Monad.Logger -import Control.Monad.Reader (ask) +import Control.Monad.Reader (ask, asks) import Control.Monad.State (runStateT, StateT, modify) import Data.Binary (Word32) import Data.Binary.Get (getWord32le, runGet) @@ -43,17 +43,19 @@ import Data.Conduit (yield) import Data.Foldable (fold) import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes, mapMaybe, isJust) import Data.Set qualified as Set import Data.Text (Text, pack) +import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Builder qualified as Builder import Data.Traversable.WithIndex (itraverse) import Keter.App qualified as App import Keter.Common +import Keter.Conduit.Process.Unix (forkExecuteLog) import Keter.Config import Keter.Context -import Keter.SharedData.App (App, AppStartConfig) +import Keter.SharedData.App (App, AppStartConfig (ascKeterConfig)) import Keter.SharedData.AppManager import Prelude hiding (FilePath, log) import System.FilePath (FilePath) @@ -271,8 +273,11 @@ launchWorker appid tstate tmnext mcurrentApp' action' = case eres of Left e -> do $logError (errorStartingBundleMsg (show name) (show e)) + callUserHook $ userHookEnvFailed e Nothing return Nothing - Right app -> return $ Just app + Right app -> do + callUserHook userHookEnvSuccess + return $ Just app processAction (Just app) (Reload input) = do $logInfo (reloadMsg (show $ Just app) (show input)) eres <- withRunInIO $ \rio -> E.try @SomeException $ @@ -280,16 +285,49 @@ launchWorker appid tstate tmnext mcurrentApp' action' = case eres of Left e -> do $logError (errorStartingBundleMsg (show name) (show e)) + callUserHook $ userHookEnvFailed e $ Just app -- reloading will /always/ result in a valid app, either the old one -- will continue running or the new one will replace it. return (Just app) - Right () -> return $ Just app + Right () -> do + callUserHook userHookEnvSuccess + return $ Just app name = case appid of AIBuiltin -> "" AINamed x -> x + callUserHook :: [(C.ByteString, C.ByteString)] -> KeterM AppManager () + callUserHook envRender = + asks (kconfigUserHook . ascKeterConfig . appStartConfig) >>= mapM_ + (\hook -> withRunInIO $ \rio -> do + void (forkExecuteLog + (encodeUtf8 hook) + [] + (Just envRender) + Nothing + Nothing + (const $ return ()) + ) + `E.catch` \(e :: E.IOException ) -> + rio $ $logError $ "Failed to start user hook '" <> hook <> "': " <> pack (show e) + ) + userHookEnvSuccess :: [(C.ByteString, C.ByteString)] + userHookEnvSuccess = + [ ("NAME", bs name) + , ("STATUS", "started") + ] + userHookEnvFailed :: SomeException -> Maybe App -> [(C.ByteString, C.ByteString)] + userHookEnvFailed err mbApp = + [ ("NAME", bs name) + , ("STATUS", "failure") + , ("FAILURE", bs err) + , ("FALLBACK", bs $ isJust mbApp) + ] ++ maybe [] (\app -> [("FALLBACK_APP", bs app)]) mbApp + bs :: Show a => a -> C.ByteString + bs = encodeUtf8 . pack . show + addApp :: FilePath -> KeterM AppManager () addApp bundle = do AppManager {..} <- ask diff --git a/src/Keter/Conduit/Process/Unix.hs b/src/Keter/Conduit/Process/Unix.hs index 288bb64..3d03a2c 100644 --- a/src/Keter/Conduit/Process/Unix.hs +++ b/src/Keter/Conduit/Process/Unix.hs @@ -12,6 +12,7 @@ module Keter.Conduit.Process.Unix -- ** Types ProcessTracker -- ** Functions + , forkExecuteLog , initProcessTracker -- * Monitored process diff --git a/src/Keter/Config/V10.hs b/src/Keter/Config/V10.hs index aec9701..b6872d1 100644 --- a/src/Keter/Config/V10.hs +++ b/src/Keter/Config/V10.hs @@ -124,6 +124,8 @@ data KeterConfig = KeterConfig , kconfigHealthcheckPath :: !(Maybe Text) , kconfigGracefulDrainMicros :: !(Maybe Int) + + , kconfigUserHook :: !(Maybe Text) } instance ToCurrent KeterConfig where @@ -146,6 +148,7 @@ instance ToCurrent KeterConfig where , kconfigRotateLogs = True , kconfigHealthcheckPath = Nothing , kconfigGracefulDrainMicros = Nothing + , kconfigUserHook = Nothing } where getSSL Nothing = V.empty @@ -176,6 +179,7 @@ defaultKeterConfig = KeterConfig , kconfigRotateLogs = True , kconfigHealthcheckPath = Nothing , kconfigGracefulDrainMicros = Nothing + , kconfigUserHook = Nothing } instance ParseYamlFile KeterConfig where @@ -203,6 +207,7 @@ instance ParseYamlFile KeterConfig where <*> o .:? "rotate-logs" .!= True <*> o .:? "app-crash-hook" <*> o .:? "graceful-drain-micros" + <*> o .:? "hook" -- | Whether we should force redirect to HTTPS routes. type RequiresSecure = Bool