From ac83908e80094560913025d6ceea5067e8b45c48 Mon Sep 17 00:00:00 2001 From: iko Date: Fri, 5 Feb 2021 17:17:55 +0300 Subject: [PATCH] Refactored status changes and added deployment locking (#24) * First stab at refactoring status transitions * Removed 'archived' column from database * Added deployment locking * Added transition possibility assertion at the start of background tasks * Added a notification control script (#27) * Added notification script * Updated docs * Fixed link * fixed link * Fixed response error body rendering * Resolved comments and fixed some bugs after rebasing * added info script back in --- .gitignore | 1 + dev/dev_backend.sh | 1 + dev/write.sh | 4 + docs/en/Control_scripts.md | 24 + docs/ru/Control_scripts.md | 16 + migrations/deploy/remove_archived_column.sql | 9 + migrations/revert/remove_archived_column.sql | 8 + migrations/sqitch.plan | 1 + migrations/verify/remove_archived_column.sql | 7 + octopod-backend/octopod-backend.cabal | 11 + .../src/Control/Octopod/DeploymentLock.hs | 55 ++ .../Database/PostgreSQL/Simple/Instances.hs | 5 +- octopod-backend/src/Octopod/Server.hs | 684 ++++++++++-------- .../src/Octopod/Server/ControlScriptUtils.hs | 93 ++- octopod-backend/src/Octopod/Server/Logger.hs | 4 + octopod-common/src/Common/Types.hs | 20 +- octopod-frontend/src/Frontend/API.hs | 4 +- octopod-frontend/src/Frontend/Utils.hs | 17 +- octopod-frontend/src/Main.hs | 2 +- octopod-frontend/src/Page/Deployment.hs | 13 +- octopod-frontend/src/Page/Deployments.hs | 7 +- .../src/Page/Popup/EditDeployment.hs | 3 +- .../src/Page/Popup/NewDeployment.hs | 3 +- octopod-frontend/src/Servant/Reflex/Extra.hs | 26 +- 24 files changed, 685 insertions(+), 333 deletions(-) create mode 100755 dev/write.sh create mode 100644 migrations/deploy/remove_archived_column.sql create mode 100644 migrations/revert/remove_archived_column.sql create mode 100644 migrations/verify/remove_archived_column.sql create mode 100644 octopod-backend/src/Control/Octopod/DeploymentLock.hs diff --git a/.gitignore b/.gitignore index 7882e76..35ae62c 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ octopod-config.json frontend-result octopod-css/node_modules dev/certs/* +tmp/* diff --git a/dev/dev_backend.sh b/dev/dev_backend.sh index 2009f0c..3b1bd94 100755 --- a/dev/dev_backend.sh +++ b/dev/dev_backend.sh @@ -18,6 +18,7 @@ export CLEANUP_COMMAND=$MOUNT_DIR/echo.sh export ARCHIVE_CHECKING_COMMAND=$MOUNT_DIR/echo.sh export TAG_CHECKING_COMMAND=$MOUNT_DIR/echo.sh export INFO_COMMAND=$MOUNT_DIR/info.sh +export NOTIFICATION_COMMAND=$MOUNT_DIR/write.sh $1/bin/octopod-exe \ --port 4443 \ --ui-port 3002 \ diff --git a/dev/write.sh b/dev/write.sh new file mode 100755 index 0000000..71803cf --- /dev/null +++ b/dev/write.sh @@ -0,0 +1,4 @@ +#!/bin/bash + +echo $0 $@ >> ./tmp/calls.txt +exit 0 diff --git a/docs/en/Control_scripts.md b/docs/en/Control_scripts.md index a781e86..9d549ef 100644 --- a/docs/en/Control_scripts.md +++ b/docs/en/Control_scripts.md @@ -39,6 +39,9 @@ - [Description](#description-8) - [Execution example](#execution-example-7) - [Sample implementation](#sample-implementation-7) + - [🔔 notifications](#-notifications) + - [Description](#description-9) + - [Execution example](#execution-example-8) @@ -296,4 +299,25 @@ echo "app,https://${name}.example.com" echo "api,https://api.${name}.example.com" ``` +### 🔔 notifications + +#### Description + +This script gets called every time a deployment changes its status (apart from creation and deletion). It might be useful if you want to send notifications about certain deployment status transitions. The complete list of statuses and their transitions can be found in the [technical architecture document](Technical_architecture.md#️-deployment-state-transitions). + +It is optional and can be omitted altogether. + +This script receives the following additional command-line arguments as input: +* `--tag` – The _Docker Image tag_ that should be deployed. (In practice you can use some other string that identifies a version of your system to deploy – you will need to process it accordingly in the script.) +- `--old-status` – The previous status the deployment was in. +- `--new-status` – The new status the deployment transitioned to. + +#### Execution example + +The script might be called something like this: + +```bash +notification --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button" --tag "c9bbc3fcc69e5aa094bca110c6f79419ab7be77a" --old-status "UpdatePending" --new-status "Running" +``` + [configmap]: https://kubernetes.io/docs/concepts/configuration/configmap/ diff --git a/docs/ru/Control_scripts.md b/docs/ru/Control_scripts.md index 4816aac..527ca9e 100644 --- a/docs/ru/Control_scripts.md +++ b/docs/ru/Control_scripts.md @@ -12,6 +12,7 @@ - [tag_check](#tag_check) - [init](#init) - [info](#info) +- [notifications](#notifications) @@ -212,3 +213,18 @@ echo "api,https://api.${name}.example.com" ``` [kubedog]: https://github.com/werf/kubedog + +## notifications + +Этот скрипт вызывается каждый раз, когда развертывание меняет свой статус. (При создании и удалении не вызывается.) + +Полный список статусов и их переходов можно найти в документе по [технической архитектуре](Technical_architecture.md#deployment-state-transitions). + +Получает на вход следующие аргументы: +* `--project-name` – название проекта +* `--base-domain` – базовый домен +* `--namespace` – namespace +* `--name` – имя стейджинга +* `--tag` – тег развертывания +- `--old-status` – предыдущий статус +- `--new-status` – новый статус diff --git a/migrations/deploy/remove_archived_column.sql b/migrations/deploy/remove_archived_column.sql new file mode 100644 index 0000000..f7379bd --- /dev/null +++ b/migrations/deploy/remove_archived_column.sql @@ -0,0 +1,9 @@ +-- Deploy octopod:remove_archived_column to pg + BEGIN; + + +ALTER TABLE "public"."deployments" +DROP COLUMN "archived"; + + +COMMIT; diff --git a/migrations/revert/remove_archived_column.sql b/migrations/revert/remove_archived_column.sql new file mode 100644 index 0000000..106998b --- /dev/null +++ b/migrations/revert/remove_archived_column.sql @@ -0,0 +1,8 @@ +-- Revert octopod:remove_archived_column from pg + BEGIN; + + +ALTER TABLE "public"."deployments" ADD COLUMN "archived" bool NOT NULL DEFAULT 'false'; + + +COMMIT; diff --git a/migrations/sqitch.plan b/migrations/sqitch.plan index 4bf48e5..c9b3358 100644 --- a/migrations/sqitch.plan +++ b/migrations/sqitch.plan @@ -14,3 +14,4 @@ rename_elements_of_scope_enum 2020-08-19T09:38:40Z Typeable LLC # Renamed delete to archive rename_delete_to_archive_2 2020-11-26T08:28:58Z Typeable LLC # Renamed delete to archive add_detailed_failures 2021-02-04T11:01:15Z Typeable LLC # Added more failure states +remove_archived_column 2021-01-28T18:44:54Z Typeable LLC # Removed 'archived' column diff --git a/migrations/verify/remove_archived_column.sql b/migrations/verify/remove_archived_column.sql new file mode 100644 index 0000000..105c1db --- /dev/null +++ b/migrations/verify/remove_archived_column.sql @@ -0,0 +1,7 @@ +-- Verify octopod:remove_archived_column on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; diff --git a/octopod-backend/octopod-backend.cabal b/octopod-backend/octopod-backend.cabal index 0817860..1cb4de3 100644 --- a/octopod-backend/octopod-backend.cabal +++ b/octopod-backend/octopod-backend.cabal @@ -35,6 +35,13 @@ library , StandaloneDeriving , TypeApplications , TypeOperators + , OverloadedLabels + , UndecidableInstances + , MultiParamTypeClasses + , FunctionalDependencies + , RankNTypes + , TypeFamilies + , QuantifiedConstraints exposed-modules: Octopod.Server Octopod.Server.Args @@ -45,6 +52,7 @@ library TLS Types Database.PostgreSQL.Simple.Instances + Control.Octopod.DeploymentLock hs-source-dirs: src build-depends: @@ -93,6 +101,9 @@ library , x509-store , x509-validation , containers + , monad-control + , lifted-base + , containers default-language: Haskell2010 executable octopod-exe diff --git a/octopod-backend/src/Control/Octopod/DeploymentLock.hs b/octopod-backend/src/Control/Octopod/DeploymentLock.hs new file mode 100644 index 0000000..6a3c80d --- /dev/null +++ b/octopod-backend/src/Control/Octopod/DeploymentLock.hs @@ -0,0 +1,55 @@ +module Control.Octopod.DeploymentLock + ( LockedDeployments + , initLockedDeployments + , withLockedDeployment + , isDeploymentLocked + ) where + +import Common.Types +import Control.Concurrent.STM +import Control.Exception.Lifted +import Control.Monad.Base +import Control.Monad.Reader +import Control.Monad.Trans.Control +import Data.Generics.Product.Typed +import Data.Set (Set) +import qualified Data.Set as S + +newtype LockedDeployments = LockedDeployments (TVar (Set DeploymentName)) + +initLockedDeployments :: IO LockedDeployments +initLockedDeployments = LockedDeployments <$> newTVarIO S.empty + +withLockedDeployment + :: + ( MonadReader r m + , HasType LockedDeployments r + , MonadBaseControl IO m + ) + => DeploymentName + -> m a + -- ^ The conflict handler. Gets called if the deployment is + -- already being processed. + -> m a + -- ^ The actions to be performed when the deployment is locked. + -> m a +withLockedDeployment dName conflictHandler m = do + (LockedDeployments tvar) <- asks getTyped + proceed <- liftBase . atomically $ do + s <- readTVar tvar + if S.member dName s + then return False -- Do not proceed + else do + writeTVar tvar (S.insert dName s) + return True -- Proceed + if proceed + then finally m $ liftBase . atomically $ modifyTVar tvar (S.delete dName) + else conflictHandler + +isDeploymentLocked + :: (MonadReader r m , HasType LockedDeployments r, MonadBase IO m) + => DeploymentName -> m Bool +isDeploymentLocked dName = do + (LockedDeployments tvar) <- asks getTyped + s <- liftBase $ readTVarIO tvar + return $ S.member dName s diff --git a/octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs b/octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs index 6ceb13b..2423940 100644 --- a/octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs +++ b/octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs @@ -11,6 +11,7 @@ import qualified Data.Map as M import Data.Text (Text) import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.ToField +import qualified Data.Text.Encoding as T deploymentStatusText :: DeploymentStatus -> Text deploymentStatusText Running = "Running" @@ -26,7 +27,8 @@ instance ToField DeploymentStatus where toField = toField @Text . deploymentStatusText instance FromField DeploymentStatus where - fromField f b = fromField f b >>= maybe empty return . flip M.lookup m + fromField _ (Just b) = + (either (const empty) pure . T.decodeUtf8' $ b) >>= maybe empty return . flip M.lookup m where m = M.fromList . fmap (deploymentStatusText &&& id) $ [ Running @@ -38,3 +40,4 @@ instance FromField DeploymentStatus where , ArchivePending , Archived ] + fromField _ Nothing = empty diff --git a/octopod-backend/src/Octopod/Server.hs b/octopod-backend/src/Octopod/Server.hs index e99b7b1..94e605f 100644 --- a/octopod-backend/src/Octopod/Server.hs +++ b/octopod-backend/src/Octopod/Server.hs @@ -3,27 +3,28 @@ module Octopod.Server (runOctopodServer) where import Chronos (Time, getTime, now) import Control.Applicative -import Control.Concurrent (forkFinally, threadDelay) +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) +import qualified Control.Concurrent.Lifted as L import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception (Exception, throwIO, try) +import Control.Lens import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Except +import Control.Monad.Reader import Data.Aeson (Value(..), encode, toJSON) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL import Data.Coerce import Data.Conduit (ConduitT, yield) import Data.Foldable (foldrM) -import Data.Functor ((<&>)) +import Data.Functor import Data.Int (Int64) import Data.IORef import Data.Maybe import Data.Pool import Data.Text (lines, pack, unpack, unwords) -import Data.Text.IO (hGetContents) import Data.Traversable import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Instances () @@ -37,11 +38,15 @@ import System.Environment (lookupEnv) import System.Exit import System.Log.FastLogger import System.Posix.Signals (sigTERM) -import System.Process.Typed -import Common.Utils import Common.Validation (isNameValid) +import Control.Monad.Base +import Control.Monad.Trans.Control +import Control.Octopod.DeploymentLock +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Generics.Labels () +import qualified Data.Text.Encoding as T import Database.PostgreSQL.Simple.Transaction import Octopod.API import Octopod.PowerAPI @@ -52,6 +57,7 @@ import Octopod.Server.Posix import Orphans () import TLS (createTLSOpts) import Types +import Control.Lens.Extras type PgPool = Pool Connection type AppM = ReaderT AppState Handler @@ -95,7 +101,11 @@ data AppState = AppState , tagCheckingCommand :: Command -- ^ tag checking command path , infoCommand :: Command - } + , notificationCommand :: Maybe Command + , lockedDeployments :: LockedDeployments + -- ^ Deployments currently being processed which has not yet been + -- recorded in the database. + } deriving Generic -- | Deployment exception definition. data DeploymentException @@ -118,18 +128,6 @@ data FullInfoListType | FullInfoOnlyForOne DeploymentName deriving (Show) --- | Deployment search errors definition. -data DeploymentNotFound - = DeploymentNotFound - | ArchivedDeploymentNotFound - | ActiveDeploymentNotFound - | DeploymentHasPendingStatus DeploymentStatus - --- | Definition of a filter by pending statuses. -data FilterByPending - = AllowPending - | DenyPending - runOctopodServer :: IO () runOctopodServer = do logger' <- newLogger @@ -158,10 +156,15 @@ runOctopodServer = do archiveCheckingCmd <- coerce . pack <$> getEnvOrDie "ARCHIVE_CHECKING_COMMAND" tagCheckingCmd <- coerce . pack <$> getEnvOrDie "TAG_CHECKING_COMMAND" infoCmd <- coerce . pack <$> getEnvOrDie "INFO_COMMAND" + notificationCmd <- (fmap . fmap) (Command . pack) + $ lookupEnv "NOTIFICATION_COMMAND" <&> \case + Just "" -> Nothing + x -> x pgPool <- initConnectionPool (unDBConnectionString $ octopodDB opts) (unDBPoolSize $ octopodDBPoolSize opts) channel <- liftIO . atomically $ newBroadcastTChan + lockedDs <- initLockedDeployments let appSt = AppState @@ -184,6 +187,8 @@ runOctopodServer = do archiveCheckingCmd tagCheckingCmd infoCmd + notificationCmd + lockedDs app' = app appSt powerApp' = powerApp appSt wsApp' = wsApp channel @@ -263,7 +268,9 @@ powerListH :: AppM [DeploymentFullInfo] powerListH = getFullInfo FullInfoForAll -- | Handles the 'full_info' request of the Web UI API. -fullInfoH :: DeploymentName -> AppM DeploymentFullInfo +fullInfoH + :: (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) + => DeploymentName -> m DeploymentFullInfo fullInfoH dName = do fullInfoList <- hidePrivateOverridesInFullInfos <$> getFullInfo (FullInfoOnlyForOne dName) @@ -284,7 +291,7 @@ powerFullInfoH dName = do -- | Hides private overrides in 'full_info' response. hidePrivateOverridesInFullInfos :: [DeploymentFullInfo] -> [DeploymentFullInfo] hidePrivateOverridesInFullInfos dFullInfos = do - dFullInfos <&> \(DeploymentFullInfo dep s a ct ut u) -> + dFullInfos <&> \(DeploymentFullInfo dep s ct ut u) -> let hidePrivate (Deployment n t appOvs depOvs) = Deployment n t (hideP appOvs) (hideP depOvs) @@ -295,32 +302,47 @@ hidePrivateOverridesInFullInfos dFullInfos = do Private -> "*" Public -> v in coerce $ Override k v' vis - in DeploymentFullInfo (hidePrivate dep) s a ct ut u + in DeploymentFullInfo (hidePrivate dep) s ct ut u + +getFullInfo + :: (MonadReader AppState m, MonadBaseControl IO m) + => FullInfoListType + -> m [DeploymentFullInfo] +getFullInfo lType = do + p <- asks pool + liftBaseOp (withResource p) $ \conn -> getFullInfo' conn lType -- | Helper to get full_info from the database. -getFullInfo :: FullInfoListType -> AppM [DeploymentFullInfo] -getFullInfo listType = do - AppState {pool = p, logger = l} <- ask - deployments <- liftIO $ withResource p $ \conn -> do +getFullInfo' + :: (MonadReader AppState m, MonadBase IO m) + => Connection + -> FullInfoListType + -> m [DeploymentFullInfo] +getFullInfo' conn listType = do + AppState {logger = l} <- ask + deployments <- do rows <- case listType of - FullInfoForAll -> query_ conn qAll - FullInfoOnlyForOne (dName) -> query conn qOne (Only dName) - for rows $ \(n, t, a, ct, ut, st) -> do - (appOvs, depOvs) <- selectOverrides conn n - dMeta <- selectDeploymentMetadata conn n + FullInfoForAll -> liftBase $ query_ conn qAll + FullInfoOnlyForOne dName -> liftBase $ query conn qOne (Only dName) + for rows $ \(n, t, ct, ut, st) -> do + (appOvs, depOvs) <- liftBase $ selectOverrides conn n + dMeta <- liftBase $ selectDeploymentMetadata conn n + st' <- isDeploymentLocked n <&> \case + True -> DeploymentPending st + False -> DeploymentNotPending st pure $ do - let dep = (Deployment n t appOvs depOvs) - DeploymentFullInfo dep st a dMeta ct ut - liftIO . logInfo l $ "get deployments: " <> (pack . show $ deployments) + let dep = Deployment n t appOvs depOvs + DeploymentFullInfo dep st' dMeta ct ut + liftBase . logInfo l $ "get deployments: " <> (pack . show $ deployments) return deployments where qAll = - "SELECT name, tag, archived, extract(epoch from created_at)::int, \ - \extract(epoch from updated_at)::int, status::text \ + "SELECT name, tag, extract(epoch from created_at)::int, \ + \extract(epoch from updated_at)::int, status \ \FROM deployments ORDER BY name" qOne = - "SELECT name, tag, archived, extract(epoch from created_at)::int, \ - \extract(epoch from updated_at)::int, status::text \ + "SELECT name, tag, extract(epoch from created_at)::int, \ + \extract(epoch from updated_at)::int, status \ \FROM deployments \ \WHERE name = ?" @@ -337,42 +359,43 @@ createH dep = do { errBody = validationError [badNameText] [] } t1 <- liftIO $ now st <- ask - let - q = - "INSERT INTO deployments (name, tag, status) \ - \VALUES (?, ?, ?) RETURNING id" - pgPool = pool st - createDep :: PgPool -> Deployment -> IO [Only Int] - createDep p Deployment { name = n, tag = t } = - withResource p $ \conn -> - query conn q (n, t, CreatePending) failIfImageNotFound (name dep) (tag dep) failIfGracefulShutdownActivated - res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep - dId <- case res of - Right ((Only depId) : _) -> - pure . DeploymentId $ depId - Right [] -> - throwError err404 - { errBody = validationError ["Name not found"] [] } - Left (SqlError code _ _ _ _) | code == unique_violation -> - throwError err400 - { errBody = validationError ["Deployment already exists"] [] } - Left (SqlError _ _ _ _ _) -> - throwError err409 { errBody = appError "Some database error" } - liftIO . withResource pgPool $ \conn -> - upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep) - liftIO . runBgWorker st $ do - sendReloadEvent st - updateDeploymentInfo (name dep) st - (ec, out, err) <- createDeployment dep st - t2 <- now + runDeploymentBgWorker Nothing (name dep) $ do + let + q = + "INSERT INTO deployments (name, tag, status) \ + \VALUES (?, ?, ?) RETURNING id" + pgPool = pool st + createDep :: PgPool -> Deployment -> IO [Only Int] + createDep p Deployment { name = n, tag = t } = + withResource p $ \conn -> + query conn q (n, t, CreatePending) + res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep + dId <- case res of + Right ((Only depId) : _) -> + pure . DeploymentId $ depId + Right [] -> + throwError err404 + { errBody = validationError ["Name not found"] [] } + Left (SqlError code _ _ _ _) | code == unique_violation -> + throwError err400 + { errBody = validationError ["Deployment already exists"] [] } + Left (SqlError _ _ _ _ _) -> + throwError err409 { errBody = appError "Some database error" } + liftIO . withResource pgPool $ \conn -> + upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep) + liftBase $ sendReloadEvent st + liftBase $ updateDeploymentInfo (name dep) st + (ec, out, err) <- liftBase $ createDeployment dep st + t2 <- liftBase $ now let - arch = ArchivedFlag False elTime = elapsedTime t2 t1 - createDeploymentLog pgPool dep "create" ec arch elTime out err - sendReloadEvent st - handleExitCode ec + liftIO . withResource pgPool $ \conn -> + -- calling it directly now is fine since there is no previous status. + createDeploymentLog conn dep "create" ec elTime out err + liftBase $ sendReloadEvent st + liftBase $ handleExitCode ec pure Success -- | Updates deployment info. @@ -455,74 +478,173 @@ selectDeploymentLogs pgPool dId = do -- | Helper to get a deployment. selectDeployment - :: PgPool - -> DeploymentName - -> DeploymentListType - -> FilterByPending - -> AppM (Either DeploymentNotFound Deployment) -selectDeployment pgPool dName lType filterByPending = do - let - baseQuery = - "SELECT name, tag, status::text FROM deployments \ - \WHERE name = ?" - q AllDeployments = baseQuery - q ArchivedOnlyDeployments = baseQuery <> " AND archived = 't'" - q ActiveOnlyDeployments = baseQuery <> " AND archived = 'f'" - allowPending = - case filterByPending of - AllowPending -> True - DenyPending -> False - result <- liftIO . withResource pgPool $ \conn -> do - retrieved <- query conn (q lType) (Only dName) - for retrieved $ \(n, t, s) -> do - (appOvs, stOvs) <- selectOverrides conn n - pure $ (Deployment n t appOvs stOvs, read s) - pure $ - case result of - [(_, st)] | isPending st && not allowPending -> - Left $ DeploymentHasPendingStatus st - [(dep, _)] -> - Right dep - _ -> - Left $ - case lType of - AllDeployments -> DeploymentNotFound - ArchivedOnlyDeployments -> ArchivedDeploymentNotFound - ActiveOnlyDeployments -> ActiveDeploymentNotFound - --- | Handles deployment search result. -unwrapOrValidateError - :: AppM (Either DeploymentNotFound Deployment) + :: DeploymentName -> AppM Deployment -unwrapOrValidateError deploymentSearchResult = do - deploymentSearchResult' <- deploymentSearchResult - case deploymentSearchResult' of - Right dep -> pure dep - Left DeploymentNotFound -> - throwError err404 - { errBody = validationError ["Deployment not found"] [] } - Left ArchivedDeploymentNotFound -> - throwError err404 - { errBody = validationError ["Archived deployment not found"] [] } - Left ActiveDeploymentNotFound -> - throwError err404 - { errBody = validationError ["Active deployment not found"] [] } - Left (DeploymentHasPendingStatus st) -> - let - err = - "You can not apply this operation \ - \on deployment with \"" <> (pack . show $ st) <> "\" status" - in throwError err405 { errBody = validationError [err] [] } +selectDeployment dName = do + pgPool <- asks pool + let q = "SELECT name, tag FROM deployments WHERE name = ?" + liftBaseOp (withResource pgPool) $ \conn -> do + retrieved <- liftBase $ query conn q (Only dName) + case retrieved of + [(n, t)] -> do + (appOvs, stOvs) <- liftBase $ selectOverrides conn n + pure $ Deployment n t appOvs stOvs + [] -> throwError err404 {errBody = "Deployment not found."} + _ -> throwError err500 + +data StatusTransitionProcessOutput = StatusTransitionProcessOutput + { exitCode :: ExitCode + , duration :: Duration + , stdout :: Stdout + , stderr :: Stderr + } deriving (Generic, Show) + +data DeploymentStatusTransition + = TransitionArchived + | TransitionCreate + | TransitionUpdate + | TransitionRestore StatusTransitionProcessOutput + | TransitionArchivePending StatusTransitionProcessOutput + | TransitionUpdatePending StatusTransitionProcessOutput + | TransitionCreatePending StatusTransitionProcessOutput + | TransitionFailure FailureType + deriving Show + +transitionStatus :: DeploymentStatusTransition -> DeploymentStatus +transitionStatus TransitionArchived {} = Archived +transitionStatus TransitionCreate {} = Running +transitionStatus TransitionUpdate {} = Running +transitionStatus TransitionRestore {} = Running +transitionStatus TransitionArchivePending {} = ArchivePending +transitionStatus TransitionUpdatePending {} = UpdatePending +transitionStatus TransitionCreatePending {} = CreatePending +transitionStatus (TransitionFailure t) = Failure t + +processOutput :: DeploymentStatusTransition -> Maybe (StatusTransitionProcessOutput, Action) +processOutput TransitionArchived = Nothing +processOutput TransitionCreate = Nothing +processOutput TransitionUpdate = Nothing +processOutput (TransitionRestore x) = Just (x, Action "restore") +processOutput (TransitionArchivePending x) = Just (x, Action "archive") +processOutput (TransitionUpdatePending x) = Just (x, Action "update") +processOutput (TransitionCreatePending x) = Just (x, Action "create") +processOutput TransitionFailure {} = Nothing + +transitionToStatusS + :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) + => DeploymentName -> DeploymentStatusTransition -> m () +transitionToStatusS dName tran = + runExceptT (transitionToStatus dName tran) >>= transitionErrorToServerError + +transitionErrorToServerError :: MonadError ServerError m => Either StatusTransitionError a -> m a +transitionErrorToServerError = \case + Right x -> return x + Left (InvalidStatusTransition dName a b) -> throwError err409 + { errBody + = "Unable to transition deployment " + <> (BSL.fromStrict . T.encodeUtf8 . unDeploymentName) dName + <> " from " <> show'' a <> " to " <> show'' b <> "." + } + Left (DeploymentNotFound dName) -> throwError err404 + { errBody + = "Couldn't find deployment " + <> (BSL.fromStrict . T.encodeUtf8 . unDeploymentName) dName <> "." + } + where + show'' = BSLC.pack . show + +transitionToStatus + :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) + => DeploymentName -> DeploymentStatusTransition -> ExceptT StatusTransitionError m () +transitionToStatus dName s = do + p <- asks pool + st <- ask + let log = liftBase . logInfo (logger st) + (oldS, newS) <- withResource p $ \conn -> liftBaseOp_ (withTransaction conn) $ do + dep <- lift (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case + [x] -> return x + _ -> throwError $ DeploymentNotFound dName + let + oldS = recordedStatus $ dep ^. #status + newS = transitionStatus s + assertStatusTransitionPossible dName oldS newS + log $ "Transitioning deployment " <> (show' . unDeploymentName) dName <> " " <> show' s + let + q = + "UPDATE deployments \ + \SET status = ?, status_updated_at = now() " + <> (if newS == ArchivePending then ", archived_at = now()" else mempty) + <> " WHERE name = ?" + void . liftBase $ execute conn q (newS, dName) + liftBase $ forM_ (processOutput s) $ \(output, act) -> + createDeploymentLog + conn + (dep ^. #deployment) + act + (output ^. #exitCode) + (output ^. #duration) + (output ^. #stdout) + (output ^. #stderr) + return (oldS, newS) + notificationCmd <- asks notificationCommand + forM_ notificationCmd $ \nCmd -> + runBgWorker . void $ runCommandArgs' nCmd =<< notificationCommandArgs dName oldS newS + liftBase $ sendReloadEvent st + +assertStatusTransitionPossible + :: MonadError StatusTransitionError m + => DeploymentName + -> DeploymentStatus + -> DeploymentStatus + -> m () +assertStatusTransitionPossible dName old new = + unless + (possibleTransitions old new) + (throwError $ InvalidStatusTransition dName old new) + +assertDeploymentTransitionPossible + :: (MonadError StatusTransitionError m, MonadReader AppState m, MonadBaseControl IO m) + => DeploymentName + -> DeploymentStatus + -> m () +assertDeploymentTransitionPossible dName new = do + p <- asks pool + dep <- withResource p $ \conn -> (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case + [x] -> return x + _ -> throwError $ DeploymentNotFound dName + assertStatusTransitionPossible dName (recordedStatus $ dep ^. #status) new + +assertDeploymentTransitionPossibleS + :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) + => DeploymentName + -> DeploymentStatus + -> m () +assertDeploymentTransitionPossibleS dName new = + runExceptT (assertDeploymentTransitionPossible dName new) >>= transitionErrorToServerError +data StatusTransitionError + = InvalidStatusTransition DeploymentName DeploymentStatus DeploymentStatus + | DeploymentNotFound DeploymentName + deriving Show + +possibleTransitions :: DeploymentStatus -> DeploymentStatus -> Bool +possibleTransitions CreatePending = anyPred [is #_Running, is #_Failure] +possibleTransitions Running = anyPred [is #_Failure, is #_ArchivePending, is #_UpdatePending] +possibleTransitions UpdatePending = anyPred [is #_Failure, is #_Running] +possibleTransitions (Failure _) = anyPred [is #_UpdatePending, is #_Running, is #_ArchivePending] +possibleTransitions ArchivePending = anyPred [is #_ArchivePending, is #_Archived] +possibleTransitions Archived = anyPred [is #_CreatePending] + +anyPred :: [a -> Bool] -> a -> Bool +anyPred preds x = any ($ x) preds -- | Handles the 'archive' request. archiveH :: DeploymentName -> AppM CommandResponse archiveH dName = do failIfGracefulShutdownActivated - t1 <- liftIO $ now + t1 <- liftBase now st <- ask let - log = logInfo (logger st) - pgPool = pool st + log = liftBase . logInfo (logger st) args = [ "--project-name", coerce $ projectName st , "--base-domain", coerce $ baseDomain st @@ -530,33 +652,20 @@ archiveH dName = do , "--name", coerce dName ] cmd = coerce $ archiveCommand st - arch = ArchivedFlag True - dep <- unwrapOrValidateError - $ selectDeployment pgPool dName ActiveOnlyDeployments DenyPending - liftIO . runBgWorker st $ do + runDeploymentBgWorker (Just ArchivePending) dName $ do log $ "call " <> unwords (cmd : args) (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args) - void $ archiveDeployment pgPool dName - sendReloadEvent st - t2 <- now + t2 <- liftBase now let elTime = elapsedTime t2 t1 - void $ createDeploymentLog pgPool dep "archive" ec arch elTime out err - log $ "deployment archived, name: " <> coerce dName - sendReloadEvent st + transitionToStatusS dName $ TransitionArchivePending StatusTransitionProcessOutput + { exitCode = ec + , duration = elTime + , stdout = out + , stderr = err + } handleExitCode ec pure Success --- | Handles the 'archive' request. -archiveDeployment :: PgPool -> DeploymentName -> IO Int64 -archiveDeployment p dName = withResource p $ \conn -> do - let - q = - "UPDATE deployments \ - \SET archived = 't', archived_at = now(), \ - \status = ?, status_updated_at = now() \ - \WHERE name = ?" - execute conn q (ArchivePending, dName) - -- | Handles the 'update' request. updateH :: DeploymentName -> DeploymentUpdate -> AppM CommandResponse updateH dName dUpdate = do @@ -573,21 +682,18 @@ updateH dName dUpdate = do } = dUpdate pgPool = pool st log = logInfo (logger st) - - void $ unwrapOrValidateError - $ selectDeployment pgPool dName ActiveOnlyDeployments DenyPending dId <- selectDeploymentId pgPool dName failIfImageNotFound dName dTag failIfGracefulShutdownActivated - liftIO . runBgWorker st $ do - (appOvs, depOvs) <- withResource pgPool $ \conn -> + runDeploymentBgWorker (Just UpdatePending) dName $ do + (appOvs, depOvs) <- liftBase . withResource pgPool $ \conn -> withTransaction conn $ do deleteOldOverrides conn dId oldAppOvs oldDepOvs upsertNewOverrides conn dId newAppOvs newDepOvs - void $ updateDeployment conn dName dTag + updateTag conn dId dTag selectOverrides conn dName - updateDeploymentInfo dName st - sendReloadEvent st + liftBase $ updateDeploymentInfo dName st + liftBase $ sendReloadEvent st let args = [ "--project-name", coerce $ projectName st @@ -598,18 +704,18 @@ updateH dName dUpdate = do ] ++ applicationOverridesToArgs appOvs ++ deploymentOverridesToArgs depOvs cmd = coerce $ updateCommand st - log $ "call " <> unwords (cmd : args) - (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args) - log $ "deployment updated, name: " + liftBase . log $ "call " <> unwords (cmd : args) + (ec, out, err) <- liftBase $ runCommand (unpack cmd) (unpack <$> args) + liftBase . log $ "deployment updated, name: " <> coerce dName <> ", tag: " <> coerce dTag - void $ do - t2 <- now - let - dep = Deployment dName dTag appOvs depOvs - arch = ArchivedFlag False - elTime = elapsedTime t2 t1 - createDeploymentLog pgPool dep "update" ec arch elTime out err - sendReloadEvent st + t2 <- liftBase now + let elTime = elapsedTime t2 t1 + transitionToStatusS dName $ TransitionUpdatePending StatusTransitionProcessOutput + { exitCode = ec + , duration = elTime + , stdout = out + , stderr = err + } handleExitCode ec return Success @@ -731,20 +837,15 @@ upsertNewOverrides conn dId appOvs depOvs = do oVis = show . overrideVisibility . unDeploymentOverride $ o execute conn q (oKey, oValue, dId', oScope, oVis, oValue, oVis) --- | Helper to update a deployment. -updateDeployment +updateTag :: Connection - -> DeploymentName + -> DeploymentId -> DeploymentTag - -> IO Int64 -updateDeployment conn dName dTag = do + -> IO () +updateTag conn (DeploymentId dId) (DeploymentTag dTag) = do let - q = - "UPDATE deployments \ - \SET tag = ?, updated_at = now(), \ - \status = ?, status_updated_at = now() \ - \WHERE name = ?" - execute conn q (dTag, UpdatePending, dName) + q = "UPDATE deployments SET tag=? WHERE id=?;" + void $ execute conn q (dTag, dId) -- | Handles the 'info' request of the Web UI API. infoH :: DeploymentName -> AppM [DeploymentInfo] @@ -786,8 +887,7 @@ getInfo :: DeploymentName -> AppM DeploymentInfo getInfo dName = do st <- ask let pgPool = pool st - dep <- unwrapOrValidateError - $ selectDeployment pgPool dName AllDeployments AllowPending + dep <- selectDeployment dName dId <- selectDeploymentId pgPool dName liftIO $ do depLogs <- selectDeploymentLogs pgPool dId @@ -813,14 +913,11 @@ statusH :: DeploymentName -> AppM CurrentDeploymentStatus statusH dName = do st <- ask let - pgPool = pool st log = logInfo (logger st) cmd = checkingCommand st args = [ "--namespace", coerce $ namespace st , "--name", coerce $ dName ] - void $ unwrapOrValidateError - $ selectDeployment pgPool dName AllDeployments AllowPending liftIO $ log $ "call " <> unwords (coerce cmd : args) ec <- liftIO $ runCommandWithoutPipes (unpack $ coerce cmd) (unpack <$> args) pure . CurrentDeploymentStatus $ @@ -833,9 +930,7 @@ cleanupH :: DeploymentName -> AppM CommandResponse cleanupH dName = do failIfGracefulShutdownActivated st <- ask - void $ unwrapOrValidateError - $ selectDeployment (pool st) dName ArchivedOnlyDeployments DenyPending - liftIO . runBgWorker st $ cleanupDeployment dName st + runDeploymentBgWorker Nothing dName $ liftBase $ cleanupDeployment dName st pure Success -- | Helper to cleanup deployment. @@ -905,11 +1000,12 @@ cleanArchiveH = do archRetention = unArchiveRetention . archiveRetention $ st q = "SELECT name FROM deployments \ - \WHERE archived = 't' AND archived_at + interval '?' second < now()" + \WHERE status in ? AND archived_at + interval '?' second < now()" retrieved :: [Only DeploymentName] <- liftIO $ - withResource pgPool $ \conn -> query conn q (Only archRetention) - liftIO . runBgWorker st . void $ - for retrieved $ \(Only dName) -> cleanupDeployment dName st + withResource pgPool $ \conn -> query conn q (In archivedStatuses, archRetention) + runBgWorker . void $ + for retrieved $ \(Only dName) -> + runDeploymentBgWorker Nothing dName $ liftBase $ cleanupDeployment dName st pure Success @@ -919,27 +1015,21 @@ restoreH dName = do failIfGracefulShutdownActivated t1 <- liftIO $ now st <- ask - let pgPool = pool st - dep <- unwrapOrValidateError - $ selectDeployment pgPool dName ArchivedOnlyDeployments DenyPending + dep <- selectDeployment dName failIfImageNotFound (name dep) (tag dep) failIfGracefulShutdownActivated - liftIO . runBgWorker st $ do - updateDeploymentInfo dName st - let - q = - "UPDATE deployments \ - \SET archived = 'f', archived_at = null, status = 'CreatePending' \ - \WHERE name = ?" - void $ withResource pgPool $ \conn -> execute conn q (Only dName) - sendReloadEvent st - (ec, out, err) <- createDeployment dep st - t2 <- now - let - arch = ArchivedFlag False - elTime = elapsedTime t2 t1 - createDeploymentLog pgPool dep "restore" ec arch elTime out err - sendReloadEvent st + runDeploymentBgWorker (Just CreatePending) dName $ do + dep' <- selectDeployment dName + liftBase $ updateDeploymentInfo dName st + (ec, out, err) <- liftBase $ createDeployment dep' st + t2 <- liftBase now + let elTime = elapsedTime t2 t1 + transitionToStatusS dName $ TransitionCreatePending StatusTransitionProcessOutput + { exitCode = ec + , duration = elTime + , stdout = out + , stderr = err + } handleExitCode ec pure Success @@ -958,56 +1048,37 @@ getActionInfoH aId = do _ -> throwError err400 { errBody = appError "Action not found" } --- | Helper to run command with pipes. -runCommand :: FilePath -> [String] -> IO (ExitCode, Stdout, Stderr) -runCommand cmd args = do - let proc' c a = setStdout createPipe . setStderr createPipe $ proc c a - withProcessWait (proc' cmd args) $ \p -> do - out <- hGetContents . getStdout $ p - err <- hGetContents . getStderr $ p - ec <- waitExitCode p - pure (ec, Stdout out, Stderr err) - --- | Helper to run command without pipes. -runCommandWithoutPipes :: FilePath -> [String] -> IO ExitCode -runCommandWithoutPipes cmd args = do - withProcessWait (proc cmd args) $ \p -> do - ec <- waitExitCode p - pure ec - -- | Helper to handle exit code. -handleExitCode :: ExitCode -> IO () +handleExitCode :: MonadBaseControl IO m => ExitCode -> m () handleExitCode ExitSuccess = return () -handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c +handleExitCode (ExitFailure c) = liftBase . throwIO $ DeploymentFailed c -- | Helper to log a deployment action. createDeploymentLog - :: PgPool + :: Connection -> Deployment -> Action -> ExitCode - -> ArchivedFlag -> Duration -> Stdout -> Stderr -> IO () -createDeploymentLog pgPool dep act ec arch dur out err = do +createDeploymentLog conn dep act ec dur out err = do let (Deployment dName dTag appOvs depOvs) = dep exitCode' = case ec of ExitSuccess -> 0 ExitFailure errCode -> errCode - arch' = unArchivedFlag arch dur' = unDuration dur out' = unStdout out err' = unStderr err qInsertLog = "INSERT INTO deployment_logs \ - \(deployment_id, action, tag, exit_code, archived, \ + \(deployment_id, action, tag, exit_code, \ \duration, stdout, stderr) \ \(\ - \SELECT id, ?, ?, ?, ?, ?, ?, ? \ + \SELECT id, ?, ?, ?, ?, ?, ? \ \FROM deployments \ \WHERE name = ? \ \) RETURNING id" @@ -1015,27 +1086,24 @@ createDeploymentLog pgPool dep act ec arch dur out err = do "INSERT INTO deployment_log_overrides \ \(key, value, deployment_log_id, scope, visibility) \ \VALUES (?, ?, ?, ?, ?)" - - void $ withResource pgPool $ \conn -> - withTransaction conn $ do - aIds :: [Only Int] <- query conn qInsertLog - (act, dTag, exitCode', arch', dur', out', err', dName) - void $ for appOvs $ \o -> do - let - [Only aId] = aIds - oKey = overrideKey . unApplicationOverride $ o - oValue = overrideValue . unApplicationOverride $ o - oScope = show ApplicationScope - oVis = show . overrideVisibility . unApplicationOverride $ o - execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis) - void $ for depOvs $ \o -> do - let - [Only aId] = aIds - oKey = overrideKey . unDeploymentOverride $ o - oValue = overrideValue . unDeploymentOverride $ o - oScope = show DeploymentScope - oVis = show . overrideVisibility . unDeploymentOverride $ o - execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis) + aIds :: [Only Int] <- query conn qInsertLog + (act, dTag, exitCode', dur', out', err', dName) + void $ for appOvs $ \o -> do + let + [Only aId] = aIds + oKey = overrideKey . unApplicationOverride $ o + oValue = overrideValue . unApplicationOverride $ o + oScope = show ApplicationScope + oVis = show . overrideVisibility . unApplicationOverride $ o + execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis) + void $ for depOvs $ \o -> do + let + [Only aId] = aIds + oKey = overrideKey . unDeploymentOverride $ o + oValue = overrideValue . unDeploymentOverride $ o + oScope = show DeploymentScope + oVis = show . overrideVisibility . unDeploymentOverride $ o + execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis) -- | Helper to get deployment metadata from the database. selectDeploymentMetadata @@ -1140,12 +1208,10 @@ runStatusUpdater state = do \extract(epoch from status_updated_at)::int \ \FROM deployments \ \WHERE checked_at < now() - interval '?' second AND status != 'Archived'" - updateStatus = - "UPDATE deployments \ - \SET status = ?, status_updated_at = now(), checked_at = now() \ - \WHERE name = ? and status = ?" updateCheckedAt = - "UPDATE deployments SET checked_at = now() WHERE name = ? and status = ?" + "UPDATE deployments SET checked_at = now() WHERE name = ? AND status = ?" + logErr :: Text -> IO () + logErr = logWarning (logger state) forever $ do rows :: [(DeploymentName, DeploymentStatus, Int)] <- liftIO $ @@ -1164,34 +1230,36 @@ runStatusUpdater state = do cmd _ = unpack . coerce $ checkingCommand state timeout = statusUpdateTimeout state ec <- runCommandWithoutPipes (cmd dStatus) args - pure (dName, newStatus ec dStatus ts timeout, ts) - void $ - for (zip checkList checkResult) $ \((dName, oldSt, _), (_, newSt, _)) -> + pure (dName, statusTransition ec dStatus ts timeout, dStatus) + updated <- + for checkResult $ \(dName, transitionM, dStatus) -> withResource pgPool $ \conn -> - if oldSt == newSt - then execute conn updateCheckedAt (dName, oldSt) - else execute conn updateStatus (newSt, dName, oldSt) - if checkList == checkResult - then pure () - else sendReloadEvent state + case transitionM of + Nothing -> execute conn updateCheckedAt (dName, dStatus) $> False + Just transition -> + ($> True) $ (flip runReaderT state . runExceptT . runExceptT) (transitionToStatus dName transition) >>= \case + Right (Right ()) -> void $ execute conn updateCheckedAt (dName, transitionStatus transition) + Left e -> logErr $ show' e + Right (Left e) -> logErr $ show' e + when (or updated) $ sendReloadEvent state threadDelay 5000000 -- | Returns the new deployment status. -newStatus +statusTransition :: ExitCode -> DeploymentStatus -> Timestamp -> Timeout - -> DeploymentStatus -newStatus ExitSuccess ArchivePending _ _ = Archived -newStatus ExitSuccess _ _ _ = Running -newStatus (ExitFailure n) Running _ _ = Failure $ failureStatusType n -newStatus (ExitFailure n) CreatePending ts timeout | ts > coerce timeout = - Failure $ failureStatusType n -newStatus (ExitFailure n) UpdatePending ts timeout | ts > coerce timeout = - Failure $ failureStatusType n -newStatus (ExitFailure _) ArchivePending _ _ = ArchivePending -newStatus (ExitFailure _) oldStatus _ _ = oldStatus + -> Maybe DeploymentStatusTransition +statusTransition ExitSuccess ArchivePending _ _ = Just TransitionArchived +statusTransition ExitSuccess Running _ _ = Nothing +statusTransition ExitSuccess _ _ _ = Just TransitionCreate +statusTransition (ExitFailure n) Running _ _ = Just . TransitionFailure $ failureStatusType n +statusTransition (ExitFailure n) CreatePending ts timeout | ts > coerce timeout = + Just . TransitionFailure $ failureStatusType n +statusTransition (ExitFailure n) UpdatePending ts timeout | ts > coerce timeout = + Just . TransitionFailure $ failureStatusType n +statusTransition (ExitFailure _) _ _ _ = Nothing failureStatusType :: Int -> FailureType failureStatusType 2 = PartialAvailability @@ -1231,14 +1299,44 @@ runShutdownHandler = takeMVar . shutdownSem -- Sends a signal to 'shutdownSem' semaphore -- if the background worker counter is 0 -- and graceful shutdown is activated. -runBgWorker :: AppState -> IO () -> IO () -runBgWorker state act = void $ forkFinally act' cleanup +runBgWorker :: (MonadBaseControl IO m, MonadReader AppState m) => m () -> m () +runBgWorker act = void $ L.forkFinally act' cleanup where - act' = - atomicModifyIORef' (bgWorkersCounter state) (\c -> (c + 1, c)) >> act + act' = do + state <- ask + liftBase (atomicModifyIORef' (bgWorkersCounter state) (\c -> (c + 1, c))) >> act cleanup _ = do - c <- atomicModifyIORef' (bgWorkersCounter state) (\c -> (c - 1, c - 1)) - gracefulShutdown <- readIORef (gracefulShutdownActivated state) - if gracefulShutdown && c == 0 - then putMVar (shutdownSem state) () - else pure () + state <- ask + liftBase $ do + c <- atomicModifyIORef' (bgWorkersCounter state) (\c -> (c - 1, c - 1)) + gracefulShutdown <- readIORef (gracefulShutdownActivated state) + if gracefulShutdown && c == 0 + then putMVar (shutdownSem state) () + else pure () + +-- | Same as 'runBgWorker' but also locks the specified deployment. +runDeploymentBgWorker + :: (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) + => Maybe DeploymentStatus -> DeploymentName -> m () -> m () +runDeploymentBgWorker newS dName m = do + st <- ask + (err :: MVar (Either ServerError ())) <- L.newEmptyMVar + runBgWorker $ withLockedDeployment + dName + (L.putMVar err $ Left err409 {errBody = "The deployment is currently being processed."}) + ( do + let + ok = do + L.putMVar err $ Right () + liftBase (sendReloadEvent st) + m + case newS of + Just newS' -> + runExceptT (assertDeploymentTransitionPossibleS dName newS') >>= \case + Left e -> L.putMVar err $ Left e + Right () -> ok + Nothing -> ok + ) + L.readMVar err >>= \case + Left e -> throwError e + Right () -> return () diff --git a/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs b/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs index 548fb44..aaa5085 100644 --- a/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs +++ b/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs @@ -6,13 +6,27 @@ This module contains control script utils. -} -module Octopod.Server.ControlScriptUtils where +module Octopod.Server.ControlScriptUtils + ( infoCommandArgs + , notificationCommandArgs + , runCommand + , runCommandWithoutPipes + , runCommandArgs + , runCommandArgs' + ) where +import Control.Monad.Base +import Control.Monad.Reader +import qualified Data.ByteString.Lazy as TL import Data.Coerce -import Data.Text - - +import Data.Generics.Product.Typed +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Octopod.Server.Logger +import System.Exit +import System.Log.FastLogger +import System.Process.Typed import Types @@ -24,8 +38,69 @@ infoCommandArgs -> DeploymentName -> ControlScriptArgs infoCommandArgs pName domain ns dName = - ControlScriptArgs $ - [ "--project-name", unpack . coerce $ pName - , "--base-domain", unpack . coerce $ domain - , "--namespace", unpack . coerce $ ns - , "--name", unpack . coerce $ dName ] + ControlScriptArgs + [ "--project-name", T.unpack . coerce $ pName + , "--base-domain", T.unpack . coerce $ domain + , "--namespace", T.unpack . coerce $ ns + , "--name", T.unpack . coerce $ dName ] + +notificationCommandArgs + :: + ( MonadReader r m + , HasType Namespace r + , HasType ProjectName r + , HasType Domain r + ) + => DeploymentName + -> DeploymentStatus + -- ^ Previous status + -> DeploymentStatus + -- ^ New status + -> m ControlScriptArgs +notificationCommandArgs dName old new = do + (Namespace namespace) <- asks getTyped + (ProjectName projectName) <- asks getTyped + (Domain domain) <- asks getTyped + return $ ControlScriptArgs + [ "--project-name", T.unpack projectName + , "--base-domain", T.unpack domain + , "--namespace", T.unpack namespace + , "--name", T.unpack . coerce $ dName + , "--tag", T.unpack . coerce $ dName + , "--old-status", show old + , "--new-status", show new + ] + +runCommandArgs + :: (MonadReader r m, MonadBase IO m, HasType TimedFastLogger r) + => (r -> Command) -> ControlScriptArgs -> m (ExitCode, Stdout, Stderr) +runCommandArgs f args = do + cmd <- asks f + runCommandArgs' cmd args + +runCommandArgs' + :: (MonadBase IO m, HasType TimedFastLogger r, MonadReader r m) + => Command -> ControlScriptArgs -> m (ExitCode, Stdout, Stderr) +runCommandArgs' (Command cmd) (ControlScriptArgs args) = do + logger <- asks (getTyped @TimedFastLogger) + let logText = T.unwords (cmd : fmap T.pack args) + liftBase $ logInfo logger $ "calling: " <> logText + res@(ec, _, _) <- runCommand (T.unpack cmd) args + liftBase $ logInfo logger + $ "calling `" <> logText <> "` exited with: " <> show' ec + return res + +-- | Helper to run command with pipes. +runCommand :: MonadBase IO m => FilePath -> [String] -> m (ExitCode, Stdout, Stderr) +runCommand cmd args = do + (ec, out, err) <- liftBase . readProcess $ proc cmd args + 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 diff --git a/octopod-backend/src/Octopod/Server/Logger.hs b/octopod-backend/src/Octopod/Server/Logger.hs index 8ce66d1..9565c0c 100644 --- a/octopod-backend/src/Octopod/Server/Logger.hs +++ b/octopod-backend/src/Octopod/Server/Logger.hs @@ -8,6 +8,7 @@ module Octopod.Server.Logger where import Data.ByteString import Data.Text +import qualified Data.Text as T import System.Log.FastLogger -- | Creates new logger. @@ -32,3 +33,6 @@ logWithSeverity l severity msg = l $ \ft -> metadata ft <> message metadata :: ByteString -> LogStr metadata ft = foldMap toLogStr ["[", ft, " ", severity, "] "] message = toLogStr msg <> toLogStr ("\n" :: ByteString) + +show' :: Show a => a -> Text +show' = T.pack . show diff --git a/octopod-common/src/Common/Types.hs b/octopod-common/src/Common/Types.hs index c390a66..6944d0d 100644 --- a/octopod-common/src/Common/Types.hs +++ b/octopod-common/src/Common/Types.hs @@ -15,6 +15,7 @@ import Data.String import Data.Text as T import Data.Traversable import Deriving.Aeson.Stock +import GHC.Records import Web.HttpApiData -- | Deployment override. @@ -101,6 +102,19 @@ data FailureType deriving (Generic, Read, Show, Eq) deriving (FromJSON, ToJSON) via Snake FailureType +data PreciseDeploymentStatus + = DeploymentPending { recordedStatus :: DeploymentStatus } + -- ^ The deployment is currently being processed by the server + | DeploymentNotPending { recordedStatus :: DeploymentStatus } + deriving (Generic, Read, Show, Eq) + deriving (FromJSON, ToJSON) via Snake PreciseDeploymentStatus + +archivedStatuses :: [DeploymentStatus] +archivedStatuses = [ArchivePending, Archived] + +isArchivedStatus :: DeploymentStatus -> Bool +isArchivedStatus = (`elem` archivedStatuses) + data Deployment = Deployment { name :: DeploymentName , tag :: DeploymentTag @@ -140,8 +154,7 @@ data DeploymentInfo = DeploymentInfo data DeploymentFullInfo = DeploymentFullInfo { deployment :: Deployment - , status :: DeploymentStatus - , archived :: Bool + , status :: PreciseDeploymentStatus , metadata :: [DeploymentMetadata] , createdAt :: Int , updatedAt :: Int @@ -149,6 +162,9 @@ data DeploymentFullInfo = DeploymentFullInfo deriving (Generic, Show, Eq) deriving (FromJSON, ToJSON) via Snake DeploymentFullInfo +isDeploymentArchived :: DeploymentFullInfo -> Bool +isDeploymentArchived = isArchivedStatus . recordedStatus . getField @"status" + data DeploymentUpdate = DeploymentUpdate { newTag :: DeploymentTag , newAppOverrides :: ApplicationOverrides diff --git a/octopod-frontend/src/Frontend/API.hs b/octopod-frontend/src/Frontend/API.hs index 0a08f77..51d03f3 100644 --- a/octopod-frontend/src/Frontend/API.hs +++ b/octopod-frontend/src/Frontend/API.hs @@ -21,7 +21,7 @@ import GHC.TypeLits import Reflex.Dom as R import Servant.API as S import Servant.Reflex as SR -import Servant.Reflex.Extra () +import Servant.Reflex.Extra import Common.Types import Frontend.GHCJS @@ -140,5 +140,5 @@ processResp processResp respEv = let respOkEv = fmapMaybe reqSuccess respEv - errEv = fmapMaybe reqFailure respEv + errEv = fmapMaybe reqErrorBody respEv in (respOkEv, () <$ errEv) diff --git a/octopod-frontend/src/Frontend/Utils.hs b/octopod-frontend/src/Frontend/Utils.hs index aa01824..b64d127 100644 --- a/octopod-frontend/src/Frontend/Utils.hs +++ b/octopod-frontend/src/Frontend/Utils.hs @@ -351,18 +351,19 @@ formatPosixToDateTime = pack . intToUTCTime -- | Widget displaying the current deployment status. -statusWidget :: MonadWidget t m => Dynamic t DeploymentStatus -> m () +statusWidget :: MonadWidget t m => Dynamic t PreciseDeploymentStatus -> m () statusWidget stDyn = do stDyn' <- holdUniqDyn stDyn let - pendingWidget = divClass "loading loading--status-alike" + loadingWidget = divClass "loading loading--status-alike" dyn_ $ stDyn' <&> \case - Running -> divClass "status status--success" $ text "Running" - Failure _ -> divClass "status status--failure" $ text "Failure" - CreatePending -> pendingWidget $ text "Creating..." - UpdatePending -> pendingWidget $ text "Updating..." - ArchivePending -> pendingWidget $ text "Archiving..." - Archived -> divClass "status status--archived" $ text "Archived" + DeploymentPending _ -> divClass "status status--pending" $ text "Pending..." + DeploymentNotPending Running -> divClass "status status--success" $ text "Running" + DeploymentNotPending (Failure _) -> divClass "status status--failure" $ text "Failure" + DeploymentNotPending CreatePending -> loadingWidget $ text "Creating..." + DeploymentNotPending UpdatePending -> loadingWidget $ text "Updating..." + DeploymentNotPending ArchivePending -> loadingWidget $ text "Archiving..." + DeploymentNotPending Archived -> divClass "status status--archived" $ text "Archived" -- | Text input field with label. octopodTextInput diff --git a/octopod-frontend/src/Main.hs b/octopod-frontend/src/Main.hs index 6f0a928..a6a568d 100644 --- a/octopod-frontend/src/Main.hs +++ b/octopod-frontend/src/Main.hs @@ -13,9 +13,9 @@ import Reflex.Dom import Servant.Reflex import Common.Types as CT -import qualified Data.Semigroup as S import Control.Monad.Reader import Data.Maybe +import qualified Data.Semigroup as S import Frontend.API import Frontend.GHCJS import Frontend.Route diff --git a/octopod-frontend/src/Page/Deployment.hs b/octopod-frontend/src/Page/Deployment.hs index 4a7d648..91dd562 100644 --- a/octopod-frontend/src/Page/Deployment.hs +++ b/octopod-frontend/src/Page/Deployment.hs @@ -28,6 +28,7 @@ import Frontend.Utils import Page.ClassicPopup import Page.Elements.Links import Page.Popup.EditDeployment +import Servant.Reflex.Extra -- | The root widget of a deployment page. It requests the deployment data. -- If the request fails it shows an error, @@ -100,9 +101,9 @@ deploymentHead dfiDyn sentEv = divClass "page__head" $ do let dname = dfiDyn <^.> dfiName . coerced elClass "h1" "page__heading title" $ dynText dname - (editEv, archEv) <- hold2 . dyn $ dfiDyn <&> \dfi -> case dfi ^. field @"archived" of - True -> mdo - let btnState = not $ isPending $ dfi ^. field @"status" + (editEv, archEv) <- hold2 . dyn $ dfiDyn <&> \dfi -> if isDeploymentArchived dfi + then mdo + let btnState = not $ isPending . recordedStatus $ dfi ^. field @"status" btnEnabledDyn <- holdDyn btnState $ leftmost [ False <$ btnEv, sentEv ] btnEv <- aButtonClassEnabled "page__action button button--secondary button--restore \ @@ -111,8 +112,8 @@ deploymentHead dfiDyn sentEv = btnEnabledDyn void $ restoreEndpoint (Right . coerce <$> dname) btnEv pure (never, never) - False -> mdo - let btnState = not $ isPending $ dfi ^. field @"status" + else mdo + let btnState = not $ isPending . recordedStatus $ dfi ^. field @"status" btnEnabledDyn <- holdDyn btnState $ not <$> sentEv editEv <- aButtonClassEnabled "page__action button button--edit popup-handler" @@ -235,7 +236,7 @@ actionsTable updEv nameDyn = do respEv <- infoEndpoint (Right <$> nameDyn) pb let okEv = join . fmap logs <$> fmapMaybe reqSuccess respEv - errEv = fmapMaybe reqFailure respEv + errEv = fmapMaybe reqErrorBody respEv el "table" $ do actionsTableHead widgetHold_ actionsTableLoading $ leftmost diff --git a/octopod-frontend/src/Page/Deployments.hs b/octopod-frontend/src/Page/Deployments.hs index 3ef6517..204c898 100644 --- a/octopod-frontend/src/Page/Deployments.hs +++ b/octopod-frontend/src/Page/Deployments.hs @@ -42,6 +42,7 @@ import Page.Elements.Links import Page.Popup.EditDeployment import Page.Popup.NewDeployment import Reflex.MultiEventWriter.Class +import Servant.Reflex.Extra -- | The root widget of the deployments list page. @@ -174,10 +175,10 @@ deploymentsListWidget updAllEv termDyn ds = dataWidgetWrapper $ mdo updRespEv <- listEndpoint $ leftmost [updAllEv, () <$ retryEv] let okUpdEv = fmapMaybe reqSuccess updRespEv - errUpdEv = fmapMaybe reqFailure updRespEv + errUpdEv = fmapMaybe reqErrorBody updRespEv dsDyn <- holdDyn ds okUpdEv let - isArchived = view (field @"deployment" . field @"archived") + isArchived = isDeploymentArchived . view #deployment filteredDyn = ffor2 termDyn dsDyn $ \term ds' -> mapMaybe (searchDeployments . T.filter (not . isSpace) $ term) ds' (archivedDsDyn, activeDsDyn) = splitDynPure $ L.partition isArchived @@ -295,7 +296,7 @@ activeDeploymentWidget clickedEv dDyn' = do text $ formatPosixToDate updatedAt el "td" $ do let - enabled = not $ isPending status + enabled = not . isPending . recordedStatus $ status elId = "deployment_row_" <> unDeploymentName dName btn = elAttr "button" ( "class" =: "drop__handler" diff --git a/octopod-frontend/src/Page/Popup/EditDeployment.hs b/octopod-frontend/src/Page/Popup/EditDeployment.hs index 6ba0acc..ea2c453 100644 --- a/octopod-frontend/src/Page/Popup/EditDeployment.hs +++ b/octopod-frontend/src/Page/Popup/EditDeployment.hs @@ -27,6 +27,7 @@ import Data.Text (Text) import Frontend.API import Frontend.Utils import Servant.Reflex +import Servant.Reflex.Extra -- | The root function for \"edit deployment\" sidebar. editDeploymentPopup @@ -84,7 +85,7 @@ editDeploymentPopupBody dfi errEv = divClass "popup__content" $ divClass "deployment" $ mdo let commandResponseEv = fmapMaybe commandResponse errEv - appErrEv = R.difference (fmapMaybe reqFailure errEv) commandResponseEv + appErrEv = R.difference (fmapMaybe reqErrorBody errEv) commandResponseEv dfiTag = dfi ^. field @"deployment" . field @"tag" . coerced . to Just dfiAppVars = dfi ^. field @"deployment" . field @"appOverrides" . coerced dfiDeploymentVars = diff --git a/octopod-frontend/src/Page/Popup/NewDeployment.hs b/octopod-frontend/src/Page/Popup/NewDeployment.hs index 4e13b5b..c9533c5 100644 --- a/octopod-frontend/src/Page/Popup/NewDeployment.hs +++ b/octopod-frontend/src/Page/Popup/NewDeployment.hs @@ -24,6 +24,7 @@ import Common.Validation (isNameValid) import Frontend.API import Frontend.Utils import Servant.Reflex +import Servant.Reflex.Extra -- | The root function for \"new deployment\" sidebar. @@ -74,7 +75,7 @@ newDeploymentPopupBody errEv = divClass "popup__content" $ divClass "deployment" $ mdo let commandResponseEv = fmapMaybe commandResponse errEv - appErrEv = R.difference (fmapMaybe reqFailure errEv) commandResponseEv + appErrEv = R.difference (fmapMaybe reqErrorBody errEv) commandResponseEv nameErrEv = getNameError commandResponseEv nameDyn tagErrEv = getTagError commandResponseEv tagDyn errorHeader appErrEv diff --git a/octopod-frontend/src/Servant/Reflex/Extra.hs b/octopod-frontend/src/Servant/Reflex/Extra.hs index 0af15c1..5bf57cd 100644 --- a/octopod-frontend/src/Servant/Reflex/Extra.hs +++ b/octopod-frontend/src/Servant/Reflex/Extra.hs @@ -1,13 +1,16 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Servant.Reflex.Extra () where +module Servant.Reflex.Extra + ( reqErrorBody + ) where +import Data.Functor.Identity +import Data.Proxy +import Data.Text (Text) import qualified Data.Text.Encoding as E -import Servant.Reflex -import Servant.API -import Reflex.Dom -import Data.Proxy -import Data.Functor.Identity +import Reflex.Dom +import Servant.API +import Servant.Reflex instance (SupportsServantReflex t m) => HasClient t m (NoContentVerb 'GET) tag where @@ -15,3 +18,14 @@ instance (SupportsServantReflex t m) clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap' trigs = wrap' =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy 'GET) + +reqErrorBody :: ReqResult tag a -> Maybe Text +reqErrorBody (ResponseFailure _ _ XhrResponse {_xhrResponse_responseText = Just b}) + = Just b +reqErrorBody (ResponseFailure _ _ XhrResponse {_xhrResponse_response = Just (XhrResponseBody_Default t)}) = + Just t +reqErrorBody (ResponseFailure _ _ XhrResponse {_xhrResponse_response = Just (XhrResponseBody_Text t)}) = + Just t +reqErrorBody (ResponseFailure _ _ XhrResponse {_xhrResponse_response = Just (XhrResponseBody_ArrayBuffer t)}) = + Just . E.decodeUtf8 $ t +reqErrorBody x = reqFailure x