Added archive cleaning to the Octopod Server (#112)

* Force server environment fields on startup

* Added archive cleaning into the Octopod Server

octo-cli/src/Octopod/CLI.hs

@@ -81,8 +81,6 @@ runOcto = do
         handleCleanup auth . coerce $ tName
       Restore tName ->
         handleRestore auth . coerce $ tName
-      CleanArchive ->
-        handleCleanArchive auth
       GetActionLogs aId l -> handleGetActionInfo auth aId l
 
 -- | Returns BaseUrl from 'OCTOPOD_URL' environment variable
@@ -190,13 +188,6 @@ handleRestore auth dName = do
   liftIO $
     handleResponse (const $ pure ()) =<< runClientM (restoreH auth dName) clientEnv
 
--- | Handles the 'clean-archive' subcommand.
-handleCleanArchive :: AuthContext AuthHeaderAuth -> ReaderT ClientEnv IO ()
-handleCleanArchive auth = do
-  clientEnv <- ask
-  liftIO $
-    handleResponse (const $ pure ()) =<< runClientM (cleanArchiveH auth) clientEnv
-
 -- | Handles the 'logs' subcommand.
 handleGetActionInfo :: AuthContext AuthHeaderAuth -> ActionId -> LogOutput -> ReaderT ClientEnv IO ()
 handleGetActionInfo auth aId l = do
@@ -223,7 +214,6 @@ _statusH :: AuthContext AuthHeaderAuth -> DeploymentName -> ClientM CurrentDeplo
 cleanupH :: AuthContext AuthHeaderAuth -> DeploymentName -> ClientM CommandResponse
 restoreH :: AuthContext AuthHeaderAuth -> DeploymentName -> ClientM CommandResponse
 getActionInfoH :: AuthContext AuthHeaderAuth -> ActionId -> ClientM ActionInfo
-cleanArchiveH :: AuthContext AuthHeaderAuth -> ClientM CommandResponse
 ( listH
     :<|> createH
     :<|> archiveH
@@ -234,8 +224,7 @@ cleanArchiveH :: AuthContext AuthHeaderAuth -> ClientM CommandResponse
     :<|> cleanupH
     :<|> restoreH
   )
-  :<|> getActionInfoH
-  :<|> cleanArchiveH = pushArrowIntoServantAlt $ client (Proxy @PowerAPI)
+  :<|> getActionInfoH = pushArrowIntoServantAlt $ client (Proxy @PowerAPI)
 
 type PushArrowIntoServantAlt a b = PushArrowIntoServantAlt' a b (CanPushArrow a)
 

octo-cli/src/Octopod/CLI/Args.hs

@@ -48,7 +48,6 @@ data Args
       { -- | deployment name
         name :: Text
       }
-  | CleanArchive
   | GetActionLogs ActionId LogOutput
   deriving stock (Show)
 
@@ -79,9 +78,6 @@ commandArgs =
         <> command "info" (info infoArgs (progDesc "get the deployment info"))
         <> command "cleanup" (info cleanupArgs (progDesc "cleanup the deployment"))
         <> command "restore" (info restoreArgs (progDesc "restore the deployment"))
-        <> command
-          "clean-archive"
-          (info cleanupArchiveArgs (progDesc "cleanup all archived deployments"))
         <> command
           "logs"
           (info actionLogsArgs (progDesc "get deployment logs of a given action"))
@@ -170,11 +166,6 @@ restoreArgs =
   Restore
     <$> strOption (long "name" <> short 'n' <> help "deployment name")
 
--- | Parses arguments of 'clean-archive' subcommand.
-cleanupArchiveArgs :: Parser Args
-cleanupArchiveArgs =
-  pure CleanArchive
-
 actionLogsArgs :: Parser Args
 actionLogsArgs =
   GetActionLogs

octopod-api/src/Octopod/PowerAPI.hs

@@ -42,9 +42,6 @@ type RestoreEndpoint c =
 type GetActionInfoEndpoint =
   "log" :> Capture "action_id" ActionId :> Get '[JSON] ActionInfo
 
-type CleanArchiveEndpoint =
-  "clean_archive" :> Delete '[JSON] CommandResponse
-
 type DeploymentAPI' c =
   Auth '[AuthHeaderAuth] () :> "api" :> "v1"
     :> ( "deployments"
@@ -69,9 +66,6 @@ type DeploymentAPI' c =
              )
           :<|> GetActionInfoEndpoint
           -- endpoint to get action logs
-          :<|> CleanArchiveEndpoint
-          -- endpoint to clean up resources of all archived deployments
-          -- according to the archive retention policy
        )
 
 data AuthHeaderAuth

