@@ -3,27 +3,28 @@ module Octopod.Server (runOctopodServer) where
33
44import Chronos (Time, getTime, now)
55import Control.Applicative
6−import Control.Concurrent (forkFinally, threadDelay)
6+import Control.Concurrent (threadDelay)
77import Control.Concurrent.Async (race_)
8+import qualified Control.Concurrent.Lifted as L
89import Control.Concurrent.MVar
910import Control.Concurrent.STM
1011import Control.Exception (Exception, throwIO, try)
12+import Control.Lens
1113import Control.Monad
12−import Control.Monad.IO.Class
13−import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
14+import Control.Monad.Except
15+import Control.Monad.Reader
1416import Data.Aeson (Value(..), encode, toJSON)
1517import Data.ByteString (ByteString)
1618import qualified Data.ByteString.Lazy as BSL
1719import Data.Coerce
1820import Data.Conduit (ConduitT, yield)
1921import Data.Foldable (foldrM)
20−import Data.Functor ((<&>))
22+import Data.Functor
2123import Data.Int (Int64)
2224import Data.IORef
2325import Data.Maybe
2426import Data.Pool
2527import Data.Text (lines, pack, unpack, unwords)
26−import Data.Text.IO (hGetContents)
2728import Data.Traversable
2829import Database.PostgreSQL.Simple
2930import Database.PostgreSQL.Simple.Instances ()
@@ -37,11 +38,15 @@ import System.Environment (lookupEnv)
3738import System.Exit
3839import System.Log.FastLogger
3940import System.Posix.Signals (sigTERM)
40−import System.Process.Typed
4141
4242
43−import Common.Utils
4443import Common.Validation (isNameValid)
44+import Control.Monad.Base
45+import Control.Monad.Trans.Control
46+import Control.Octopod.DeploymentLock
47+import qualified Data.ByteString.Lazy.Char8 as BSLC
48+import Data.Generics.Labels ()
49+import qualified Data.Text.Encoding as T
4550import Database.PostgreSQL.Simple.Transaction
4651import Octopod.API
4752import Octopod.PowerAPI
@@ -52,6 +57,7 @@ import Octopod.Server.Posix
5257import Orphans ()
5358import TLS (createTLSOpts)
5459import Types
60+import Control.Lens.Extras
5561
5662type PgPool = Pool Connection
5763type AppM = ReaderT AppState Handler
@@ -95,7 +101,11 @@ data AppState = AppState
95101 , tagCheckingCommand :: Command
96102 -- ^ tag checking command path
97103 , infoCommand :: Command
98− }
104+ , notificationCommand :: Maybe Command
105+ , lockedDeployments :: LockedDeployments
106+ -- ^ Deployments currently being processed which has not yet been
107+ -- recorded in the database.
108+ } deriving Generic
99109
100110-- | Deployment exception definition.
101111data DeploymentException
@@ -118,18 +128,6 @@ data FullInfoListType
118128 | FullInfoOnlyForOne DeploymentName
119129 deriving (Show)
120130
121−-- | Deployment search errors definition.
122−data DeploymentNotFound
123− = DeploymentNotFound
124− | ArchivedDeploymentNotFound
125− | ActiveDeploymentNotFound
126− | DeploymentHasPendingStatus DeploymentStatus
127−
128−-- | Definition of a filter by pending statuses.
129−data FilterByPending
130− = AllowPending
131− | DenyPending
132−
133131runOctopodServer :: IO ()
134132runOctopodServer = do
135133 logger' <- newLogger
@@ -158,10 +156,15 @@ runOctopodServer = do
158156 archiveCheckingCmd <- coerce . pack <$> getEnvOrDie "ARCHIVE_CHECKING_COMMAND"
159157 tagCheckingCmd <- coerce . pack <$> getEnvOrDie "TAG_CHECKING_COMMAND"
160158 infoCmd <- coerce . pack <$> getEnvOrDie "INFO_COMMAND"
159+ notificationCmd <- (fmap . fmap) (Command . pack)
160+ $ lookupEnv "NOTIFICATION_COMMAND" <&> \case
161+ Just "" -> Nothing
162+ x -> x
161163 pgPool <- initConnectionPool
162164 (unDBConnectionString $ octopodDB opts)
163165 (unDBPoolSize $ octopodDBPoolSize opts)
164166 channel <- liftIO . atomically $ newBroadcastTChan
167+ lockedDs <- initLockedDeployments
165168 let
166169 appSt =
167170 AppState
@@ -184,6 +187,8 @@ runOctopodServer = do
184187 archiveCheckingCmd
185188 tagCheckingCmd
186189 infoCmd
190+ notificationCmd
191+ lockedDs
187192 app' = app appSt
188193 powerApp' = powerApp appSt
189194 wsApp' = wsApp channel
@@ -263,7 +268,9 @@ powerListH :: AppM [DeploymentFullInfo]
263268powerListH = getFullInfo FullInfoForAll
264269
265270-- | Handles the 'full_info' request of the Web UI API.
266−fullInfoH :: DeploymentName -> AppM DeploymentFullInfo
271+fullInfoH
272+ :: (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m)
273+ => DeploymentName -> m DeploymentFullInfo
267274fullInfoH dName = do
268275 fullInfoList <- hidePrivateOverridesInFullInfos <$>
269276 getFullInfo (FullInfoOnlyForOne dName)
@@ -284,7 +291,7 @@ powerFullInfoH dName = do
284291-- | Hides private overrides in 'full_info' response.
285292hidePrivateOverridesInFullInfos :: [DeploymentFullInfo] -> [DeploymentFullInfo]
286293hidePrivateOverridesInFullInfos dFullInfos = do
287− dFullInfos <&> \(DeploymentFullInfo dep s a ct ut u) ->
294+ dFullInfos <&> \(DeploymentFullInfo dep s ct ut u) ->
288295 let
289296 hidePrivate (Deployment n t appOvs depOvs) =
290297 Deployment n t (hideP appOvs) (hideP depOvs)
@@ -295,32 +302,47 @@ hidePrivateOverridesInFullInfos dFullInfos = do
295302 Private -> "*"
296303 Public -> v
297304 in coerce $ Override k v' vis
298− in DeploymentFullInfo (hidePrivate dep) s a ct ut u
305+ in DeploymentFullInfo (hidePrivate dep) s ct ut u
306+
307+getFullInfo
308+ :: (MonadReader AppState m, MonadBaseControl IO m)
309+ => FullInfoListType
310+ -> m [DeploymentFullInfo]
311+getFullInfo lType = do
312+ p <- asks pool
313+ liftBaseOp (withResource p) $ \conn -> getFullInfo' conn lType
299314
300315-- | Helper to get full_info from the database.
301−getFullInfo :: FullInfoListType -> AppM [DeploymentFullInfo]
302−getFullInfo listType = do
303− AppState {pool = p, logger = l} <- ask
304− deployments <- liftIO $ withResource p $ \conn -> do
316+getFullInfo'
317+ :: (MonadReader AppState m, MonadBase IO m)
318+ => Connection
319+ -> FullInfoListType
320+ -> m [DeploymentFullInfo]
321+getFullInfo' conn listType = do
322+ AppState {logger = l} <- ask
323+ deployments <- do
305324 rows <- case listType of
306− FullInfoForAll -> query_ conn qAll
307− FullInfoOnlyForOne (dName) -> query conn qOne (Only dName)
308− for rows $ \(n, t, a, ct, ut, st) -> do
309− (appOvs, depOvs) <- selectOverrides conn n
310− dMeta <- selectDeploymentMetadata conn n
325+ FullInfoForAll -> liftBase $ query_ conn qAll
326+ FullInfoOnlyForOne dName -> liftBase $ query conn qOne (Only dName)
327+ for rows $ \(n, t, ct, ut, st) -> do
328+ (appOvs, depOvs) <- liftBase $ selectOverrides conn n
329+ dMeta <- liftBase $ selectDeploymentMetadata conn n
330+ st' <- isDeploymentLocked n <&> \case
331+ True -> DeploymentPending st
332+ False -> DeploymentNotPending st
311333 pure $ do
312− let dep = (Deployment n t appOvs depOvs)
313− DeploymentFullInfo dep st a dMeta ct ut
314− liftIO . logInfo l $ "get deployments: " <> (pack . show $ deployments)
334+ let dep = Deployment n t appOvs depOvs
335+ DeploymentFullInfo dep st' dMeta ct ut
336+ liftBase . logInfo l $ "get deployments: " <> (pack . show $ deployments)
315337 return deployments
316338 where
317339 qAll =
318− "SELECT name, tag, archived, extract(epoch from created_at)::int, \
319− \extract(epoch from updated_at)::int, status::text \
340+ "SELECT name, tag, extract(epoch from created_at)::int, \
341+ \extract(epoch from updated_at)::int, status \
320342 \FROM deployments ORDER BY name"
321343 qOne =
322− "SELECT name, tag, archived, extract(epoch from created_at)::int, \
323− \extract(epoch from updated_at)::int, status::text \
344+ "SELECT name, tag, extract(epoch from created_at)::int, \
345+ \extract(epoch from updated_at)::int, status \
324346 \FROM deployments \
325347 \WHERE name = ?"
326348
@@ -337,42 +359,43 @@ createH dep = do
337359 { errBody = validationError [badNameText] [] }
338360 t1 <- liftIO $ now
339361 st <- ask
340− let
341− q =
342− "INSERT INTO deployments (name, tag, status) \
343− \VALUES (?, ?, ?) RETURNING id"
344− pgPool = pool st
345− createDep :: PgPool -> Deployment -> IO [Only Int]
346− createDep p Deployment { name = n, tag = t } =
347− withResource p $ \conn ->
348− query conn q (n, t, CreatePending)
349362 failIfImageNotFound (name dep) (tag dep)
350363 failIfGracefulShutdownActivated
351− res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep
352− dId <- case res of
353− Right ((Only depId) : _) ->
354− pure . DeploymentId $ depId
355− Right [] ->
356− throwError err404
357− { errBody = validationError ["Name not found"] [] }
358− Left (SqlError code _ _ _ _) | code == unique_violation ->
359− throwError err400
360− { errBody = validationError ["Deployment already exists"] [] }
361− Left (SqlError _ _ _ _ _) ->
362− throwError err409 { errBody = appError "Some database error" }
363− liftIO . withResource pgPool $ \conn ->
364− upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep)
365− liftIO . runBgWorker st $ do
366− sendReloadEvent st
367− updateDeploymentInfo (name dep) st
368− (ec, out, err) <- createDeployment dep st
369− t2 <- now
364+ runDeploymentBgWorker Nothing (name dep) $ do
365+ let
366+ q =
367+ "INSERT INTO deployments (name, tag, status) \
368+ \VALUES (?, ?, ?) RETURNING id"
369+ pgPool = pool st
370+ createDep :: PgPool -> Deployment -> IO [Only Int]
371+ createDep p Deployment { name = n, tag = t } =
372+ withResource p $ \conn ->
373+ query conn q (n, t, CreatePending)
374+ res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep
375+ dId <- case res of
376+ Right ((Only depId) : _) ->
377+ pure . DeploymentId $ depId
378+ Right [] ->
379+ throwError err404
380+ { errBody = validationError ["Name not found"] [] }
381+ Left (SqlError code _ _ _ _) | code == unique_violation ->
382+ throwError err400
383+ { errBody = validationError ["Deployment already exists"] [] }
384+ Left (SqlError _ _ _ _ _) ->
385+ throwError err409 { errBody = appError "Some database error" }
386+ liftIO . withResource pgPool $ \conn ->
387+ upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep)
388+ liftBase $ sendReloadEvent st
389+ liftBase $ updateDeploymentInfo (name dep) st
390+ (ec, out, err) <- liftBase $ createDeployment dep st
391+ t2 <- liftBase $ now
370392 let
371− arch = ArchivedFlag False
372393 elTime = elapsedTime t2 t1
373− createDeploymentLog pgPool dep "create" ec arch elTime out err
374− sendReloadEvent st
375− handleExitCode ec
394+ liftIO . withResource pgPool $ \conn ->
395+ -- calling it directly now is fine since there is no previous status.
396+ createDeploymentLog conn dep "create" ec elTime out err
397+ liftBase $ sendReloadEvent st
398+ liftBase $ handleExitCode ec
376399 pure Success
377400
378401-- | Updates deployment info.
@@ -455,74 +478,173 @@ selectDeploymentLogs pgPool dId = do
455478
456479-- | Helper to get a deployment.
457480selectDeployment
458− :: PgPool
459− -> DeploymentName
460− -> DeploymentListType
461− -> FilterByPending
462− -> AppM (Either DeploymentNotFound Deployment)
463−selectDeployment pgPool dName lType filterByPending = do
464− let
465− baseQuery =
466− "SELECT name, tag, status::text FROM deployments \
467− \WHERE name = ?"
468− q AllDeployments = baseQuery
469− q ArchivedOnlyDeployments = baseQuery <> " AND archived = 't'"
470− q ActiveOnlyDeployments = baseQuery <> " AND archived = 'f'"
471− allowPending =
472− case filterByPending of
473− AllowPending -> True
474− DenyPending -> False
475− result <- liftIO . withResource pgPool $ \conn -> do
476− retrieved <- query conn (q lType) (Only dName)
477− for retrieved $ \(n, t, s) -> do
478− (appOvs, stOvs) <- selectOverrides conn n
479− pure $ (Deployment n t appOvs stOvs, read s)
480− pure $
481− case result of
482− [(_, st)] | isPending st && not allowPending ->
483− Left $ DeploymentHasPendingStatus st
484− [(dep, _)] ->
485− Right dep
486− _ ->
487− Left $
488− case lType of
489− AllDeployments -> DeploymentNotFound
490− ArchivedOnlyDeployments -> ArchivedDeploymentNotFound
491− ActiveOnlyDeployments -> ActiveDeploymentNotFound
492−
493−-- | Handles deployment search result.
494−unwrapOrValidateError
495− :: AppM (Either DeploymentNotFound Deployment)
481+ :: DeploymentName
496482 -> AppM Deployment
497−unwrapOrValidateError deploymentSearchResult = do
498− deploymentSearchResult' <- deploymentSearchResult
499− case deploymentSearchResult' of
500− Right dep -> pure dep
501− Left DeploymentNotFound ->
502− throwError err404
503− { errBody = validationError ["Deployment not found"] [] }
504− Left ArchivedDeploymentNotFound ->
505− throwError err404
506− { errBody = validationError ["Archived deployment not found"] [] }
507− Left ActiveDeploymentNotFound ->
508− throwError err404
509− { errBody = validationError ["Active deployment not found"] [] }
510− Left (DeploymentHasPendingStatus st) ->
511− let
512− err =
513− "You can not apply this operation \
514− \on deployment with \"" <> (pack . show $ st) <> "\" status"
515− in throwError err405 { errBody = validationError [err] [] }
483+selectDeployment dName = do
484+ pgPool <- asks pool
485+ let q = "SELECT name, tag FROM deployments WHERE name = ?"
486+ liftBaseOp (withResource pgPool) $ \conn -> do
487+ retrieved <- liftBase $ query conn q (Only dName)
488+ case retrieved of
489+ [(n, t)] -> do
490+ (appOvs, stOvs) <- liftBase $ selectOverrides conn n
491+ pure $ Deployment n t appOvs stOvs
492+ [] -> throwError err404 {errBody = "Deployment not found."}
493+ _ -> throwError err500
494+
495+data StatusTransitionProcessOutput = StatusTransitionProcessOutput
496+ { exitCode :: ExitCode
497+ , duration :: Duration
498+ , stdout :: Stdout
499+ , stderr :: Stderr
500+ } deriving (Generic, Show)
501+
502+data DeploymentStatusTransition
503+ = TransitionArchived
504+ | TransitionCreate
505+ | TransitionUpdate
506+ | TransitionRestore StatusTransitionProcessOutput
507+ | TransitionArchivePending StatusTransitionProcessOutput
508+ | TransitionUpdatePending StatusTransitionProcessOutput
509+ | TransitionCreatePending StatusTransitionProcessOutput
510+ | TransitionFailure FailureType
511+ deriving Show
512+
513+transitionStatus :: DeploymentStatusTransition -> DeploymentStatus
514+transitionStatus TransitionArchived {} = Archived
515+transitionStatus TransitionCreate {} = Running
516+transitionStatus TransitionUpdate {} = Running
517+transitionStatus TransitionRestore {} = Running
518+transitionStatus TransitionArchivePending {} = ArchivePending
519+transitionStatus TransitionUpdatePending {} = UpdatePending
520+transitionStatus TransitionCreatePending {} = CreatePending
521+transitionStatus (TransitionFailure t) = Failure t
522+
523+processOutput :: DeploymentStatusTransition -> Maybe (StatusTransitionProcessOutput, Action)
524+processOutput TransitionArchived = Nothing
525+processOutput TransitionCreate = Nothing
526+processOutput TransitionUpdate = Nothing
527+processOutput (TransitionRestore x) = Just (x, Action "restore")
528+processOutput (TransitionArchivePending x) = Just (x, Action "archive")
529+processOutput (TransitionUpdatePending x) = Just (x, Action "update")
530+processOutput (TransitionCreatePending x) = Just (x, Action "create")
531+processOutput TransitionFailure {} = Nothing
532+
533+transitionToStatusS
534+ :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m)
535+ => DeploymentName -> DeploymentStatusTransition -> m ()
536+transitionToStatusS dName tran =
537+ runExceptT (transitionToStatus dName tran) >>= transitionErrorToServerError
538+
539+transitionErrorToServerError :: MonadError ServerError m => Either StatusTransitionError a -> m a
540+transitionErrorToServerError = \case
541+ Right x -> return x
542+ Left (InvalidStatusTransition dName a b) -> throwError err409
543+ { errBody
544+ = "Unable to transition deployment "
545+ <> (BSL.fromStrict . T.encodeUtf8 . unDeploymentName) dName
546+ <> " from " <> show'' a <> " to " <> show'' b <> "."
547+ }
548+ Left (DeploymentNotFound dName) -> throwError err404
549+ { errBody
550+ = "Couldn't find deployment "
551+ <> (BSL.fromStrict . T.encodeUtf8 . unDeploymentName) dName <> "."
552+ }
553+ where
554+ show'' = BSLC.pack . show
555+
556+transitionToStatus
557+ :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m)
558+ => DeploymentName -> DeploymentStatusTransition -> ExceptT StatusTransitionError m ()
559+transitionToStatus dName s = do
560+ p <- asks pool
561+ st <- ask
562+ let log = liftBase . logInfo (logger st)
563+ (oldS, newS) <- withResource p $ \conn -> liftBaseOp_ (withTransaction conn) $ do
564+ dep <- lift (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case
565+ [x] -> return x
566+ _ -> throwError $ DeploymentNotFound dName
567+ let
568+ oldS = recordedStatus $ dep ^. #status
569+ newS = transitionStatus s
570+ assertStatusTransitionPossible dName oldS newS
571+ log $ "Transitioning deployment " <> (show' . unDeploymentName) dName <> " " <> show' s
572+ let
573+ q =
574+ "UPDATE deployments \
575+ \SET status = ?, status_updated_at = now() "
576+ <> (if newS == ArchivePending then ", archived_at = now()" else mempty)
577+ <> " WHERE name = ?"
578+ void . liftBase $ execute conn q (newS, dName)
579+ liftBase $ forM_ (processOutput s) $ \(output, act) ->
580+ createDeploymentLog
581+ conn
582+ (dep ^. #deployment)
583+ act
584+ (output ^. #exitCode)
585+ (output ^. #duration)
586+ (output ^. #stdout)
587+ (output ^. #stderr)
588+ return (oldS, newS)
589+ notificationCmd <- asks notificationCommand
590+ forM_ notificationCmd $ \nCmd ->
591+ runBgWorker . void $ runCommandArgs' nCmd =<< notificationCommandArgs dName oldS newS
592+ liftBase $ sendReloadEvent st
593+
594+assertStatusTransitionPossible
595+ :: MonadError StatusTransitionError m
596+ => DeploymentName
597+ -> DeploymentStatus
598+ -> DeploymentStatus
599+ -> m ()
600+assertStatusTransitionPossible dName old new =
601+ unless
602+ (possibleTransitions old new)
603+ (throwError $ InvalidStatusTransition dName old new)
604+
605+assertDeploymentTransitionPossible
606+ :: (MonadError StatusTransitionError m, MonadReader AppState m, MonadBaseControl IO m)
607+ => DeploymentName
608+ -> DeploymentStatus
609+ -> m ()
610+assertDeploymentTransitionPossible dName new = do
611+ p <- asks pool
612+ dep <- withResource p $ \conn -> (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case
613+ [x] -> return x
614+ _ -> throwError $ DeploymentNotFound dName
615+ assertStatusTransitionPossible dName (recordedStatus $ dep ^. #status) new
616+
617+assertDeploymentTransitionPossibleS
618+ :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m)
619+ => DeploymentName
620+ -> DeploymentStatus
621+ -> m ()
622+assertDeploymentTransitionPossibleS dName new =
623+ runExceptT (assertDeploymentTransitionPossible dName new) >>= transitionErrorToServerError
624+data StatusTransitionError
625+ = InvalidStatusTransition DeploymentName DeploymentStatus DeploymentStatus
626+ | DeploymentNotFound DeploymentName
627+ deriving Show
628+
629+possibleTransitions :: DeploymentStatus -> DeploymentStatus -> Bool
630+possibleTransitions CreatePending = anyPred [is #_Running, is #_Failure]
631+possibleTransitions Running = anyPred [is #_Failure, is #_ArchivePending, is #_UpdatePending]
632+possibleTransitions UpdatePending = anyPred [is #_Failure, is #_Running]
633+possibleTransitions (Failure _) = anyPred [is #_UpdatePending, is #_Running, is #_ArchivePending]
634+possibleTransitions ArchivePending = anyPred [is #_ArchivePending, is #_Archived]
635+possibleTransitions Archived = anyPred [is #_CreatePending]
636+
637+anyPred :: [a -> Bool] -> a -> Bool
638+anyPred preds x = any ($ x) preds
516639
517640-- | Handles the 'archive' request.
518641archiveH :: DeploymentName -> AppM CommandResponse
519642archiveH dName = do
520643 failIfGracefulShutdownActivated
521− t1 <- liftIO $ now
644+ t1 <- liftBase now
522645 st <- ask
523646 let
524− log = logInfo (logger st)
525− pgPool = pool st
647+ log = liftBase . logInfo (logger st)
526648 args =
527649 [ "--project-name", coerce $ projectName st
528650 , "--base-domain", coerce $ baseDomain st
@@ -530,33 +652,20 @@ archiveH dName = do
530652 , "--name", coerce dName
531653 ]
532654 cmd = coerce $ archiveCommand st
533− arch = ArchivedFlag True
534− dep <- unwrapOrValidateError
535− $ selectDeployment pgPool dName ActiveOnlyDeployments DenyPending
536− liftIO . runBgWorker st $ do
655+ runDeploymentBgWorker (Just ArchivePending) dName $ do
537656 log $ "call " <> unwords (cmd : args)
538657 (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
539− void $ archiveDeployment pgPool dName
540− sendReloadEvent st
541− t2 <- now
658+ t2 <- liftBase now
542659 let elTime = elapsedTime t2 t1
543− void $ createDeploymentLog pgPool dep "archive" ec arch elTime out err
544− log $ "deployment archived, name: " <> coerce dName
545− sendReloadEvent st
660+ transitionToStatusS dName $ TransitionArchivePending StatusTransitionProcessOutput
661+ { exitCode = ec
662+ , duration = elTime
663+ , stdout = out
664+ , stderr = err
665+ }
546666 handleExitCode ec
547667 pure Success
548668
549−-- | Handles the 'archive' request.
550−archiveDeployment :: PgPool -> DeploymentName -> IO Int64
551−archiveDeployment p dName = withResource p $ \conn -> do
552− let
553− q =
554− "UPDATE deployments \
555− \SET archived = 't', archived_at = now(), \
556− \status = ?, status_updated_at = now() \
557− \WHERE name = ?"
558− execute conn q (ArchivePending, dName)
559−
560669-- | Handles the 'update' request.
561670updateH :: DeploymentName -> DeploymentUpdate -> AppM CommandResponse
562671updateH dName dUpdate = do
@@ -573,21 +682,18 @@ updateH dName dUpdate = do
573682 } = dUpdate
574683 pgPool = pool st
575684 log = logInfo (logger st)
576−
577− void $ unwrapOrValidateError
578− $ selectDeployment pgPool dName ActiveOnlyDeployments DenyPending
579685 dId <- selectDeploymentId pgPool dName
580686 failIfImageNotFound dName dTag
581687 failIfGracefulShutdownActivated
582− liftIO . runBgWorker st $ do
583− (appOvs, depOvs) <- withResource pgPool $ \conn ->
688+ runDeploymentBgWorker (Just UpdatePending) dName $ do
689+ (appOvs, depOvs) <- liftBase . withResource pgPool $ \conn ->
584690 withTransaction conn $ do
585691 deleteOldOverrides conn dId oldAppOvs oldDepOvs
586692 upsertNewOverrides conn dId newAppOvs newDepOvs
587− void $ updateDeployment conn dName dTag
693+ updateTag conn dId dTag
588694 selectOverrides conn dName
589− updateDeploymentInfo dName st
590− sendReloadEvent st
695+ liftBase $ updateDeploymentInfo dName st
696+ liftBase $ sendReloadEvent st
591697 let
592698 args =
593699 [ "--project-name", coerce $ projectName st
@@ -598,18 +704,18 @@ updateH dName dUpdate = do
598704 ] ++ applicationOverridesToArgs appOvs
599705 ++ deploymentOverridesToArgs depOvs
600706 cmd = coerce $ updateCommand st
601− log $ "call " <> unwords (cmd : args)
602− (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
603− log $ "deployment updated, name: "
707+ liftBase . log $ "call " <> unwords (cmd : args)
708+ (ec, out, err) <- liftBase $ runCommand (unpack cmd) (unpack <$> args)
709+ liftBase . log $ "deployment updated, name: "
604710 <> coerce dName <> ", tag: " <> coerce dTag
605− void $ do
606− t2 <- now
607− let
608− dep = Deployment dName dTag appOvs depOvs
609− arch = ArchivedFlag False
610− elTime = elapsedTime t2 t1
611− createDeploymentLog pgPool dep "update" ec arch elTime out err
612− sendReloadEvent st
711+ t2 <- liftBase now
712+ let elTime = elapsedTime t2 t1
713+ transitionToStatusS dName $ TransitionUpdatePending StatusTransitionProcessOutput
714+ { exitCode = ec
715+ , duration = elTime
716+ , stdout = out
717+ , stderr = err
718+ }
613719 handleExitCode ec
614720 return Success
615721
@@ -731,20 +837,15 @@ upsertNewOverrides conn dId appOvs depOvs = do
731837 oVis = show . overrideVisibility . unDeploymentOverride $ o
732838 execute conn q (oKey, oValue, dId', oScope, oVis, oValue, oVis)
733839
734−-- | Helper to update a deployment.
735−updateDeployment
840+updateTag
736841 :: Connection
737− -> DeploymentName
842+ -> DeploymentId
738843 -> DeploymentTag
739− -> IO Int64
740−updateDeployment conn dName dTag = do
844+ -> IO ()
845+updateTag conn (DeploymentId dId) (DeploymentTag dTag) = do
741846 let
742− q =
743− "UPDATE deployments \
744− \SET tag = ?, updated_at = now(), \
745− \status = ?, status_updated_at = now() \
746− \WHERE name = ?"
747− execute conn q (dTag, UpdatePending, dName)
847+ q = "UPDATE deployments SET tag=? WHERE id=?;"
848+ void $ execute conn q (dTag, dId)
748849
749850-- | Handles the 'info' request of the Web UI API.
750851infoH :: DeploymentName -> AppM [DeploymentInfo]
@@ -786,8 +887,7 @@ getInfo :: DeploymentName -> AppM DeploymentInfo
786887getInfo dName = do
787888 st <- ask
788889 let pgPool = pool st
789− dep <- unwrapOrValidateError
790− $ selectDeployment pgPool dName AllDeployments AllowPending
890+ dep <- selectDeployment dName
791891 dId <- selectDeploymentId pgPool dName
792892 liftIO $ do
793893 depLogs <- selectDeploymentLogs pgPool dId
@@ -813,14 +913,11 @@ statusH :: DeploymentName -> AppM CurrentDeploymentStatus
813913statusH dName = do
814914 st <- ask
815915 let
816− pgPool = pool st
817916 log = logInfo (logger st)
818917 cmd = checkingCommand st
819918 args =
820919 [ "--namespace", coerce $ namespace st
821920 , "--name", coerce $ dName ]
822− void $ unwrapOrValidateError
823− $ selectDeployment pgPool dName AllDeployments AllowPending
824921 liftIO $ log $ "call " <> unwords (coerce cmd : args)
825922 ec <- liftIO $ runCommandWithoutPipes (unpack $ coerce cmd) (unpack <$> args)
826923 pure . CurrentDeploymentStatus $
@@ -833,9 +930,7 @@ cleanupH :: DeploymentName -> AppM CommandResponse
833930cleanupH dName = do
834931 failIfGracefulShutdownActivated
835932 st <- ask
836− void $ unwrapOrValidateError
837− $ selectDeployment (pool st) dName ArchivedOnlyDeployments DenyPending
838− liftIO . runBgWorker st $ cleanupDeployment dName st
933+ runDeploymentBgWorker Nothing dName $ liftBase $ cleanupDeployment dName st
839934 pure Success
840935
841936-- | Helper to cleanup deployment.
@@ -905,11 +1000,12 @@ cleanArchiveH = do
9051000 archRetention = unArchiveRetention . archiveRetention $ st
9061001 q =
9071002 "SELECT name FROM deployments \
908− \WHERE archived = 't' AND archived_at + interval '?' second < now()"
1003+ \WHERE status in ? AND archived_at + interval '?' second < now()"
9091004 retrieved :: [Only DeploymentName] <- liftIO $
910− withResource pgPool $ \conn -> query conn q (Only archRetention)
911− liftIO . runBgWorker st . void $
912− for retrieved $ \(Only dName) -> cleanupDeployment dName st
1005+ withResource pgPool $ \conn -> query conn q (In archivedStatuses, archRetention)
1006+ runBgWorker . void $
1007+ for retrieved $ \(Only dName) ->
1008+ runDeploymentBgWorker Nothing dName $ liftBase $ cleanupDeployment dName st
9131009
9141010 pure Success
9151011
@@ -919,27 +1015,21 @@ restoreH dName = do
9191015 failIfGracefulShutdownActivated
9201016 t1 <- liftIO $ now
9211017 st <- ask
922− let pgPool = pool st
923− dep <- unwrapOrValidateError
924− $ selectDeployment pgPool dName ArchivedOnlyDeployments DenyPending
1018+ dep <- selectDeployment dName
9251019 failIfImageNotFound (name dep) (tag dep)
9261020 failIfGracefulShutdownActivated
927− liftIO . runBgWorker st $ do
928− updateDeploymentInfo dName st
929− let
930− q =
931− "UPDATE deployments \
932− \SET archived = 'f', archived_at = null, status = 'CreatePending' \
933− \WHERE name = ?"
934− void $ withResource pgPool $ \conn -> execute conn q (Only dName)
935− sendReloadEvent st
936− (ec, out, err) <- createDeployment dep st
937− t2 <- now
938− let
939− arch = ArchivedFlag False
940− elTime = elapsedTime t2 t1
941− createDeploymentLog pgPool dep "restore" ec arch elTime out err
942− sendReloadEvent st
1021+ runDeploymentBgWorker (Just CreatePending) dName $ do
1022+ dep' <- selectDeployment dName
1023+ liftBase $ updateDeploymentInfo dName st
1024+ (ec, out, err) <- liftBase $ createDeployment dep' st
1025+ t2 <- liftBase now
1026+ let elTime = elapsedTime t2 t1
1027+ transitionToStatusS dName $ TransitionCreatePending StatusTransitionProcessOutput
1028+ { exitCode = ec
1029+ , duration = elTime
1030+ , stdout = out
1031+ , stderr = err
1032+ }
9431033 handleExitCode ec
9441034 pure Success
9451035
@@ -958,56 +1048,37 @@ getActionInfoH aId = do
9581048 _ ->
9591049 throwError err400 { errBody = appError "Action not found" }
9601050
961−-- | Helper to run command with pipes.
962−runCommand :: FilePath -> [String] -> IO (ExitCode, Stdout, Stderr)
963−runCommand cmd args = do
964− let proc' c a = setStdout createPipe . setStderr createPipe $ proc c a
965− withProcessWait (proc' cmd args) $ \p -> do
966− out <- hGetContents . getStdout $ p
967− err <- hGetContents . getStderr $ p
968− ec <- waitExitCode p
969− pure (ec, Stdout out, Stderr err)
970−
971−-- | Helper to run command without pipes.
972−runCommandWithoutPipes :: FilePath -> [String] -> IO ExitCode
973−runCommandWithoutPipes cmd args = do
974− withProcessWait (proc cmd args) $ \p -> do
975− ec <- waitExitCode p
976− pure ec
977−
9781051-- | Helper to handle exit code.
979−handleExitCode :: ExitCode -> IO ()
1052+handleExitCode :: MonadBaseControl IO m => ExitCode -> m ()
9801053handleExitCode ExitSuccess = return ()
981−handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c
1054+handleExitCode (ExitFailure c) = liftBase . throwIO $ DeploymentFailed c
9821055
9831056-- | Helper to log a deployment action.
9841057createDeploymentLog
985− :: PgPool
1058+ :: Connection
9861059 -> Deployment
9871060 -> Action
9881061 -> ExitCode
989− -> ArchivedFlag
9901062 -> Duration
9911063 -> Stdout
9921064 -> Stderr
9931065 -> IO ()
994−createDeploymentLog pgPool dep act ec arch dur out err = do
1066+createDeploymentLog conn dep act ec dur out err = do
9951067 let
9961068 (Deployment dName dTag appOvs depOvs) = dep
9971069 exitCode' =
9981070 case ec of
9991071 ExitSuccess -> 0
10001072 ExitFailure errCode -> errCode
1001− arch' = unArchivedFlag arch
10021073 dur' = unDuration dur
10031074 out' = unStdout out
10041075 err' = unStderr err
10051076 qInsertLog =
10061077 "INSERT INTO deployment_logs \
1007− \(deployment_id, action, tag, exit_code, archived, \
1078+ \(deployment_id, action, tag, exit_code, \
10081079 \duration, stdout, stderr) \
10091080 \(\
1010− \SELECT id, ?, ?, ?, ?, ?, ?, ? \
1081+ \SELECT id, ?, ?, ?, ?, ?, ? \
10111082 \FROM deployments \
10121083 \WHERE name = ? \
10131084 \) RETURNING id"
@@ -1015,27 +1086,24 @@ createDeploymentLog pgPool dep act ec arch dur out err = do
10151086 "INSERT INTO deployment_log_overrides \
10161087 \(key, value, deployment_log_id, scope, visibility) \
10171088 \VALUES (?, ?, ?, ?, ?)"
1018−
1019− void $ withResource pgPool $ \conn ->
1020− withTransaction conn $ do
1021− aIds :: [Only Int] <- query conn qInsertLog
1022− (act, dTag, exitCode', arch', dur', out', err', dName)
1023− void $ for appOvs $ \o -> do
1024− let
1025− [Only aId] = aIds
1026− oKey = overrideKey . unApplicationOverride $ o
1027− oValue = overrideValue . unApplicationOverride $ o
1028− oScope = show ApplicationScope
1029− oVis = show . overrideVisibility . unApplicationOverride $ o
1030− execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1031− void $ for depOvs $ \o -> do
1032− let
1033− [Only aId] = aIds
1034− oKey = overrideKey . unDeploymentOverride $ o
1035− oValue = overrideValue . unDeploymentOverride $ o
1036− oScope = show DeploymentScope
1037− oVis = show . overrideVisibility . unDeploymentOverride $ o
1038− execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1089+ aIds :: [Only Int] <- query conn qInsertLog
1090+ (act, dTag, exitCode', dur', out', err', dName)
1091+ void $ for appOvs $ \o -> do
1092+ let
1093+ [Only aId] = aIds
1094+ oKey = overrideKey . unApplicationOverride $ o
1095+ oValue = overrideValue . unApplicationOverride $ o
1096+ oScope = show ApplicationScope
1097+ oVis = show . overrideVisibility . unApplicationOverride $ o
1098+ execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1099+ void $ for depOvs $ \o -> do
1100+ let
1101+ [Only aId] = aIds
1102+ oKey = overrideKey . unDeploymentOverride $ o
1103+ oValue = overrideValue . unDeploymentOverride $ o
1104+ oScope = show DeploymentScope
1105+ oVis = show . overrideVisibility . unDeploymentOverride $ o
1106+ execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
10391107
10401108-- | Helper to get deployment metadata from the database.
10411109selectDeploymentMetadata
@@ -1140,12 +1208,10 @@ runStatusUpdater state = do
11401208 \extract(epoch from status_updated_at)::int \
11411209 \FROM deployments \
11421210 \WHERE checked_at < now() - interval '?' second AND status != 'Archived'"
1143− updateStatus =
1144− "UPDATE deployments \
1145− \SET status = ?, status_updated_at = now(), checked_at = now() \
1146− \WHERE name = ? and status = ?"
11471211 updateCheckedAt =
1148− "UPDATE deployments SET checked_at = now() WHERE name = ? and status = ?"
1212+ "UPDATE deployments SET checked_at = now() WHERE name = ? AND status = ?"
1213+ logErr :: Text -> IO ()
1214+ logErr = logWarning (logger state)
11491215
11501216 forever $ do
11511217 rows :: [(DeploymentName, DeploymentStatus, Int)] <- liftIO $
@@ -1164,34 +1230,36 @@ runStatusUpdater state = do
11641230 cmd _ = unpack . coerce $ checkingCommand state
11651231 timeout = statusUpdateTimeout state
11661232 ec <- runCommandWithoutPipes (cmd dStatus) args
1167− pure (dName, newStatus ec dStatus ts timeout, ts)
1168− void $
1169− for (zip checkList checkResult) $ \((dName, oldSt, _), (_, newSt, _)) ->
1233+ pure (dName, statusTransition ec dStatus ts timeout, dStatus)
1234+ updated <-
1235+ for checkResult $ \(dName, transitionM, dStatus) ->
11701236 withResource pgPool $ \conn ->
1171− if oldSt == newSt
1172− then execute conn updateCheckedAt (dName, oldSt)
1173− else execute conn updateStatus (newSt, dName, oldSt)
1174− if checkList == checkResult
1175− then pure ()
1176− else sendReloadEvent state
1237+ case transitionM of
1238+ Nothing -> execute conn updateCheckedAt (dName, dStatus) $> False
1239+ Just transition ->
1240+ ($> True) $ (flip runReaderT state . runExceptT . runExceptT) (transitionToStatus dName transition) >>= \case
1241+ Right (Right ()) -> void $ execute conn updateCheckedAt (dName, transitionStatus transition)
1242+ Left e -> logErr $ show' e
1243+ Right (Left e) -> logErr $ show' e
1244+ when (or updated) $ sendReloadEvent state
11771245 threadDelay 5000000
11781246
11791247-- | Returns the new deployment status.
1180−newStatus
1248+statusTransition
11811249 :: ExitCode
11821250 -> DeploymentStatus
11831251 -> Timestamp
11841252 -> Timeout
1185− -> DeploymentStatus
1186−newStatus ExitSuccess ArchivePending _ _ = Archived
1187−newStatus ExitSuccess _ _ _ = Running
1188−newStatus (ExitFailure n) Running _ _ = Failure $ failureStatusType n
1189−newStatus (ExitFailure n) CreatePending ts timeout | ts > coerce timeout =
1190− Failure $ failureStatusType n
1191−newStatus (ExitFailure n) UpdatePending ts timeout | ts > coerce timeout =
1192− Failure $ failureStatusType n
1193−newStatus (ExitFailure _) ArchivePending _ _ = ArchivePending
1194−newStatus (ExitFailure _) oldStatus _ _ = oldStatus
1253+ -> Maybe DeploymentStatusTransition
1254+statusTransition ExitSuccess ArchivePending _ _ = Just TransitionArchived
1255+statusTransition ExitSuccess Running _ _ = Nothing
1256+statusTransition ExitSuccess _ _ _ = Just TransitionCreate
1257+statusTransition (ExitFailure n) Running _ _ = Just . TransitionFailure $ failureStatusType n
1258+statusTransition (ExitFailure n) CreatePending ts timeout | ts > coerce timeout =
1259+ Just . TransitionFailure $ failureStatusType n
1260+statusTransition (ExitFailure n) UpdatePending ts timeout | ts > coerce timeout =
1261+ Just . TransitionFailure $ failureStatusType n
1262+statusTransition (ExitFailure _) _ _ _ = Nothing
11951263
11961264failureStatusType :: Int -> FailureType
11971265failureStatusType 2 = PartialAvailability
@@ -1231,14 +1299,44 @@ runShutdownHandler = takeMVar . shutdownSem
12311299-- Sends a signal to 'shutdownSem' semaphore
12321300-- if the background worker counter is 0
12331301-- and graceful shutdown is activated.
1234−runBgWorker :: AppState -> IO () -> IO ()
1235−runBgWorker state act = void $ forkFinally act' cleanup
1302+runBgWorker :: (MonadBaseControl IO m, MonadReader AppState m) => m () -> m ()
1303+runBgWorker act = void $ L.forkFinally act' cleanup
12361304 where
1237− act' =
1238− atomicModifyIORef' (bgWorkersCounter state) (\c -> (c + 1, c)) >> act
1305+ act' = do
1306+ state <- ask
1307+ liftBase (atomicModifyIORef' (bgWorkersCounter state) (\c -> (c + 1, c))) >> act
12391308 cleanup _ = do
1240− c <- atomicModifyIORef' (bgWorkersCounter state) (\c -> (c - 1, c - 1))
1241− gracefulShutdown <- readIORef (gracefulShutdownActivated state)
1242− if gracefulShutdown && c == 0
1243− then putMVar (shutdownSem state) ()
1244− else pure ()
1309+ state <- ask
1310+ liftBase $ do
1311+ c <- atomicModifyIORef' (bgWorkersCounter state) (\c -> (c - 1, c - 1))
1312+ gracefulShutdown <- readIORef (gracefulShutdownActivated state)
1313+ if gracefulShutdown && c == 0
1314+ then putMVar (shutdownSem state) ()
1315+ else pure ()
1316+
1317+-- | Same as 'runBgWorker' but also locks the specified deployment.
1318+runDeploymentBgWorker
1319+ :: (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m)
1320+ => Maybe DeploymentStatus -> DeploymentName -> m () -> m ()
1321+runDeploymentBgWorker newS dName m = do
1322+ st <- ask
1323+ (err :: MVar (Either ServerError ())) <- L.newEmptyMVar
1324+ runBgWorker $ withLockedDeployment
1325+ dName
1326+ (L.putMVar err $ Left err409 {errBody = "The deployment is currently being processed."})
1327+ ( do
1328+ let
1329+ ok = do
1330+ L.putMVar err $ Right ()
1331+ liftBase (sendReloadEvent st)
1332+ m
1333+ case newS of
1334+ Just newS' ->
1335+ runExceptT (assertDeploymentTransitionPossibleS dName newS') >>= \case
1336+ Left e -> L.putMVar err $ Left e
1337+ Right () -> ok
1338+ Nothing -> ok
1339+ )
1340+ L.readMVar err >>= \case
1341+ Left e -> throwError e
1342+ Right () -> return ()