diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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 diff --git a/src/Keter/App.hs b/src/Keter/App.hs --- a/src/Keter/App.hs +++ b/src/Keter/App.hs @@ -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 diff --git a/src/Keter/AppManager.hs b/src/Keter/AppManager.hs --- a/src/Keter/AppManager.hs +++ b/src/Keter/AppManager.hs @@ -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)) diff --git a/src/Keter/Main.hs b/src/Keter/Main.hs --- a/src/Keter/Main.hs +++ b/src/Keter/Main.hs @@ -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) diff --git a/src/Keter/SharedData/App.hs b/src/Keter/SharedData/App.hs new file mode 100644 --- /dev/null +++ b/src/Keter/SharedData/App.hs @@ -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' diff --git a/src/Keter/SharedData/AppManager.hs b/src/Keter/SharedData/AppManager.hs new file mode 100644 --- /dev/null +++ b/src/Keter/SharedData/AppManager.hs @@ -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"