octopod-backend/src/Octopod/Server.hs

@@ -27,6 +27,7 @@ import qualified Data.ByteString.Lazy.Char8 as BSLC
 import Data.Coerce
 import Data.Conduit (ConduitT, yield)
 import qualified Data.Csv as C
+import Data.Fixed
 import Data.Foldable
 import Data.Functor
 import Data.Generics.Labels ()
@@ -67,6 +68,7 @@ import System.Environment (lookupEnv)
 import System.Exit
 import System.Log.FastLogger
 import System.Posix.Signals (sigTERM)
+import Text.Read (readMaybe)
 import Types
 import Prelude hiding (lines, log, unlines, unwords)
 
@@ -81,56 +83,54 @@ newtype AppM' a = AppM' {runAppM' :: forall m. AppMConstraints m => m a}
 -- | Octopod Server state definition.
 data AppState = AppState
   { -- | postgres pool
-    dbPool :: Pool Connection
+    dbPool :: !(Pool Connection)
   , -- | logger
-    logger :: TimedFastLogger
+    logger :: !TimedFastLogger
   , -- | channel for WS events for the frontend
-    eventSink :: TChan WSEvent
+    eventSink :: !(TChan WSEvent)
   , -- | background workers counter
-    bgWorkersCounter :: IORef Int
+    bgWorkersCounter :: !(IORef Int)
   , -- | flag of activating graceful shutdown
-    gracefulShutdownActivated :: IORef Bool
+    gracefulShutdownActivated :: !(IORef Bool)
   , -- | semaphore for graceful shutdown
-    shutdownSem :: MVar ()
+    shutdownSem :: !(MVar ())
   , -- | project name
-    projectName :: ProjectName
+    projectName :: !ProjectName
   , -- | base domain
-    baseDomain :: Domain
+    baseDomain :: !Domain
   , -- | namespace
-    namespace :: Namespace
-  , -- | archive retention
-    archiveRetention :: ArchiveRetention
+    namespace :: !Namespace
   , -- | status update timeout
-    statusUpdateTimeout :: Timeout
+    statusUpdateTimeout :: !Timeout
   , -- | creation command path
-    creationCommand :: Command
+    creationCommand :: !Command
   , -- | update command path
-    updateCommand :: Command
+    updateCommand :: !Command
   , -- | deletion command path
-    archiveCommand :: Command
+    archiveCommand :: !Command
   , -- | checking command path
-    checkingCommand :: Command
+    checkingCommand :: !Command
   , -- | cleanup command path
-    cleanupCommand :: Command
+    cleanupCommand :: !Command
   , -- | archive checking command path
-    archiveCheckingCommand :: Command
+    archiveCheckingCommand :: !Command
   , -- | tag checking command path
-    configCheckingCommand :: Command
-  , infoCommand :: Command
-  , notificationCommand :: Maybe Command
-  , deploymentOverridesCommand :: Command
-  , deploymentOverrideKeysCommand :: Command
-  , applicationOverridesCommand :: Command
-  , applicationOverrideKeysCommand :: Command
-  , unarchiveCommand :: Command
+    configCheckingCommand :: !Command
+  , infoCommand :: !Command
+  , notificationCommand :: !(Maybe Command)
+  , deploymentOverridesCommand :: !Command
+  , deploymentOverrideKeysCommand :: !Command
+  , applicationOverridesCommand :: !Command
+  , applicationOverrideKeysCommand :: !Command
+  , unarchiveCommand :: !Command
   , -- | Deployments currently being processed which has not yet been
     -- recorded in the database.
-    lockedDeployments :: LockedDeployments
-  , depOverridesCache :: CacheMap ServerError AppM' () (DefaultConfig 'DeploymentLevel)
-  , depOverrideKeysCache :: CacheMap ServerError AppM' () [Text]
-  , appOverridesCache :: CacheMap ServerError AppM' (Config 'DeploymentLevel) (DefaultConfig 'ApplicationLevel)
-  , appOverrideKeysCache :: CacheMap ServerError AppM' (Config 'DeploymentLevel) [Text]
-  , gitSha :: Text
+    lockedDeployments :: !LockedDeployments
+  , depOverridesCache :: !(CacheMap ServerError AppM' () (DefaultConfig 'DeploymentLevel))
+  , depOverrideKeysCache :: !(CacheMap ServerError AppM' () [Text])
+  , appOverridesCache :: !(CacheMap ServerError AppM' (Config 'DeploymentLevel) (DefaultConfig 'ApplicationLevel))
+  , appOverrideKeysCache :: !(CacheMap ServerError AppM' (Config 'DeploymentLevel) [Text])
+  , gitSha :: !Text
   }
   deriving stock (Generic)
 
