diff --git a/dev/default.nix b/dev/default.nix index f729204..53ea6ce 100644 --- a/dev/default.nix +++ b/dev/default.nix @@ -152,6 +152,7 @@ in export POWER_AUTHORIZATION_HEADER="123" export CACHE_INVALIDATION_TIME="60" export CACHE_UPDATE_TIME="20" + export CONTROL_SCRIPT_TIMEOUT="10" ${hsPkgs.octopod-backend.components.exes.octopod-exe}/bin/octopod-exe \ --port 4443 \ --ui-port 3002 \ diff --git a/octopod-backend/octopod-backend.cabal b/octopod-backend/octopod-backend.cabal index d970bc7..c084360 100644 --- a/octopod-backend/octopod-backend.cabal +++ b/octopod-backend/octopod-backend.cabal @@ -115,6 +115,7 @@ library , hasql-transaction , ordered-containers , vector + , process default-language: Haskell2010 executable octopod-exe diff --git a/octopod-backend/src/Octopod/Server.hs b/octopod-backend/src/Octopod/Server.hs index 6832e70..5c38e63 100644 --- a/octopod-backend/src/Octopod/Server.hs +++ b/octopod-backend/src/Octopod/Server.hs @@ -131,6 +131,7 @@ data AppState = AppState , appOverridesCache :: !(CacheMap ServerError AppM' (Config 'DeploymentLevel) (DefaultConfig 'ApplicationLevel)) , appOverrideKeysCache :: !(CacheMap ServerError AppM' (Config 'DeploymentLevel) [Text]) , gitSha :: !Text + , controlScriptTimeout :: !ControlScriptTimeout } deriving stock (Generic) @@ -175,8 +176,9 @@ runOctopodServer sha = do projName <- coerce . pack <$> getEnvOrDie "PROJECT_NAME" domain <- coerce . pack <$> getEnvOrDie "BASE_DOMAIN" ns <- coerce . pack <$> getEnvOrDie "NAMESPACE" - archRetention <- fromIntegral <$> getEnvOrDieWith "ARCHIVE_RETENTION" (readMaybe @Int) - stUpdateTimeout <- Timeout . CalendarDiffTime 0 . fromIntegral <$> getEnvOrDieWith "STATUS_UPDATE_TIMEOUT" (readMaybe @Int) + archRetention <- fromInteger <$> getEnvOrDieWith "ARCHIVE_RETENTION" readMaybe + stUpdateTimeout <- Timeout . CalendarDiffTime 0 . fromInteger <$> getEnvOrDieWith "STATUS_UPDATE_TIMEOUT" readMaybe + scriptTimeout <- ControlScriptTimeout . fromInteger . maybe (60 * 30) read <$> lookupEnv "CONTROL_SCRIPT_TIMEOUT" creationCmd <- Command . pack <$> getEnvOrDie "CREATION_COMMAND" updateCmd <- Command . pack <$> getEnvOrDie "UPDATE_COMMAND" archiveCmd <- Command . pack <$> getEnvOrDie "ARCHIVE_COMMAND" @@ -262,6 +264,7 @@ runOctopodServer sha = do , appOverridesCache = appOverridesCache' , appOverrideKeysCache = appOverrideKeysCache' , gitSha = sha + , controlScriptTimeout = scriptTimeout } app' = app appSt @@ -291,7 +294,7 @@ runArchiveCleanup retention = do dNames <- runStatement $ select $ do ds <- each deploymentSchema - where_ $ (ds ^. #status) `in_` (litExpr <$> archivedStatuses) + where_ $ (ds ^. #status) ==. litExpr Archived where_ $ ds ^. #archivedAt <. litExpr (Just cutoff) pure $ ds ^. #name for_ dNames $ \dName -> (>>= logLeft) . runExceptT $ diff --git a/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs b/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs index c511750..ef7229b 100644 --- a/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs +++ b/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs @@ -10,7 +10,6 @@ module Octopod.Server.ControlScriptUtils cleanupCommandArgs, notificationCommandArgs, runCommand, - runCommandWithoutPipes, runCommandArgs, runCommandArgs', checkCommandArgs, @@ -29,11 +28,14 @@ module Octopod.Server.ControlScriptUtils ) where +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM import Control.Lens import Control.Monad.Base import Control.Monad.Reader import qualified Data.ByteString.Lazy as TL import Data.Coerce +import Data.Fixed import Data.Generics.Product.Typed import qualified Data.Map.Ordered.Strict as MO import qualified Data.Text as T @@ -42,6 +44,7 @@ import Data.Time import Octopod.Server.Logger import System.Exit import System.Log.FastLogger +import System.Process (terminateProcess) import System.Process.Typed import Types @@ -168,7 +171,11 @@ notificationCommandArgs dName old new = do ] runCommandArgs :: - (MonadReader r m, MonadBase IO m, HasType TimedFastLogger r) => + ( MonadReader r m + , MonadBase IO m + , HasType TimedFastLogger r + , HasType ControlScriptTimeout r + ) => (r -> Command) -> ControlScriptArgs -> m (ExitCode, Stdout, Stderr, Duration) @@ -177,7 +184,11 @@ runCommandArgs f args = do runCommandArgs' cmd args runCommandArgs' :: - (MonadBase IO m, HasType TimedFastLogger r, MonadReader r m) => + ( MonadBase IO m + , HasType TimedFastLogger r + , MonadReader r m + , HasType ControlScriptTimeout r + ) => Command -> ControlScriptArgs -> m (ExitCode, Stdout, Stderr, Duration) @@ -200,19 +211,38 @@ elapsedTime :: UTCTime -> UTCTime -> Duration elapsedTime t1 t2 = Duration . calendarTimeTime $ Prelude.abs $ t2 `diffUTCTime` t1 -- | Helper to run command with pipes. -runCommand :: MonadBase IO m => FilePath -> [String] -> m (ExitCode, Stdout, Stderr) +runCommand :: + ( MonadBase IO m + , MonadReader r m + , HasType ControlScriptTimeout r + ) => + FilePath -> + [String] -> + m (ExitCode, Stdout, Stderr) runCommand cmd args = do - (ec, out, err) <- liftBase . readProcess $ proc cmd args + ControlScriptTimeout timeout <- asks getTyped + let pc = + proc cmd args + & setStdout byteStringOutput + & setStderr byteStringOutput + (ec, out, err) <- liftBase $ + withProcessTerm pc $ \p -> do + void . forkIO $ do + threadDelayMicro $ realToFrac timeout + terminateProcess $ unsafeProcessHandle p + atomically $ + (,,) + <$> waitExitCodeSTM p + <*> getStdout p + <*> getStderr p pure ( ec , Stdout . T.decodeUtf8 . TL.toStrict $ out , Stderr . T.decodeUtf8 . TL.toStrict $ err ) - --- | Helper to run command without pipes. -runCommandWithoutPipes :: FilePath -> [String] -> IO ExitCode -runCommandWithoutPipes cmd args = - withProcessWait (proc cmd args) waitExitCode + where + threadDelayMicro :: Micro -> IO () + threadDelayMicro (MkFixed i) = threadDelay (fromInteger i) fullConfigArgs :: FullConfig -> ControlScriptArgs fullConfigArgs cfg = overridesArgs (appConfig cfg) <> overridesArgs (depConfig cfg) diff --git a/octopod-backend/src/Types.hs b/octopod-backend/src/Types.hs index d9b34da..a679fc8 100644 --- a/octopod-backend/src/Types.hs +++ b/octopod-backend/src/Types.hs @@ -15,6 +15,7 @@ module Types Command (..), Timeout (..), ControlScriptArgs (..), + ControlScriptTimeout (..), ) where @@ -65,3 +66,5 @@ newtype ControlScriptArgs = ControlScriptArgs {unControlScriptArgs :: [String]} deriving stock (Show) deriving newtype (Semigroup, Monoid) + +newtype ControlScriptTimeout = ControlScriptTimeout DiffTime