mirror of
https://github.com/typeable/octopod.git
synced 2024-09-11 14:56:38 +03:00
Added archive cleaning to the Octopod Server (#112)
* Force server environment fields on startup * Added archive cleaning into the Octopod Server
This commit is contained in:
parent
f231289fb9
commit
b100a94d0a
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user