@@ -171,11 +171,12 @@ runOctopodServer sha = do
   opts <- parseArgs
   let a ?! e = a >>= maybe (die e) pure
       getEnvOrDie eName = lookupEnv eName ?! (eName <> " is not set")
+      getEnvOrDieWith eName f = fmap (>>= f) (lookupEnv eName) ?! (eName <> " is not set")
   projName <- coerce . pack <$> getEnvOrDie "PROJECT_NAME"
   domain <- coerce . pack <$> getEnvOrDie "BASE_DOMAIN"
   ns <- coerce . pack <$> getEnvOrDie "NAMESPACE"
-  archRetention <- ArchiveRetention . fromIntegral . read @Int <$> getEnvOrDie "ARCHIVE_RETENTION"
-  stUpdateTimeout <- Timeout . CalendarDiffTime 0 . fromIntegral . read @Int <$> getEnvOrDie "STATUS_UPDATE_TIMEOUT"
+  archRetention <- fromIntegral <$> getEnvOrDieWith "ARCHIVE_RETENTION" (readMaybe @Int)
+  stUpdateTimeout <- Timeout . CalendarDiffTime 0 . fromIntegral <$> getEnvOrDieWith "STATUS_UPDATE_TIMEOUT" (readMaybe @Int)
   creationCmd <- Command . pack <$> getEnvOrDie "CREATION_COMMAND"
   updateCmd <- Command . pack <$> getEnvOrDie "UPDATE_COMMAND"
   archiveCmd <- Command . pack <$> getEnvOrDie "ARCHIVE_COMMAND"
@@ -240,7 +241,6 @@ runOctopodServer sha = do
           , projectName = projName
           , baseDomain = domain
           , namespace = ns
-          , archiveRetention = archRetention
           , statusUpdateTimeout = stUpdateTimeout
           , creationCommand = creationCmd
           , updateCommand = updateCmd
@@ -270,6 +270,7 @@ runOctopodServer sha = do
       uiServerPort = unServerPort $ octopodUIPort opts
       powerServerPort = unServerPort serverPort
       wsServerPort = unServerPort $ octopodWSPort opts
