keter 2.1.9 → 2.1.10
raw patch · 7 files changed
+150/−96 lines, 7 filesdep ~optparse-applicativedep ~tls
Dependency ranges changed: optparse-applicative, tls
Files
- ChangeLog.md +4/−0
- keter.cabal +5/−3
- src/Keter/App.hs +24/−65
- src/Keter/AppManager.hs +9/−27
- src/Keter/Main.hs +2/−1
- src/Keter/SharedData/App.hs +72/−0
- src/Keter/SharedData/AppManager.hs +34/−0
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog +## 2.1.10+- bump optparse applicative @jappeace+- Fix reloading stuck on crash-looping bundles @ktak-007 [314](https://github.com/snoyberg/keter/pull/314)+ ## 2.1.9 - Add integration tests (@jezen) - bump random package (@jappeace)
keter.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: keter-version: 2.1.9+version: 2.1.10 synopsis: Web application deployment manager, focusing on Haskell web frameworks. It mitigates downtime. @@ -51,7 +51,7 @@ , monad-logger >=0.3.0 && <0.4.0 , mtl >=2.2.2 && <2.3 || ^>=2.3.1 , network >=3.1.2 && <3.2 || ^>=3.2.0- , optparse-applicative >=0.16.1 && <0.18 || ^>=0.18.1.0+ , optparse-applicative >=0.16.1 && <0.20 , process >=1.6 && <1.7 , random >=1.2.1 && <1.4 , regex-tdfa >=1.3.1 && <1.4@@ -60,7 +60,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.1 || ^>=2.1.0+ , tls >=1.5.7 && <2.2 , tls-session-manager >=0.0.4 && <0.1 , transformers >=0.5.6 && <0.7 , unix >=2.7.2 && <2.9@@ -94,6 +94,8 @@ Keter.Plugin.Postgres Keter.PortPool Keter.Proxy+ Keter.SharedData.App+ Keter.SharedData.AppManager Keter.Rewrite Keter.TempTarball Keter.Yaml.FilePath
src/Keter/App.hs view
@@ -8,13 +8,10 @@ {-# LANGUAGE TypeFamilies #-} module Keter.App- ( App- , AppStartConfig (..)- , start+ ( start , reload , getTimestamp , Keter.App.terminate- , showApp ) where import Control.Arrow ((***))@@ -32,7 +29,7 @@ import Data.IORef import Data.Map (Map) import Data.Map qualified as Map-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isJust) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text, pack, unpack)@@ -41,9 +38,7 @@ import Data.Yaml import Keter.Common import Keter.Conduit.Process.Unix- ( MonitoredProcess- , ProcessTracker- , monitorProcess+ ( monitorProcess , printStatus , terminateMonitoredProcess )@@ -52,8 +47,10 @@ import Keter.HostManager hiding (start) import Keter.Logger (Logger) import Keter.Logger qualified as Log-import Keter.PortPool (PortPool, getPort, releasePort)+import Keter.PortPool (getPort, releasePort) import Keter.Rewrite (ReverseProxyConfig(..))+import Keter.SharedData.App+import Keter.SharedData.AppManager (AppState(..)) import Keter.TempTarball import Keter.Yaml.FilePath import Network.Socket@@ -66,46 +63,9 @@ import System.IO (IOMode(..), hClose) import System.Log.FastLogger qualified as FL import System.Posix.Files (fileAccess)-import System.Posix.Types (EpochTime, GroupID, UserID)+import System.Posix.Types (EpochTime) import System.Timeout (timeout) -data App = App- { appModTime :: !(TVar (Maybe EpochTime))- , appRunningWebApps :: !(TVar [RunningWebApp])- , appBackgroundApps :: !(TVar [RunningBackgroundApp])- , appId :: !AppId- , appHosts :: !(TVar (Set Host))- , appDir :: !(TVar (Maybe FilePath))- , appAsc :: !AppStartConfig- , appLog :: !(TVar (Maybe Logger))- }-instance Show App where- show App {appId} = "App{appId=" <> show appId <> "}"---- | within an stm context we can show a lot more then the show instance can do-showApp :: App -> STM Text-showApp App{..} = do- appModTime' <- readTVar appModTime- appRunning' <- readTVar appRunningWebApps- appHosts' <- readTVar appHosts- pure $ pack $- show appId <>- " modtime: " <> show appModTime' <> ", webappsRunning: " <> show appRunning' <> ", hosts: " <> show appHosts'---data RunningWebApp = RunningWebApp- { rwaProcess :: !MonitoredProcess- , rwaPort :: !Port- , rwaEnsureAliveTimeOut :: !Int- }--instance Show RunningWebApp where- show (RunningWebApp {..}) = "RunningWebApp{rwaPort=" <> show rwaPort <> ", rwaEnsureAliveTimeOut=" <> show rwaEnsureAliveTimeOut <> ",..}"--newtype RunningBackgroundApp = RunningBackgroundApp- { rbaProcess :: MonitoredProcess- }- unpackBundle :: FilePath -> AppId -> KeterM AppStartConfig (FilePath, BundleConfig)@@ -133,16 +93,6 @@ AIBuiltin -> "__builtin__" AINamed x -> x -data AppStartConfig = AppStartConfig- { ascTempFolder :: !TempFolder- , ascSetuid :: !(Maybe (Text, (UserID, GroupID)))- , ascProcessTracker :: !ProcessTracker- , ascHostManager :: !HostManager- , ascPortPool :: !PortPool- , ascPlugins :: !Plugins- , ascKeterConfig :: !KeterConfig- }- withConfig :: AppId -> AppInput -> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)@@ -267,8 +217,9 @@ start :: AppId -> AppInput+ -> TVar AppState -> KeterM AppStartConfig App-start aid input =+start aid input tstate = withLogger aid Nothing $ \tAppLogger appLogger -> withConfig aid input $ \newdir bconfig mmodtime -> withSanityChecks bconfig $@@ -276,7 +227,7 @@ withBackgroundApps aid bconfig newdir appLogger backs $ \runningBacks -> withWebApps aid bconfig newdir appLogger webapps $ \runningWebapps -> do asc@AppStartConfig{..} <- ask- liftIO $ mapM_ ensureAlive runningWebapps+ liftIO $ mapM_ (ensureAlive tstate) runningWebapps withMappedConfig (const ascHostManager) $ activateApp aid actions liftIO $ App@@ -373,8 +324,8 @@ $logInfo $ pack $ "Killing " <> unpack status <> " running on port: " <> show rwaPort liftIO $ terminateMonitoredProcess rwaProcess -ensureAlive :: RunningWebApp -> IO ()-ensureAlive RunningWebApp {..} = do+ensureAlive :: TVar AppState -> RunningWebApp -> IO ()+ensureAlive tstate RunningWebApp {..} = do didAnswer <- testApp rwaPort if didAnswer then return ()@@ -392,10 +343,18 @@ threadDelay $ 2 * 1000 * 1000 eres <- try $ connectTo "127.0.0.1" $ show port case eres of- Left (_ :: IOException) -> testApp'+ Left (_ :: IOException) -> do+ testApp'required <- not <$> hasNextStartingAction+ if testApp'required then testApp' else return False Right handle -> do hClose handle return True+ hasNextStartingAction :: IO Bool+ hasNextStartingAction = do+ state <- readTVarIO tstate+ case state of+ ASStarting _app _time tmaction -> isJust <$> readTVarIO tmaction+ _ -> return False connectTo host serv = do let hints = defaultHints { addrFlags = [AI_ADDRCONFIG] , addrSocketType = Stream }@@ -612,8 +571,8 @@ terminateOld = forkKIO $ do -} -reload :: AppInput -> KeterM App ()-reload input = do+reload :: AppInput -> TVar AppState -> KeterM App ()+reload input tstate = do App{..} <- ask withMappedConfig (const appAsc) $ withLogger appId (Just appLog) $ \_ appLogger ->@@ -622,7 +581,7 @@ withReservations appId bconfig $ \webapps backs actions -> withBackgroundApps appId bconfig newdir appLogger backs $ \runningBacks -> withWebApps appId bconfig newdir appLogger webapps $ \runningWebapps -> do- liftIO $ mapM_ ensureAlive runningWebapps+ liftIO $ mapM_ (ensureAlive tstate) runningWebapps liftIO (readTVarIO appHosts) >>= \hosts -> withMappedConfig (const $ ascHostManager appAsc) $ reactivateApp appId actions hosts
src/Keter/AppManager.hs view
@@ -7,7 +7,6 @@ module Keter.AppManager ( -- * Types AppManager- , Action (..) -- * Actions , perform , reloadAppList@@ -20,11 +19,12 @@ ) where import Control.Applicative+import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Concurrent.STM import Control.Exception (SomeException) import Control.Exception qualified as E-import Control.Monad (forM_)+import Control.Monad (forM_, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (withRunInIO) import Control.Monad.Logger@@ -34,20 +34,20 @@ import Data.Map qualified as Map import Data.Maybe (catMaybes, mapMaybe) import Data.Set qualified as Set-import Data.Text (Text, pack, unpack)+import Data.Text (Text, pack) import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Builder qualified as Builder import Data.Traversable.WithIndex (itraverse)-import Keter.App (App, AppStartConfig, showApp) import Keter.App qualified as App import Keter.Common import Keter.Config import Keter.Context+import Keter.SharedData.App (App, AppStartConfig)+import Keter.SharedData.AppManager import Prelude hiding (FilePath, log) import System.FilePath (FilePath) import System.Posix.Files (getFileStatus, modificationTime) import System.Posix.Types (EpochTime)-import Text.Printf (printf) data AppManager = AppManager { apps :: !(TVar (Map AppId (TVar AppState)))@@ -55,22 +55,6 @@ , mutex :: !(MVar ()) } -data AppState = ASRunning App- | ASStarting- !(Maybe App)- !(TVar (Maybe EpochTime))- !(TVar (Maybe Action)) -- ^ the next one to try- | ASTerminated--showAppState :: AppState -> STM Text-showAppState (ASRunning x) = (\x' -> "running(" <> x' <> ")") <$> showApp x-showAppState (ASStarting mapp tmtime tmaction) = do- mtime <- readTVar tmtime- maction <- readTVar tmaction- mtext <- traverse showApp mapp- pure $ pack $ printf "starting app %s, time %s, action %s \n" (unpack $ fold mtext) (show mtime) (show maction)-showAppState ASTerminated = pure "terminated"- renderApps :: AppManager -> STM Text renderApps mngr = do appMap <- readTVar $ apps mngr@@ -81,9 +65,6 @@ ) appMap pure $ LT.toStrict $ Builder.toLazyText $ fold x -data Action = Reload AppInput | Terminate- deriving Show- initialize :: KeterM AppStartConfig AppManager initialize = do asc <- ask@@ -230,7 +211,8 @@ -> Maybe App -> Action -> KeterM AppManager ()-launchWorker appid tstate tmnext = loop+launchWorker appid tstate tmnext mcurrentApp' action' =+ void $ withRunInIO $ \rio -> forkIO $ rio $ loop mcurrentApp' action' where loop :: Maybe App -> Action -> KeterM AppManager () loop mcurrentApp action = do@@ -271,7 +253,7 @@ $logInfo (reloadMsg "Nothing" (show input)) AppManager{..} <- ask eres <- withRunInIO $ \rio -> E.try @SomeException $- rio $ withMappedConfig (const appStartConfig) $ App.start appid input+ rio $ withMappedConfig (const appStartConfig) $ App.start appid input tstate case eres of Left e -> do $logError (errorStartingBundleMsg (show name) (show e))@@ -280,7 +262,7 @@ processAction (Just app) (Reload input) = do $logInfo (reloadMsg (show $ Just app) (show input)) eres <- withRunInIO $ \rio -> E.try @SomeException $- rio $ withMappedConfig (const app) $ App.reload input+ rio $ withMappedConfig (const app) $ App.reload input tstate case eres of Left e -> do $logError (errorStartingBundleMsg (show name) (show e))
src/Keter/Main.hs view
@@ -25,7 +25,6 @@ import Data.Text.Read qualified import Data.Time (getCurrentTime) import Data.Vector qualified as V-import Keter.App (AppStartConfig(..)) import Keter.AppManager qualified as AppMan import Keter.Cli import Keter.Common@@ -37,6 +36,8 @@ import Keter.Logger qualified as Log import Keter.PortPool qualified as PortPool import Keter.Proxy qualified as Proxy+import Keter.SharedData.App (AppStartConfig(..))+import Keter.SharedData.AppManager qualified as AppMan import Keter.TempTarball qualified as TempFolder import Keter.Yaml.FilePath import Prelude hiding (FilePath, log)
@@ -0,0 +1,72 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Keter.SharedData.App+ ( App(..)+ , AppStartConfig(..)+ , RunningBackgroundApp(..)+ , RunningWebApp(..)+ , showApp+ ) where++import Control.Concurrent.STM (STM, TVar, readTVar)+import Data.Set (Set)+import Data.Text (Text, pack)+import Keter.Common (AppId, Host, Plugins, Port)+import Keter.Conduit.Process.Unix+ ( MonitoredProcess+ , ProcessTracker+ )+import Keter.Config (KeterConfig)+import Keter.HostManager (HostManager)+import Keter.Logger (Logger)+import Keter.PortPool (PortPool)+import Keter.TempTarball (TempFolder)+import System.Posix.Types (EpochTime, GroupID, UserID)++data RunningWebApp = RunningWebApp+ { rwaProcess :: !MonitoredProcess+ , rwaPort :: !Port+ , rwaEnsureAliveTimeOut :: !Int+ }++instance Show RunningWebApp where+ show (RunningWebApp {..}) = "RunningWebApp{rwaPort=" <> show rwaPort <> ", rwaEnsureAliveTimeOut=" <> show rwaEnsureAliveTimeOut <> ",..}"++newtype RunningBackgroundApp = RunningBackgroundApp+ { rbaProcess :: MonitoredProcess+ }++data AppStartConfig = AppStartConfig+ { ascTempFolder :: !TempFolder+ , ascSetuid :: !(Maybe (Text, (UserID, GroupID)))+ , ascProcessTracker :: !ProcessTracker+ , ascHostManager :: !HostManager+ , ascPortPool :: !PortPool+ , ascPlugins :: !Plugins+ , ascKeterConfig :: !KeterConfig+ }++data App = App+ { appModTime :: !(TVar (Maybe EpochTime))+ , appRunningWebApps :: !(TVar [RunningWebApp])+ , appBackgroundApps :: !(TVar [RunningBackgroundApp])+ , appId :: !AppId+ , appHosts :: !(TVar (Set Host))+ , appDir :: !(TVar (Maybe FilePath))+ , appAsc :: !AppStartConfig+ , appLog :: !(TVar (Maybe Logger))+ }++instance Show App where+ show App {appId} = "App{appId=" <> show appId <> "}"++-- | within an stm context we can show a lot more then the show instance can do+showApp :: App -> STM Text+showApp App{..} = do+ appModTime' <- readTVar appModTime+ appRunning' <- readTVar appRunningWebApps+ appHosts' <- readTVar appHosts+ pure $ pack $+ show appId <>+ " modtime: " <> show appModTime' <> ", webappsRunning: " <> show appRunning' <> ", hosts: " <> show appHosts'
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++module Keter.SharedData.AppManager+ ( Action(..)+ , AppState(..)+ , showAppState+ ) where++import Control.Concurrent.STM (STM, TVar, readTVar)+import Data.Foldable (fold)+import Data.Text (Text, pack, unpack)+import Keter.Config (AppInput)+import Keter.SharedData.App (App, showApp)+import System.Posix.Types (EpochTime)+import Text.Printf (printf)++data Action = Reload AppInput | Terminate+ deriving Show++data AppState = ASRunning App+ | ASStarting+ !(Maybe App)+ !(TVar (Maybe EpochTime))+ !(TVar (Maybe Action)) -- ^ the next one to try+ | ASTerminated++showAppState :: AppState -> STM Text+showAppState (ASRunning x) = (\x' -> "running(" <> x' <> ")") <$> showApp x+showAppState (ASStarting mapp tmtime tmaction) = do+ mtime <- readTVar tmtime+ maction <- readTVar tmaction+ mtext <- traverse showApp mapp+ pure $ pack $ printf "starting app %s, time %s, action %s \n" (unpack $ fold mtext) (show mtime) (show maction)+showAppState ASTerminated = pure "terminated"