@@ -0,0 +1,1236 @@
1+module Octopod.Server (runOctopodServer) where
2+
3+
4+import Chronos (Time, getTime, now)
5+import Control.Applicative
6+import Control.Concurrent (forkFinally, threadDelay)
7+import Control.Concurrent.Async (race_)
8+import Control.Concurrent.MVar
9+import Control.Concurrent.STM
10+import Control.Exception (Exception, throwIO, try)
11+import Control.Monad
12+import Control.Monad.IO.Class
13+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
14+import Data.Aeson (Value(..), encode, toJSON)
15+import Data.ByteString (ByteString)
16+import qualified Data.ByteString.Lazy as BSL
17+import Data.Coerce
18+import Data.Conduit (ConduitT, yield)
19+import Data.Foldable (foldrM)
20+import Data.Functor ((<&>))
21+import Data.Int (Int64)
22+import Data.IORef
23+import Data.Maybe
24+import Data.Pool
25+import Data.Text (lines, pack, unpack, unwords)
26+import Data.Text.IO (hGetContents)
27+import Data.Traversable
28+import Database.PostgreSQL.Simple
29+import Network.Wai.Handler.Warp
30+import Network.Wai.Handler.WarpTLS
31+import Options.Generic
32+import PostgreSQL.ErrorCodes (unique_violation)
33+import Prelude hiding (lines, log, unlines, unwords)
34+import Servant
35+import System.Environment (lookupEnv)
36+import System.Exit
37+import System.Log.FastLogger
38+import System.Posix.Signals (sigTERM)
39+import System.Process.Typed
40+
41+
42+import Common.Utils
43+import Common.Validation (isNameValid)
44+import Octopod.API
45+import Octopod.PowerAPI
46+import Octopod.Server.Args
47+import Octopod.Server.ControlScriptUtils
48+import Octopod.Server.Logger
49+import Octopod.Server.Posix
50+import Orphans ()
51+import TLS (createTLSOpts)
52+import Types
53+
54+type PgPool = Pool Connection
55+type AppM = ReaderT AppState Handler
56+
57+-- | Octopod Server state definition.
58+data AppState = AppState
59+ { pool :: PgPool
60+ -- ^ postgres pool
61+ , logger :: TimedFastLogger
62+ -- ^ logger
63+ , eventSink :: TChan WSEvent
64+ -- ^ channel for WS events for the frontend
65+ , bgWorkersCounter :: IORef Int
66+ -- ^ background workers counter
67+ , gracefulShutdownActivated :: IORef Bool
68+ -- ^ flag of activating graceful shutdown
69+ , shutdownSem :: MVar ()
70+ -- ^ semaphore for graceful shutdown
71+ , projectName :: ProjectName
72+ -- ^ project name
73+ , baseDomain :: Domain
74+ -- ^ base domain
75+ , namespace :: Namespace
76+ -- ^ namespace
77+ , archiveRetention :: ArchiveRetention
78+ -- ^ archive retention
79+ , statusUpdateTimeout :: Timeout
80+ -- ^ status update timeout
81+ , creationCommand :: Command
82+ -- ^ creation command path
83+ , updateCommand :: Command
84+ -- ^ update command path
85+ , archiveCommand :: Command
86+ -- ^ deletion command path
87+ , checkingCommand :: Command
88+ -- ^ checking command path
89+ , cleanupCommand :: Command
90+ -- ^ cleanup command path
91+ , archiveCheckingCommand :: Command
92+ -- ^ archive checking command path
93+ , tagCheckingCommand :: Command
94+ -- ^ tag checking command path
95+ , infoCommand :: Command
96+ }
97+
98+-- | Deployment exception definition.
99+data DeploymentException
100+ = DeploymentFailed Int
101+ | ThereIsActiveDeployment
102+ deriving (Show)
103+
104+instance Exception DeploymentException
105+
106+-- | Deployment list type definition.
107+data DeploymentListType
108+ = AllDeployments
109+ | ArchivedOnlyDeployments
110+ | ActiveOnlyDeployments
111+ deriving (Show)
112+
113+-- | Full info list type definition.
114+data FullInfoListType
115+ = FullInfoForAll
116+ | FullInfoOnlyForOne DeploymentName
117+ deriving (Show)
118+
119+-- | Deployment search errors definition.
120+data DeploymentNotFound
121+ = DeploymentNotFound
122+ | ArchivedDeploymentNotFound
123+ | ActiveDeploymentNotFound
124+ | DeploymentHasPendingStatus DeploymentStatus
125+
126+-- | Definition of a filter by pending statuses.
127+data FilterByPending
128+ = AllowPending
129+ | DenyPending
130+
131+runOctopodServer :: IO ()
132+runOctopodServer = do
133+ logger' <- newLogger
134+ logInfo logger' "started"
135+ bgWorkersC <- newIORef 0
136+ gracefulShutdownAct <- newIORef False
137+ shutdownS <- newEmptyMVar
138+ void $ do
139+ let
140+ termHandler = terminationHandler bgWorkersC gracefulShutdownAct shutdownS
141+ installShutdownHandler logger' [sigTERM] termHandler
142+ opts <- parseArgs
143+ let
144+ a ?! e = a >>= maybe (die e) pure
145+ getEnvOrDie eName = lookupEnv eName ?! (eName <> " is not set")
146+ projName <- coerce . pack <$> getEnvOrDie "PROJECT_NAME"
147+ domain <- coerce . pack <$> getEnvOrDie "BASE_DOMAIN"
148+ ns <- coerce . pack <$> getEnvOrDie "NAMESPACE"
149+ archRetention <- coerce . read @Int <$> getEnvOrDie "ARCHIVE_RETENTION"
150+ stUpdateTimeout <- coerce . read @Int <$> getEnvOrDie "STATUS_UPDATE_TIMEOUT"
151+ creationCmd <- coerce . pack <$> getEnvOrDie "CREATION_COMMAND"
152+ updateCmd <- coerce . pack <$> getEnvOrDie "UPDATE_COMMAND"
153+ archiveCmd <- coerce . pack <$> getEnvOrDie "ARCHIVE_COMMAND"
154+ checkingCmd <- coerce . pack <$> getEnvOrDie "CHECKING_COMMAND"
155+ cleanupCmd <- coerce . pack <$> getEnvOrDie "CLEANUP_COMMAND"
156+ archiveCheckingCmd <- coerce . pack <$> getEnvOrDie "ARCHIVE_CHECKING_COMMAND"
157+ tagCheckingCmd <- coerce . pack <$> getEnvOrDie "TAG_CHECKING_COMMAND"
158+ infoCmd <- coerce . pack <$> getEnvOrDie "INFO_COMMAND"
159+ pgPool <- initConnectionPool
160+ (unDBConnectionString $ octopodDB opts)
161+ (unDBPoolSize $ octopodDBPoolSize opts)
162+ channel <- liftIO . atomically $ newBroadcastTChan
163+ let
164+ appSt =
165+ AppState
166+ pgPool
167+ logger'
168+ channel
169+ bgWorkersC
170+ gracefulShutdownAct
171+ shutdownS
172+ projName
173+ domain
174+ ns
175+ archRetention
176+ stUpdateTimeout
177+ creationCmd
178+ updateCmd
179+ archiveCmd
180+ checkingCmd
181+ cleanupCmd
182+ archiveCheckingCmd
183+ tagCheckingCmd
184+ infoCmd
185+ app' = app appSt
186+ powerApp' = powerApp appSt
187+ wsApp' = wsApp channel
188+ serverPort = octopodPort opts
189+ uiServerPort = unServerPort $ octopodUIPort opts
190+ wsServerPort = unServerPort $ octopodWSPort opts
191+ tlsOpts =
192+ createTLSOpts (octopodTLSCertPath opts) (octopodTLSKeyPath opts)
193+ (octopodTLSStorePath opts) serverPort
194+ warpOpts = setPort (unServerPort serverPort) defaultSettings
195+ in
196+ (run uiServerPort app')
197+ `race_` (runTLS tlsOpts warpOpts powerApp')
198+ `race_` (run wsServerPort wsApp')
199+ `race_` (runStatusUpdater appSt)
200+ `race_` (runShutdownHandler appSt)
201+
202+-- | Initializes the connection pool.
203+initConnectionPool :: ByteString -> Int -> IO PgPool
204+initConnectionPool dbConnStr =
205+ createPool (connectPostgreSQL dbConnStr) close 1 30
206+
207+-- | Helper to run the server.
208+nt :: AppState -> AppM a -> Handler a
209+nt s x = runReaderT x s
210+
211+-- | Application with the Web UI API.
212+app :: AppState -> Application
213+app s = serve api $ hoistServer api (nt s) server
214+ where
215+ api = Proxy @API
216+
217+-- | Request handlers of the Web UI API application.
218+server :: ServerT API AppM
219+server =
220+ ( listH :<|> createH :<|> archiveH :<|> updateH
221+ :<|> infoH :<|> fullInfoH :<|> statusH :<|> restoreH
222+ ) :<|> pingH :<|> projectNameH
223+
224+-- | Application with the octo CLI API.
225+powerApp :: AppState -> Application
226+powerApp s = serve api $ hoistServer api (nt s) powerServer
227+ where
228+ api = Proxy @PowerAPI
229+
230+-- | Request handlers of application with the octo CLI API.
231+powerServer :: ServerT PowerAPI AppM
232+powerServer =
233+ ( powerListH :<|> createH :<|> archiveH :<|> updateH
234+ :<|> powerInfoH :<|> powerFullInfoH :<|> statusH :<|> cleanupH :<|> restoreH
235+ ) :<|> getActionInfoH :<|> cleanArchiveH
236+
237+-- | Application with the WS API.
238+wsApp :: TChan WSEvent -> Application
239+wsApp channel = serve api $ wsServer channel
240+ where
241+ api = Proxy @WebSocketAPI
242+
243+-- | Request handlers of the application with the WS API.
244+wsServer :: TChan WSEvent -> Server WebSocketAPI
245+wsServer = eventS
246+
247+-- | Handles WS events.
248+eventS :: MonadIO m => TChan WSEvent -> ConduitT () Value m ()
249+eventS channel = do
250+ dupChannel <- liftIO . atomically $ dupTChan channel
251+ forever $ do
252+ event <- liftIO . atomically . readTChan $ dupChannel
253+ yield . toJSON $ event
254+
255+-- | Handles the 'list' request of the Web UI API.
256+listH :: AppM [DeploymentFullInfo]
257+listH = hidePrivateOverridesInFullInfos <$> getFullInfo FullInfoForAll
258+
259+-- | Handles the 'list' request of the octo CLI API.
260+powerListH :: AppM [DeploymentFullInfo]
261+powerListH = getFullInfo FullInfoForAll
262+
263+-- | Handles the 'full_info' request of the Web UI API.
264+fullInfoH :: DeploymentName -> AppM DeploymentFullInfo
265+fullInfoH dName = do
266+ fullInfoList <- hidePrivateOverridesInFullInfos <$>
267+ getFullInfo (FullInfoOnlyForOne dName)
268+ case fullInfoList of
269+ fullInfo : _ -> pure fullInfo
270+ [] -> throwError err404
271+ { errBody = validationError ["Name not found"] [] }
272+
273+-- | Handles the 'full_info' request of the octo CLI API.
274+powerFullInfoH :: DeploymentName -> AppM DeploymentFullInfo
275+powerFullInfoH dName = do
276+ fullInfoList <- getFullInfo $ FullInfoOnlyForOne dName
277+ case fullInfoList of
278+ fullInfo : _ -> pure fullInfo
279+ [] -> throwError err404
280+ { errBody = validationError ["Name not found"] [] }
281+
282+-- | Hides private overrides in 'full_info' response.
283+hidePrivateOverridesInFullInfos :: [DeploymentFullInfo] -> [DeploymentFullInfo]
284+hidePrivateOverridesInFullInfos dFullInfos = do
285+ dFullInfos <&> \(DeploymentFullInfo dep s a ct ut u) ->
286+ let
287+ hidePrivate (Deployment n t appOvs depOvs) =
288+ Deployment n t (hideP appOvs) (hideP depOvs)
289+ hideP o =
290+ coerce o <&> \(Override k v vis) ->
291+ let
292+ v' = case vis of
293+ Private -> "*"
294+ Public -> v
295+ in coerce $ Override k v' vis
296+ in DeploymentFullInfo (hidePrivate dep) s a ct ut u
297+
298+-- | Helper to get full_info from the database.
299+getFullInfo :: FullInfoListType -> AppM [DeploymentFullInfo]
300+getFullInfo listType = do
301+ AppState {pool = p, logger = l} <- ask
302+ deployments <- liftIO $ withResource p $ \conn -> do
303+ rows <- case listType of
304+ FullInfoForAll -> query_ conn qAll
305+ FullInfoOnlyForOne (dName) -> query conn qOne (Only dName)
306+ for rows $ \(n, t, a, ct, ut, st) -> do
307+ (appOvs, depOvs) <- selectOverrides conn n
308+ dMeta <- selectDeploymentMetadata conn n
309+ pure $ do
310+ let dep = (Deployment n t appOvs depOvs)
311+ DeploymentFullInfo dep (read st) a dMeta ct ut
312+ liftIO . logInfo l $ "get deployments: " <> (pack . show $ deployments)
313+ return deployments
314+ where
315+ qAll =
316+ "SELECT name, tag, archived, extract(epoch from created_at)::int, \
317+ \extract(epoch from updated_at)::int, status::text \
318+ \FROM deployments ORDER BY name"
319+ qOne =
320+ "SELECT name, tag, archived, extract(epoch from created_at)::int, \
321+ \extract(epoch from updated_at)::int, status::text \
322+ \FROM deployments \
323+ \WHERE name = ?"
324+
325+-- | Handles the 'create' request.
326+createH :: Deployment -> AppM CommandResponse
327+createH dep = do
328+ failIfGracefulShutdownActivated
329+ unless (isNameValid $ name dep) $ do
330+ let
331+ badNameText =
332+ "Deployment name length should be longer than 2 characters, \
333+ \under 17 characters and begin with a letter."
334+ throwError err400
335+ { errBody = validationError [badNameText] [] }
336+ t1 <- liftIO $ now
337+ st <- ask
338+ let
339+ q =
340+ "INSERT INTO deployments (name, tag, status) \
341+ \VALUES (?, ?, ?) RETURNING id"
342+ pgPool = pool st
343+ createDep :: PgPool -> Deployment -> IO [Only Int]
344+ createDep p Deployment { name = n, tag = t } =
345+ withResource p $ \conn ->
346+ query conn q (n, t, show CreatePending)
347+ failIfImageNotFound (name dep) (tag dep)
348+ failIfGracefulShutdownActivated
349+ res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep
350+ dId <- case res of
351+ Right ((Only depId) : _) ->
352+ pure . DeploymentId $ depId
353+ Right [] ->
354+ throwError err404
355+ { errBody = validationError ["Name not found"] [] }
356+ Left (SqlError code _ _ _ _) | code == unique_violation ->
357+ throwError err400
358+ { errBody = validationError ["Deployment already exists"] [] }
359+ Left (SqlError _ _ _ _ _) ->
360+ throwError err409 { errBody = appError "Some database error" }
361+ liftIO . withResource pgPool $ \conn ->
362+ upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep)
363+ liftIO . runBgWorker st $ do
364+ sendReloadEvent st
365+ updateDeploymentInfo (name dep) st
366+ (ec, out, err) <- createDeployment dep st
367+ t2 <- now
368+ let
369+ arch = ArchivedFlag False
370+ elTime = elapsedTime t2 t1
371+ createDeploymentLog pgPool dep "create" ec arch elTime out err
372+ sendReloadEvent st
373+ handleExitCode ec
374+ pure Success
375+
376+-- | Updates deployment info.
377+updateDeploymentInfo :: DeploymentName -> AppState -> IO ()
378+updateDeploymentInfo dName st = do
379+ let
380+ log = logWarning (logger st)
381+ args = infoCommandArgs (projectName st) (baseDomain st) (namespace st) dName
382+ cmd = coerce $ infoCommand st
383+ liftIO $ do
384+ (ec, out, err) <- runCommand (unpack cmd) (coerce args)
385+ case ec of
386+ ExitSuccess -> do
387+ dMeta <- parseDeploymentMetadata (lines . unStdout $ out)
388+ forM_ dMeta $ \meta ->
389+ upsertDeploymentMetadata (pool st) dName meta
390+ ExitFailure _ ->
391+ log $
392+ "could not get deployment info, exit code: " <> (pack . show $ ec)
393+ <> ", stdout: " <> coerce out <> "stderr: " <> coerce err
394+
395+-- | Helper to create a new deployment.
396+createDeployment :: Deployment -> AppState -> IO (ExitCode, Stdout, Stderr)
397+createDeployment dep st = do
398+ let
399+ log :: Text -> IO ()
400+ log = logInfo (logger st)
401+ args =
402+ [ "--project-name", coerce $ projectName st
403+ , "--base-domain", coerce $ baseDomain st
404+ , "--namespace", coerce $ namespace st
405+ , "--name", coerce $ name dep
406+ , "--tag", coerce $ tag dep
407+ ] ++ applicationOverridesToArgs (appOverrides dep)
408+ ++ deploymentOverridesToArgs (deploymentOverrides dep)
409+ cmd = coerce $ creationCommand st
410+
411+ liftIO $ do
412+ log $ "call " <> unwords (cmd : args)
413+ (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
414+ log $ "deployment created, deployment: " <> (pack . show $ dep)
415+ pure (ec, out, err)
416+
417+-- | Converts an application-level override list to command arguments.
418+applicationOverrideToArg :: ApplicationOverride -> [Text]
419+applicationOverrideToArg o = ["--app-env-override", overrideToArg . coerce $ o]
420+
421+-- | Helper to convert an application-level override to command arguments.
422+applicationOverridesToArgs :: ApplicationOverrides -> [Text]
423+applicationOverridesToArgs ovs = concat [applicationOverrideToArg o | o <- ovs ]
424+
425+-- | Converts a deployment-level override list to command arguments.
426+deploymentOverrideToArg :: DeploymentOverride -> [Text]
427+deploymentOverrideToArg o =
428+ ["--deployment-override", overrideToArg . coerce $ o]
429+
430+-- | Helper to convert a deployment-level override to command arguments.
431+deploymentOverridesToArgs :: DeploymentOverrides -> [Text]
432+deploymentOverridesToArgs ovs = concat [deploymentOverrideToArg o | o <- ovs]
433+
434+-- | Helper to get deployment logs.
435+selectDeploymentLogs
436+ :: PgPool
437+ -> DeploymentId
438+ -> IO [DeploymentLog]
439+selectDeploymentLogs pgPool dId = do
440+ let
441+ q =
442+ "SELECT id, action::text, tag, exit_code, \
443+ \duration, extract(epoch from created_at)::int \
444+ \FROM deployment_logs \
445+ \WHERE deployment_id = ? \
446+ \ORDER BY created_at DESC \
447+ \LIMIT 20"
448+ withResource pgPool $ \conn -> do
449+ rows <- query conn q (Only . unDeploymentId $ dId)
450+ -- FIXME: use FromRow instance instead
451+ for rows $ \(ai, a, t, ec, d, ts) -> do
452+ (appOvs, depOvs) <- selectLogOverrides conn (ActionId ai)
453+ pure $ DeploymentLog (ActionId ai) a t appOvs depOvs ec (Duration d) ts
454+
455+-- | Helper to get a deployment.
456+selectDeployment
457+ :: PgPool
458+ -> DeploymentName
459+ -> DeploymentListType
460+ -> FilterByPending
461+ -> AppM (Either DeploymentNotFound Deployment)
462+selectDeployment pgPool dName lType filterByPending = do
463+ let
464+ baseQuery =
465+ "SELECT name, tag, status::text FROM deployments \
466+ \WHERE name = ?"
467+ q AllDeployments = baseQuery
468+ q ArchivedOnlyDeployments = baseQuery <> " AND archived = 't'"
469+ q ActiveOnlyDeployments = baseQuery <> " AND archived = 'f'"
470+ allowPending =
471+ case filterByPending of
472+ AllowPending -> True
473+ DenyPending -> False
474+ result <- liftIO . withResource pgPool $ \conn -> do
475+ retrieved <- query conn (q lType) (Only dName)
476+ for retrieved $ \(n, t, s) -> do
477+ (appOvs, stOvs) <- selectOverrides conn n
478+ pure $ (Deployment n t appOvs stOvs, read s)
479+ pure $
480+ case result of
481+ [(_, st)] | isPending st && not allowPending ->
482+ Left $ DeploymentHasPendingStatus st
483+ [(dep, _)] ->
484+ Right dep
485+ _ ->
486+ Left $
487+ case lType of
488+ AllDeployments -> DeploymentNotFound
489+ ArchivedOnlyDeployments -> ArchivedDeploymentNotFound
490+ ActiveOnlyDeployments -> ActiveDeploymentNotFound
491+
492+-- | Handles deployment search result.
493+unwrapOrValidateError
494+ :: AppM (Either DeploymentNotFound Deployment)
495+ -> AppM Deployment
496+unwrapOrValidateError deploymentSearchResult = do
497+ deploymentSearchResult' <- deploymentSearchResult
498+ case deploymentSearchResult' of
499+ Right dep -> pure dep
500+ Left DeploymentNotFound ->
501+ throwError err404
502+ { errBody = validationError ["Deployment not found"] [] }
503+ Left ArchivedDeploymentNotFound ->
504+ throwError err404
505+ { errBody = validationError ["Archived deployment not found"] [] }
506+ Left ActiveDeploymentNotFound ->
507+ throwError err404
508+ { errBody = validationError ["Active deployment not found"] [] }
509+ Left (DeploymentHasPendingStatus st) ->
510+ let
511+ err =
512+ "You can not apply this operation \
513+ \on deployment with \"" <> (pack . show $ st) <> "\" status"
514+ in throwError err405 { errBody = validationError [err] [] }
515+
516+-- | Handles the 'archive' request.
517+archiveH :: DeploymentName -> AppM CommandResponse
518+archiveH dName = do
519+ failIfGracefulShutdownActivated
520+ t1 <- liftIO $ now
521+ st <- ask
522+ let
523+ log = logInfo (logger st)
524+ pgPool = pool st
525+ args =
526+ [ "--project-name", coerce $ projectName st
527+ , "--base-domain", coerce $ baseDomain st
528+ , "--namespace", coerce $ namespace st
529+ , "--name", coerce dName
530+ ]
531+ cmd = coerce $ archiveCommand st
532+ arch = ArchivedFlag True
533+ dep <- unwrapOrValidateError
534+ $ selectDeployment pgPool dName ActiveOnlyDeployments DenyPending
535+ liftIO . runBgWorker st $ do
536+ log $ "call " <> unwords (cmd : args)
537+ (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
538+ void $ archiveDeployment pgPool dName
539+ sendReloadEvent st
540+ t2 <- now
541+ let elTime = elapsedTime t2 t1
542+ void $ createDeploymentLog pgPool dep "archive" ec arch elTime out err
543+ log $ "deployment archived, name: " <> coerce dName
544+ sendReloadEvent st
545+ handleExitCode ec
546+ pure Success
547+
548+-- | Handles the 'archive' request.
549+archiveDeployment :: PgPool -> DeploymentName -> IO Int64
550+archiveDeployment p dName = withResource p $ \conn -> do
551+ let
552+ q =
553+ "UPDATE deployments \
554+ \SET archived = 't', archived_at = now(), \
555+ \status = ?, status_updated_at = now() \
556+ \WHERE name = ?"
557+ execute conn q (show ArchivePending, dName)
558+
559+-- | Handles the 'update' request.
560+updateH :: DeploymentName -> DeploymentUpdate -> AppM CommandResponse
561+updateH dName dUpdate = do
562+ failIfGracefulShutdownActivated
563+ t1 <- liftIO $ now
564+ st <- ask
565+ let
566+ DeploymentUpdate
567+ { newTag = dTag
568+ , newAppOverrides = newAppOvs
569+ , oldAppOverrides = oldAppOvs
570+ , newDeploymentOverrides = newDepOvs
571+ , oldDeploymentOverrides = oldDepOvs
572+ } = dUpdate
573+ pgPool = pool st
574+ log = logInfo (logger st)
575+
576+ void $ unwrapOrValidateError
577+ $ selectDeployment pgPool dName ActiveOnlyDeployments DenyPending
578+ dId <- selectDeploymentId pgPool dName
579+ failIfImageNotFound dName dTag
580+ failIfGracefulShutdownActivated
581+ liftIO . runBgWorker st $ do
582+ (appOvs, depOvs) <- withResource pgPool $ \conn ->
583+ withTransaction conn $ do
584+ deleteOldOverrides conn dId oldAppOvs oldDepOvs
585+ upsertNewOverrides conn dId newAppOvs newDepOvs
586+ void $ updateDeployment conn dName dTag
587+ selectOverrides conn dName
588+ updateDeploymentInfo dName st
589+ sendReloadEvent st
590+ let
591+ args =
592+ [ "--project-name", coerce $ projectName st
593+ , "--base-domain", coerce $ baseDomain st
594+ , "--namespace", coerce $ namespace st
595+ , "--name", coerce $ dName
596+ , "--tag", coerce $ dTag
597+ ] ++ applicationOverridesToArgs appOvs
598+ ++ deploymentOverridesToArgs depOvs
599+ cmd = coerce $ updateCommand st
600+ log $ "call " <> unwords (cmd : args)
601+ (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
602+ log $ "deployment updated, name: "
603+ <> coerce dName <> ", tag: " <> coerce dTag
604+ void $ do
605+ t2 <- now
606+ let
607+ dep = Deployment dName dTag appOvs depOvs
608+ arch = ArchivedFlag False
609+ elTime = elapsedTime t2 t1
610+ createDeploymentLog pgPool dep "update" ec arch elTime out err
611+ sendReloadEvent st
612+ handleExitCode ec
613+ return Success
614+
615+-- | Helper to get overrides from the database.
616+selectOverrides
617+ :: Connection
618+ -> DeploymentName
619+ -> IO (ApplicationOverrides, DeploymentOverrides)
620+selectOverrides conn dName = do
621+ let
622+ q =
623+ "SELECT key, value, scope::text, visibility::text \
624+ \FROM deployment_overrides \
625+ \WHERE deployment_id = ( \
626+ \SELECT id FROM deployments WHERE name = ? \
627+ \)"
628+ parseVis :: Text -> OverrideVisibility
629+ parseVis = read . unpack
630+ parseScope :: Text -> OverrideScope
631+ parseScope = read . unpack
632+ toOverrides (k, v, s, vis) (appOvs, depOvs) =
633+ pure $ case parseScope s of
634+ ApplicationScope ->
635+ (ApplicationOverride (Override k v $ parseVis vis) : appOvs, depOvs)
636+ DeploymentScope ->
637+ (appOvs, DeploymentOverride (Override k v $ parseVis vis) : depOvs)
638+ rows <- query conn q (Only dName)
639+ foldrM toOverrides ([], []) rows
640+
641+-- | Helper to get override logs from the database.
642+selectLogOverrides
643+ :: Connection
644+ -> ActionId
645+ -> IO (ApplicationOverrides, DeploymentOverrides)
646+selectLogOverrides conn aId = do
647+ let
648+ q =
649+ "SELECT key, value, scope::text, visibility::text \
650+ \FROM deployment_log_overrides \
651+ \WHERE deployment_log_id = ?"
652+ parseVis :: Text -> OverrideVisibility
653+ parseVis = read . unpack
654+ parseScope :: Text -> OverrideScope
655+ parseScope = read . unpack
656+ toOverrides (k, v, s, vis) (appOvs, depOvs) =
657+ pure $ case parseScope s of
658+ ApplicationScope ->
659+ (ApplicationOverride (Override k v $ parseVis vis) : appOvs, depOvs)
660+ DeploymentScope ->
661+ (appOvs, DeploymentOverride (Override k v $ parseVis vis) : depOvs)
662+ rows <- query conn q (Only . unActionId $ aId)
663+ foldrM toOverrides ([], []) rows
664+
665+-- | Helper to delete overrides from the database.
666+deleteOldOverrides
667+ :: Connection
668+ -> DeploymentId
669+ -> ApplicationOverrides
670+ -> DeploymentOverrides
671+ -> IO ()
672+deleteOldOverrides conn dId appOvs depOvs = do
673+ let
674+ q =
675+ "DELETE FROM deployment_overrides \
676+ \WHERE deployment_id = ? AND key = ? AND scope = ?"
677+ dId' = unDeploymentId dId
678+ void $ for appOvs $ \o -> do
679+ let
680+ oKey = overrideKey . unApplicationOverride $ o
681+ oScope = show ApplicationScope
682+ execute conn q (dId', oKey, oScope)
683+ void $ for depOvs $ \o -> do
684+ let
685+ oKey = overrideKey . unDeploymentOverride $ o
686+ oScope = show DeploymentScope
687+ execute conn q (dId', oKey, oScope)
688+
689+-- | Helper to get the deployment id from the database.
690+selectDeploymentId :: PgPool -> DeploymentName -> AppM DeploymentId
691+selectDeploymentId pgPool dName = do
692+ dIds :: [(Only Int)] <- liftIO $ withResource pgPool $ \conn ->
693+ query conn "SELECT id FROM deployments WHERE name = ?" (Only dName)
694+ case dIds of
695+ [(Only dId)] -> pure . DeploymentId $ dId
696+ [] -> throwError err404
697+ { errBody = validationError ["Name not found"] [] }
698+ _ -> throwError err406
699+ { errBody = validationError ["More than one name found"] [] }
700+
701+-- | Helper to insert or update overrides.
702+upsertNewOverrides
703+ :: Connection
704+ -> DeploymentId
705+ -> ApplicationOverrides
706+ -> DeploymentOverrides
707+ -> IO ()
708+upsertNewOverrides conn dId appOvs depOvs = do
709+ let
710+ q =
711+ "INSERT INTO deployment_overrides \
712+ \(key, value, deployment_id, scope, visibility) \
713+ \VALUES (?, ?, ?, ?, ?) \
714+ \ON CONFLICT (key, deployment_id, scope) \
715+ \DO \
716+ \UPDATE SET value = ?, visibility = ?, updated_at = now()"
717+ dId' = unDeploymentId dId
718+ void $ for appOvs $ \o -> do
719+ let
720+ oKey = overrideKey . unApplicationOverride $ o
721+ oValue = overrideValue . unApplicationOverride $ o
722+ oScope = show ApplicationScope
723+ oVis = show . overrideVisibility . unApplicationOverride $ o
724+ execute conn q (oKey, oValue, dId', oScope, oVis, oValue, oVis)
725+ void $ for depOvs $ \o -> do
726+ let
727+ oKey = overrideKey . unDeploymentOverride $ o
728+ oValue = overrideValue . unDeploymentOverride $ o
729+ oScope = show DeploymentScope
730+ oVis = show . overrideVisibility . unDeploymentOverride $ o
731+ execute conn q (oKey, oValue, dId', oScope, oVis, oValue, oVis)
732+
733+-- | Helper to update a deployment.
734+updateDeployment
735+ :: Connection
736+ -> DeploymentName
737+ -> DeploymentTag
738+ -> IO Int64
739+updateDeployment conn dName dTag = do
740+ let
741+ q =
742+ "UPDATE deployments \
743+ \SET tag = ?, updated_at = now(), \
744+ \status = ?, status_updated_at = now() \
745+ \WHERE name = ?"
746+ execute conn q (dTag, show UpdatePending, dName)
747+
748+-- | Handles the 'info' request of the Web UI API.
749+infoH :: DeploymentName -> AppM [DeploymentInfo]
750+infoH dName = do
751+ st <- ask
752+ dInfo <- getInfo dName
753+ liftIO . logInfo (logger st) $
754+ "get deployment info: " <> (pack . show $ dInfo)
755+ pure [hidePrivateOverridesInInfo dInfo]
756+
757+-- | Handles the 'info' request of the octo CLI API.
758+powerInfoH :: DeploymentName -> AppM [DeploymentInfo]
759+powerInfoH dName = do
760+ st <- ask
761+ dInfo <- getInfo dName
762+ liftIO . logInfo (logger st) $
763+ "get deployment info: " <> (pack . show $ dInfo)
764+ pure [dInfo]
765+
766+-- | Hides private overrides of 'info' response.
767+hidePrivateOverridesInInfo :: DeploymentInfo -> DeploymentInfo
768+hidePrivateOverridesInInfo (DeploymentInfo dep dMeta dLogs) =
769+ let
770+ dep' =
771+ let (Deployment n t ao so) = dep
772+ in Deployment n t (hideP ao) (hideP so)
773+ dLogs' = dLogs <&> \(DeploymentLog ai a t ao so ec d ct) ->
774+ DeploymentLog ai a t (hideP ao) (hideP so) ec d ct
775+ hideP o = coerce o <&> \(Override k v vis) ->
776+ let
777+ v' = case vis of
778+ Private -> "*"
779+ Public -> v
780+ in coerce $ Override k v' vis
781+ in DeploymentInfo dep' dMeta dLogs'
782+
783+-- | Helper to get deployment info from the database.
784+getInfo :: DeploymentName -> AppM DeploymentInfo
785+getInfo dName = do
786+ st <- ask
787+ let pgPool = pool st
788+ dep <- unwrapOrValidateError
789+ $ selectDeployment pgPool dName AllDeployments AllowPending
790+ dId <- selectDeploymentId pgPool dName
791+ liftIO $ do
792+ depLogs <- selectDeploymentLogs pgPool dId
793+ dMeta <- withResource pgPool $ \conn ->
794+ selectDeploymentMetadata conn dName
795+ let depInfo = DeploymentInfo dep dMeta $ reverse depLogs
796+ pure depInfo
797+
798+-- | Handles the 'ping' request.
799+pingH :: AppM NoContent
800+pingH = do
801+ pgPool <- pool <$> ask
802+ _ :: [Only Int] <- liftIO $ withResource pgPool $ \conn ->
803+ query_ conn "SELECT 1"
804+ pure NoContent
805+
806+-- | Handles the 'project_name' request.
807+projectNameH :: AppM ProjectName
808+projectNameH = projectName <$> ask
809+
810+-- | Handles the 'status' request.
811+statusH :: DeploymentName -> AppM CurrentDeploymentStatus
812+statusH dName = do
813+ st <- ask
814+ let
815+ pgPool = pool st
816+ log = logInfo (logger st)
817+ cmd = checkingCommand st
818+ args =
819+ [ "--namespace", coerce $ namespace st
820+ , "--name", coerce $ dName ]
821+ void $ unwrapOrValidateError
822+ $ selectDeployment pgPool dName AllDeployments AllowPending
823+ liftIO $ log $ "call " <> unwords (coerce cmd : args)
824+ ec <- liftIO $ runCommandWithoutPipes (unpack $ coerce cmd) (unpack <$> args)
825+ pure . CurrentDeploymentStatus $
826+ case ec of
827+ ExitSuccess -> Ok
828+ _ -> Error
829+
830+-- | Handles the 'cleanup' request.
831+cleanupH :: DeploymentName -> AppM CommandResponse
832+cleanupH dName = do
833+ failIfGracefulShutdownActivated
834+ st <- ask
835+ void $ unwrapOrValidateError
836+ $ selectDeployment (pool st) dName ArchivedOnlyDeployments DenyPending
837+ liftIO . runBgWorker st $ cleanupDeployment dName st
838+ pure Success
839+
840+-- | Helper to cleanup deployment.
841+cleanupDeployment :: DeploymentName -> AppState -> IO ()
842+cleanupDeployment dName st = do
843+ let
844+ log = logInfo (logger st)
845+ pgPool = pool st
846+ args =
847+ [ "--project-name", coerce $ projectName st
848+ , "--base-domain", coerce $ baseDomain st
849+ , "--namespace", coerce $ namespace st
850+ , "--name", coerce dName
851+ ]
852+ cmd = coerce $ cleanupCommand st
853+ log $ "call " <> unwords (cmd : args)
854+ (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
855+ print out >> print err
856+ void $ deleteDeploymentLogOverrides pgPool dName
857+ void $ deleteDeploymentLogs pgPool dName
858+ void $ deleteDeploymentMetadata pgPool dName
859+ void $ deleteDeploymentOverrides pgPool dName
860+ void $ deleteDeployment pgPool dName
861+ log $ "deployment destroyed, name: " <> coerce dName
862+ sendReloadEvent st
863+ handleExitCode ec
864+
865+-- | Helper to delete deployment log overrides.
866+deleteDeploymentLogOverrides :: PgPool -> DeploymentName -> IO Int64
867+deleteDeploymentLogOverrides p n = withResource p $ \conn -> execute
868+ conn
869+ "DELETE FROM deployment_log_overrides WHERE deployment_log_id in ( \
870+ \SELECT id FROM deployment_logs WHERE deployment_id in ( \
871+ \SELECT id FROM deployments where name = ? \
872+ \) \
873+ \)"
874+ (Only n)
875+
876+-- | Helper to delete deployment logs.
877+deleteDeploymentLogs :: PgPool -> DeploymentName -> IO Int64
878+deleteDeploymentLogs p n = withResource p $ \conn -> execute
879+ conn
880+ "DELETE FROM deployment_logs WHERE deployment_id in\
881+ \ (SELECT id FROM deployments where name = ?)"
882+ (Only n)
883+
884+-- | Helper to delete deployment overrides.
885+deleteDeploymentOverrides :: PgPool -> DeploymentName -> IO Int64
886+deleteDeploymentOverrides p n = withResource p $ \conn -> execute
887+ conn
888+ "DELETE FROM deployment_overrides WHERE deployment_id in\
889+ \ (SELECT id FROM deployments where name = ?)"
890+ (Only n)
891+
892+-- | Helper to delete a deployment.
893+deleteDeployment :: PgPool -> DeploymentName -> IO Int64
894+deleteDeployment p n = withResource p $ \conn ->
895+ execute conn "DELETE FROM deployments WHERE name = ?" (Only n)
896+
897+-- | Handles the 'clean-archive' request.
898+cleanArchiveH :: AppM CommandResponse
899+cleanArchiveH = do
900+ failIfGracefulShutdownActivated
901+ st <- ask
902+ let
903+ pgPool = pool st
904+ archRetention = unArchiveRetention . archiveRetention $ st
905+ q =
906+ "SELECT name FROM deployments \
907+ \WHERE archived = 't' AND archived_at + interval '?' second < now()"
908+ retrieved :: [Only DeploymentName] <- liftIO $
909+ withResource pgPool $ \conn -> query conn q (Only archRetention)
910+ liftIO . runBgWorker st . void $
911+ for retrieved $ \(Only dName) -> cleanupDeployment dName st
912+
913+ pure Success
914+
915+-- | Handles the 'restore' request.
916+restoreH :: DeploymentName -> AppM CommandResponse
917+restoreH dName = do
918+ failIfGracefulShutdownActivated
919+ t1 <- liftIO $ now
920+ st <- ask
921+ let pgPool = pool st
922+ dep <- unwrapOrValidateError
923+ $ selectDeployment pgPool dName ArchivedOnlyDeployments DenyPending
924+ failIfImageNotFound (name dep) (tag dep)
925+ failIfGracefulShutdownActivated
926+ liftIO . runBgWorker st $ do
927+ updateDeploymentInfo dName st
928+ let
929+ q =
930+ "UPDATE deployments \
931+ \SET archived = 'f', archived_at = null, status = 'CreatePending' \
932+ \WHERE name = ?"
933+ void $ withResource pgPool $ \conn -> execute conn q (Only dName)
934+ sendReloadEvent st
935+ (ec, out, err) <- createDeployment dep st
936+ t2 <- now
937+ let
938+ arch = ArchivedFlag False
939+ elTime = elapsedTime t2 t1
940+ createDeploymentLog pgPool dep "restore" ec arch elTime out err
941+ sendReloadEvent st
942+ handleExitCode ec
943+ pure Success
944+
945+-- | Helper to get action info.
946+getActionInfoH :: ActionId -> AppM ActionInfo
947+getActionInfoH aId = do
948+ st <- ask
949+ let
950+ pgPool = pool st
951+ aId' = Only . unActionId $ aId
952+ q = "SELECT stdout, stderr FROM deployment_logs WHERE id = ?"
953+ rows :: [(Text, Text)] <- liftIO $
954+ withResource pgPool $ \conn -> query conn q aId'
955+ case rows of
956+ (out, err) : _ -> pure $ ActionInfo out err
957+ _ ->
958+ throwError err400 { errBody = appError "Action not found" }
959+
960+-- | Helper to run command with pipes.
961+runCommand :: FilePath -> [String] -> IO (ExitCode, Stdout, Stderr)
962+runCommand cmd args = do
963+ let proc' c a = setStdout createPipe . setStderr createPipe $ proc c a
964+ withProcessWait (proc' cmd args) $ \p -> do
965+ out <- hGetContents . getStdout $ p
966+ err <- hGetContents . getStderr $ p
967+ ec <- waitExitCode p
968+ pure (ec, Stdout out, Stderr err)
969+
970+-- | Helper to run command without pipes.
971+runCommandWithoutPipes :: FilePath -> [String] -> IO ExitCode
972+runCommandWithoutPipes cmd args = do
973+ withProcessWait (proc cmd args) $ \p -> do
974+ ec <- waitExitCode p
975+ pure ec
976+
977+-- | Helper to handle exit code.
978+handleExitCode :: ExitCode -> IO ()
979+handleExitCode ExitSuccess = return ()
980+handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c
981+
982+-- | Helper to log a deployment action.
983+createDeploymentLog
984+ :: PgPool
985+ -> Deployment
986+ -> Action
987+ -> ExitCode
988+ -> ArchivedFlag
989+ -> Duration
990+ -> Stdout
991+ -> Stderr
992+ -> IO ()
993+createDeploymentLog pgPool dep act ec arch dur out err = do
994+ let
995+ (Deployment dName dTag appOvs depOvs) = dep
996+ exitCode' =
997+ case ec of
998+ ExitSuccess -> 0
999+ ExitFailure errCode -> errCode
1000+ arch' = unArchivedFlag arch
1001+ dur' = unDuration dur
1002+ out' = unStdout out
1003+ err' = unStderr err
1004+ qInsertLog =
1005+ "INSERT INTO deployment_logs \
1006+ \(deployment_id, action, tag, exit_code, archived, \
1007+ \duration, stdout, stderr) \
1008+ \(\
1009+ \SELECT id, ?, ?, ?, ?, ?, ?, ? \
1010+ \FROM deployments \
1011+ \WHERE name = ? \
1012+ \) RETURNING id"
1013+ qInsertLogOverride =
1014+ "INSERT INTO deployment_log_overrides \
1015+ \(key, value, deployment_log_id, scope, visibility) \
1016+ \VALUES (?, ?, ?, ?, ?)"
1017+
1018+ void $ withResource pgPool $ \conn ->
1019+ withTransaction conn $ do
1020+ aIds :: [Only Int] <- query conn qInsertLog
1021+ (act, dTag, exitCode', arch', dur', out', err', dName)
1022+ void $ for appOvs $ \o -> do
1023+ let
1024+ [Only aId] = aIds
1025+ oKey = overrideKey . unApplicationOverride $ o
1026+ oValue = overrideValue . unApplicationOverride $ o
1027+ oScope = show ApplicationScope
1028+ oVis = show . overrideVisibility . unApplicationOverride $ o
1029+ execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1030+ void $ for depOvs $ \o -> do
1031+ let
1032+ [Only aId] = aIds
1033+ oKey = overrideKey . unDeploymentOverride $ o
1034+ oValue = overrideValue . unDeploymentOverride $ o
1035+ oScope = show DeploymentScope
1036+ oVis = show . overrideVisibility . unDeploymentOverride $ o
1037+ execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1038+
1039+-- | Helper to get deployment metadata from the database.
1040+selectDeploymentMetadata
1041+ :: Connection
1042+ -> DeploymentName
1043+ -> IO [DeploymentMetadata]
1044+selectDeploymentMetadata conn dName = do
1045+ let
1046+ q =
1047+ "SELECT key, value FROM deployment_metadata \
1048+ \WHERE deployment_id = (SELECT id FROM deployments WHERE name = ?)"
1049+ rows <- query conn q (Only dName)
1050+ for rows $ \(k, v) -> pure $ DeploymentMetadata k v
1051+
1052+-- | Helper to delete deployment metadata.
1053+deleteDeploymentMetadata
1054+ :: PgPool
1055+ -> DeploymentName
1056+ -> IO ()
1057+deleteDeploymentMetadata pgPool dName = do
1058+ let
1059+ q =
1060+ "DELETE FROM deployment_metadata \
1061+ \WHERE deployment_id = (SELECT id FROM deployments WHERE name = ?)"
1062+ void $ withResource pgPool $ \conn -> execute conn q (Only dName)
1063+
1064+-- | Helper to insert or update deployment metadata.
1065+upsertDeploymentMetadata
1066+ :: PgPool
1067+ -> DeploymentName
1068+ -> DeploymentMetadata
1069+ -> IO ()
1070+upsertDeploymentMetadata pgPool dName dMetadata = do
1071+ let
1072+ q =
1073+ "INSERT INTO deployment_metadata \
1074+ \(deployment_id, key, value, created_at, updated_at) \
1075+ \(SELECT id, ?, ?, now(), now() FROM deployments WHERE name = ?) \
1076+ \ON CONFLICT (deployment_id, key) \
1077+ \DO \
1078+ \UPDATE SET key = ?, value = ?, updated_at = now()"
1079+ key = deploymentMetadataKey dMetadata
1080+ value = deploymentMetadataValue dMetadata
1081+ void $ withResource pgPool $ \conn ->
1082+ execute conn q (key, value, dName, key, value)
1083+
1084+-- | Checks the existence of a deployment tag.
1085+-- Returns 404 'Tag not found' response if the deployment tag doesn't exist.
1086+failIfImageNotFound :: DeploymentName -> DeploymentTag -> AppM ()
1087+failIfImageNotFound dName dTag = do
1088+ st <- ask
1089+ let
1090+ log :: Text -> IO ()
1091+ log = logInfo (logger st)
1092+ args =
1093+ [ "--project-name", coerce $ projectName st
1094+ , "--base-domain", coerce $ baseDomain st
1095+ , "--namespace", coerce $ namespace st
1096+ , "--name", coerce $ dName
1097+ , "--tag", coerce $ dTag
1098+ ]
1099+ cmd = coerce $ tagCheckingCommand st
1100+
1101+ ec <- liftIO $ do
1102+ log $ "call " <> unwords (cmd : args)
1103+ runCommandWithoutPipes (unpack cmd) (unpack <$> args)
1104+ case ec of
1105+ ExitSuccess -> pure ()
1106+ ExitFailure _ ->
1107+ throwError err400 { errBody = validationError [] ["Tag not found"] }
1108+
1109+-- | Helper to create an application-level error.
1110+appError :: Text -> BSL.ByteString
1111+appError = encode . AppError
1112+
1113+-- | Helper to create a validation-level error.
1114+validationError :: [Text] -> [Text] -> BSL.ByteString
1115+validationError nameErrors tagErrors =
1116+ encode $ ValidationError nameErrors tagErrors
1117+
1118+-- | Helper to send an event to the WS event channel.
1119+sendReloadEvent :: AppState -> IO ()
1120+sendReloadEvent state =
1121+ atomically $ writeTChan (eventSink state) FrontendPleaseUpdateEverything
1122+
1123+-- | Returns time delta between 2 timestamps.
1124+elapsedTime :: Time -> Time -> Duration
1125+elapsedTime t1 t2 =
1126+ Duration . fromIntegral . (`div` 1000000) . abs $ getTime t2 - getTime t1
1127+
1128+-- | Runs the status updater.
1129+runStatusUpdater :: AppState -> IO ()
1130+runStatusUpdater state = do
1131+ let
1132+ pgPool = pool state
1133+ interval = 30 :: Int
1134+ selectDeps =
1135+ "SELECT name, status::text, \
1136+ \extract(epoch from now())::int - \
1137+ \extract(epoch from status_updated_at)::int \
1138+ \FROM deployments \
1139+ \WHERE checked_at < now() - interval '?' second AND status != 'Archived'"
1140+ updateStatus =
1141+ "UPDATE deployments \
1142+ \SET status = ?, status_updated_at = now(), checked_at = now() \
1143+ \WHERE name = ? and status = ?"
1144+ updateCheckedAt =
1145+ "UPDATE deployments SET checked_at = now() WHERE name = ? and status = ?"
1146+
1147+ forever $ do
1148+ rows :: [(DeploymentName, Text, Int)] <- liftIO $
1149+ withResource pgPool $ \conn -> query conn selectDeps (Only interval)
1150+ let
1151+ checkList :: [(DeploymentName, DeploymentStatus, Timestamp)] =
1152+ (\(n, s, t) -> (n, read . unpack $ s, coerce t)) <$> rows
1153+ checkResult <- for checkList $ \(dName, dStatus, ts) -> do
1154+ let
1155+ args =
1156+ [ "--project-name", unpack . coerce $ projectName state
1157+ , "--base-domain", unpack . coerce $ baseDomain state
1158+ , "--namespace", unpack . coerce $ namespace state
1159+ , "--name", unpack . coerce $ dName ]
1160+ cmd ArchivePending = unpack . coerce $ archiveCheckingCommand state
1161+ cmd _ = unpack . coerce $ checkingCommand state
1162+ timeout = statusUpdateTimeout state
1163+ ec <- runCommandWithoutPipes (cmd dStatus) args
1164+ pure (dName, newStatus ec dStatus ts timeout, ts)
1165+ void $
1166+ for (zip checkList checkResult) $ \((dName, oldSt, _), (_, newSt, _)) ->
1167+ withResource pgPool $ \conn ->
1168+ if oldSt == newSt
1169+ then execute conn updateCheckedAt (dName, show oldSt)
1170+ else execute conn updateStatus (show newSt, dName, show oldSt)
1171+ if checkList == checkResult
1172+ then pure ()
1173+ else sendReloadEvent state
1174+ threadDelay 5000000
1175+
1176+-- | Returns the new deployment status.
1177+newStatus
1178+ :: ExitCode
1179+ -> DeploymentStatus
1180+ -> Timestamp
1181+ -> Timeout
1182+ -> DeploymentStatus
1183+newStatus ExitSuccess ArchivePending _ _ = Archived
1184+newStatus ExitSuccess _ _ _ = Running
1185+newStatus (ExitFailure _) Running _ _ = Failure
1186+newStatus (ExitFailure _) CreatePending ts timeout | ts > coerce timeout =
1187+ Failure
1188+newStatus (ExitFailure _) UpdatePending ts timeout | ts > coerce timeout =
1189+ Failure
1190+newStatus (ExitFailure _) ArchivePending _ _ = ArchivePending
1191+newStatus (ExitFailure _) oldStatus _ _ = oldStatus
1192+
1193+-- | Checks if graceful shutdown has been activated activated.
1194+-- Returns 405 'Graceful shutdown activated' response
1195+-- if graceful shutdown has been activated.
1196+failIfGracefulShutdownActivated :: AppM ()
1197+failIfGracefulShutdownActivated = do
1198+ gracefulShutdownAct <- gracefulShutdownActivated <$> ask
1199+ gracefulShutdown <- liftIO . readIORef $ gracefulShutdownAct
1200+ if gracefulShutdown
1201+ then throwError err405 { errBody = appError "Graceful shutdown activated" }
1202+ else pure ()
1203+
1204+-- | Handles the graceful shutdown signal.
1205+-- Sends a signal to the 'shutdownSem' semaphore
1206+-- if the background worker counter is 0.
1207+terminationHandler :: IORef Int -> IORef Bool -> MVar () -> IO ()
1208+terminationHandler bgWorkersC gracefulShudownAct shutdownS = do
1209+ atomicWriteIORef gracefulShudownAct True
1210+ c <- readIORef bgWorkersC
1211+ if c == 0
1212+ then putMVar shutdownS ()
1213+ else pure ()
1214+
1215+-- | Waits on the 'shutdownSem' semaphore to determine when the
1216+-- server can shut down.
1217+runShutdownHandler :: AppState -> IO ()
1218+runShutdownHandler = takeMVar . shutdownSem
1219+
1220+-- | Runs background the worker and increases the background worker counter.
1221+-- Decreases background worker counter
1222+-- after the background worker exits.
1223+-- Sends a signal to 'shutdownSem' semaphore
1224+-- if the background worker counter is 0
1225+-- and graceful shutdown is activated.
1226+runBgWorker :: AppState -> IO () -> IO ()
1227+runBgWorker state act = void $ forkFinally act' cleanup
1228+ where
1229+ act' =
1230+ atomicModifyIORef' (bgWorkersCounter state) (\c -> (c + 1, c)) >> act
1231+ cleanup _ = do
1232+ c <- atomicModifyIORef' (bgWorkersCounter state) (\c -> (c - 1, c - 1))
1233+ gracefulShutdown <- readIORef (gracefulShutdownActivated state)
1234+ if gracefulShutdown && c == 0
1235+ then putMVar (shutdownSem state) ()
1236+ else pure ()