+  void . L.fork $ flip runReaderT appSt $ runArchiveCleanup archRetention
   powerApp' <- powerApp powerAuthorizationHeader appSt
   (run uiServerPort app')
     `race_` (run powerServerPort powerApp')
@@ -277,6 +278,30 @@ runOctopodServer sha = do
     `race_` (runStatusUpdater appSt)
     `race_` (runShutdownHandler appSt)
 
+runArchiveCleanup ::
+  forall m.
+  (MonadReader AppState m, MonadBaseControl IO m) =>
+  NominalDiffTime ->
+  m ()
+runArchiveCleanup retention = do
+  isShuttingDown >>= \case
+    True -> pure ()
+    False -> do
+      cutoff <- liftBase getCurrentTime <&> addUTCTime (negate retention)
+      dNames <- runStatement $
+        select $ do
+          ds <- each deploymentSchema
+          where_ $ (ds ^. #status) `in_` (litExpr <$> archivedStatuses)
+          where_ $ ds ^. #archivedAt <. litExpr (Just cutoff)
+          pure $ ds ^. #name
+      for_ dNames $ \dName -> (>>= logLeft) . runExceptT $
+        runDeploymentBgWorker Nothing dName (pure ()) $ \() -> cleanupDeployment dName
+      threadDelayMicro (realToFrac $ retention / 10)
+      runArchiveCleanup retention
+  where
+    threadDelayMicro :: Micro -> m ()
+    threadDelayMicro (MkFixed i) = liftBase $ threadDelay (fromInteger i)
+
 runTransaction ::
   (MonadReader AppState m, MonadBaseControl IO m) =>
   Transaction a ->
@@ -378,7 +403,6 @@ powerServer (Authenticated ()) =
       :<|> restoreH
   )
     :<|> getActionInfoH
-    :<|> cleanArchiveH
 powerServer _ = throwAll err401
 
 -- | Application with the WS API.
@@ -965,25 +989,6 @@ deleteDeployment dName =
         , returning = pure ()
         }
 
--- | Handles the 'clean-archive' request.
-cleanArchiveH :: AppM CommandResponse
-cleanArchiveH = do
-  failIfGracefulShutdownActivated
-  st <- ask
-  let archRetention = unArchiveRetention . archiveRetention $ st
-  cutoff <- liftBase getCurrentTime <&> addUTCTime (negate archRetention)
-  dNames <- runStatement $
-    select $ do
-      ds <- each deploymentSchema
-      where_ $ (ds ^. #status) `in_` (litExpr <$> archivedStatuses)
-      where_ $ ds ^. #archivedAt <. litExpr (Just cutoff)
-      pure $ ds ^. #name
-  runBgWorker . void $
-    for dNames $ \dName ->
-      runDeploymentBgWorker Nothing dName (pure ()) $ \() -> cleanupDeployment dName
-
-  pure Success
-
 -- | Handles the 'restore' request.
 restoreH :: DeploymentName -> AppM CommandResponse
 restoreH dName = do
@@ -1131,10 +1136,7 @@ runStatusUpdater state = do
   forever $ do
     currentTime <- liftBase getCurrentTime
     let cutoff = addUTCTime (negate interval) currentTime
-        logLeft :: Either ServerError () -> IO ()
-        logLeft (Left err) = logErr . T.pack $ displayException err
-        logLeft (Right ()) = pure ()
-    (>>= logLeft) . runExceptT . flip runReaderT state $ do
+    flip runReaderT state . (>>= logLeft) . runExceptT $ do
       rows' <- runStatement . select $ do
         ds <- each deploymentSchema
         where_ $ ds ^. #checkedAt <. litExpr cutoff
@@ -1178,6 +1180,13 @@ runStatusUpdater state = do
       when (Prelude.or updated) $ liftBase $ sendReloadEvent state
       liftBase $ threadDelay 2000000
 
+logLeft :: (MonadBase IO m, MonadReader AppState m, Exception e) => Either e () -> m ()
+logLeft (Left err) = do
+  state <- ask
+  let logErr = liftBase . logWarning (logger state)
+  logErr . T.pack $ displayException err
+logLeft (Right ()) = pure ()
+
 -- | Returns the new deployment status.
 statusTransition ::
   ExitCode ->
@@ -1207,12 +1216,16 @@ failureStatusType _ = GenericFailure
 -- if graceful shutdown has been activated.
 failIfGracefulShutdownActivated :: AppM ()
 failIfGracefulShutdownActivated = do
-  gracefulShutdownAct <- gracefulShutdownActivated <$> ask
-  gracefulShutdown <- liftIO . readIORef $ gracefulShutdownAct
+  gracefulShutdown <- isShuttingDown
   if gracefulShutdown
     then throwError err405 {errBody = appError "Graceful shutdown activated"}
     else pure ()
 
+isShuttingDown :: (MonadReader AppState m, MonadBase IO m) => m Bool
+isShuttingDown = do
+  gracefulShutdownAct <- gracefulShutdownActivated <$> ask
+  liftBase . readIORef $ gracefulShutdownAct
+
 -- | Handles the graceful shutdown signal.
 -- Sends a signal to the 'shutdownSem' semaphore
 -- if the background worker counter is 0.

octopod-backend/src/Types.hs

@@ -13,7 +13,6 @@ module Types
     Domain (..),
     Namespace (..),
     Command (..),
-    ArchiveRetention (..),
     Timeout (..),
     ControlScriptArgs (..),
   )
@@ -53,10 +52,6 @@ newtype Domain = Domain {unDomain :: Text}
 newtype Namespace = Namespace {unNamespace :: Text}
   deriving stock (Show)
 
--- | Archive retention.
-newtype ArchiveRetention = ArchiveRetention {unArchiveRetention :: NominalDiffTime}
-  deriving stock (Show)
-
 -- | Timeout.
 newtype Timeout = Timeout {unTimeout :: CalendarDiffTime}
   deriving stock (Show)