Added 30 minute timeout to all control scripts (#114)

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 \

octopod-backend/octopod-backend.cabal

@@ -115,6 +115,7 @@ library
     , hasql-transaction
     , ordered-containers
     , vector
+    , process
   default-language: Haskell2010
 
 executable octopod-exe

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 $

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)

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