@@ -1,118 +1,119 @@
11module Octopod.Server (runOctopodServer) where
22
3−
4−import Chronos (Time, getTime, now)
5−import Control.Applicative
6−import Control.Concurrent (threadDelay)
7−import Control.Concurrent.Async (race_)
3+import Chronos (Time, getTime, now)
4+import Common.Validation (isNameValid)
5+import Control.Applicative
6+import Control.Concurrent (threadDelay)
7+import Control.Concurrent.Async (race_)
88import qualified Control.Concurrent.Lifted as L
9+import Control.Concurrent.MVar
10+import Control.Concurrent.STM
11+import Control.Exception (Exception, throwIO, try)
912import qualified Control.Exception.Lifted as L
10−import Control.Concurrent.MVar
11−import Control.Concurrent.STM
12−import Control.Exception (Exception, throwIO, try)
13−import Control.Lens hiding (pre)
14−import Control.Monad
15−import Control.Monad.Except
16−import Control.Monad.Reader
17−import Data.Aeson (Value(..), encode, toJSON)
18−import Data.ByteString (ByteString)
13+import Control.Lens hiding (Context, pre)
14+import Control.Lens.Extras
15+import Control.Monad
16+import Control.Monad.Base
17+import Control.Monad.Except
18+import Control.Monad.Reader
19+import Control.Monad.Trans.Control
20+import Control.Octopod.DeploymentLock
21+import Crypto.JOSE hiding (Context)
22+import Data.Aeson (Value (..), encode, toJSON)
23+import Data.ByteString (ByteString)
24+import qualified Data.ByteString.Char8 as BSC
1925import qualified Data.ByteString.Lazy as BSL
20−import Data.Coerce
21−import Data.Conduit (ConduitT, yield)
22−import Data.Foldable (foldrM)
23−import Data.Functor
24−import Data.Int (Int64)
25−import Data.IORef
26−import Data.Maybe
27−import Data.Pool
28−import Data.Text (lines, pack, unpack, unwords)
29−import Data.Traversable
30−import Database.PostgreSQL.Simple
31−import Database.PostgreSQL.Simple.Instances ()
32−import Network.Wai.Handler.Warp
33−import Network.Wai.Handler.WarpTLS
34−import Options.Generic
35−import PostgreSQL.ErrorCodes (unique_violation)
36−import Prelude hiding (lines, log, unlines, unwords)
37−import Servant
38−import System.Environment (lookupEnv)
39−import System.Exit
40−import System.Log.FastLogger
41−import System.Posix.Signals (sigTERM)
42−
43−
44−import Common.Validation (isNameValid)
45−import Control.Monad.Base
46−import Control.Monad.Trans.Control
47−import Control.Octopod.DeploymentLock
4826import qualified Data.ByteString.Lazy.Char8 as BSLC
49−import Data.Generics.Labels ()
27+import Data.Coerce
28+import Data.Conduit (ConduitT, yield)
29+import Data.Foldable (foldrM)
30+import Data.Functor
31+import Data.Generics.Labels ()
32+import Data.IORef
33+import Data.Int (Int64)
34+import Data.Maybe
35+import Data.Pool
36+import Data.Text (lines, pack, unpack, unwords)
5037import qualified Data.Text.Encoding as T
51−import Database.PostgreSQL.Simple.Transaction
52−import Octopod.API
53−import Octopod.PowerAPI
54−import Octopod.Server.Args
55−import Octopod.Server.ControlScriptUtils
56−import Octopod.Server.Logger
57−import Octopod.Server.Posix
58−import Orphans ()
59−import TLS (createTLSOpts)
60−import Types
61−import Control.Lens.Extras
38+import Data.Traversable
39+import Database.PostgreSQL.Simple hiding ((:.))
40+import Database.PostgreSQL.Simple.Instances ()
41+import Database.PostgreSQL.Simple.Transaction
42+import Network.Wai.Handler.Warp
43+import Octopod.API
44+import Octopod.PowerAPI
45+import Octopod.PowerAPI.Auth.Server
46+import Octopod.Server.Args
47+import Octopod.Server.ControlScriptUtils
48+import Octopod.Server.Logger
49+import Octopod.Server.Posix
50+import Options.Generic
51+import Orphans ()
52+import PostgreSQL.ErrorCodes (unique_violation)
53+import Servant
54+import Servant.Auth.Server
55+import System.Environment (lookupEnv)
56+import System.Exit
57+import System.Log.FastLogger
58+import System.Posix.Signals (sigTERM)
59+import Types
60+import Prelude hiding (lines, log, unlines, unwords)
6261
6362type PgPool = Pool Connection
64−type AppM = ReaderT AppState Handler
63+
64+type AppM = ReaderT AppState Handler
6565
6666-- | Octopod Server state definition.
6767data AppState = AppState
68− { pool :: PgPool
69− -- ^ postgres pool
70− , logger :: TimedFastLogger
71− -- ^ logger
72− , eventSink :: TChan WSEvent
73− -- ^ channel for WS events for the frontend
74− , bgWorkersCounter :: IORef Int
75− -- ^ background workers counter
76− , gracefulShutdownActivated :: IORef Bool
77− -- ^ flag of activating graceful shutdown
78− , shutdownSem :: MVar ()
79− -- ^ semaphore for graceful shutdown
80− , projectName :: ProjectName
81− -- ^ project name
82− , baseDomain :: Domain
83− -- ^ base domain
84− , namespace :: Namespace
85− -- ^ namespace
86− , archiveRetention :: ArchiveRetention
87− -- ^ archive retention
88− , statusUpdateTimeout :: Timeout
89− -- ^ status update timeout
90− , creationCommand :: Command
91− -- ^ creation command path
92− , updateCommand :: Command
93− -- ^ update command path
94− , archiveCommand :: Command
95− -- ^ deletion command path
96− , checkingCommand :: Command
97− -- ^ checking command path
98− , cleanupCommand :: Command
99− -- ^ cleanup command path
100− , archiveCheckingCommand :: Command
101− -- ^ archive checking command path
102− , tagCheckingCommand :: Command
103− -- ^ tag checking command path
68+ { -- | postgres pool
69+ pool :: PgPool
70+ , -- | logger
71+ logger :: TimedFastLogger
72+ , -- | channel for WS events for the frontend
73+ eventSink :: TChan WSEvent
74+ , -- | background workers counter
75+ bgWorkersCounter :: IORef Int
76+ , -- | flag of activating graceful shutdown
77+ gracefulShutdownActivated :: IORef Bool
78+ , -- | semaphore for graceful shutdown
79+ shutdownSem :: MVar ()
80+ , -- | project name
81+ projectName :: ProjectName
82+ , -- | base domain
83+ baseDomain :: Domain
84+ , -- | namespace
85+ namespace :: Namespace
86+ , -- | archive retention
87+ archiveRetention :: ArchiveRetention
88+ , -- | status update timeout
89+ statusUpdateTimeout :: Timeout
90+ , -- | creation command path
91+ creationCommand :: Command
92+ , -- | update command path
93+ updateCommand :: Command
94+ , -- | deletion command path
95+ archiveCommand :: Command
96+ , -- | checking command path
97+ checkingCommand :: Command
98+ , -- | cleanup command path
99+ cleanupCommand :: Command
100+ , -- | archive checking command path
101+ archiveCheckingCommand :: Command
102+ , -- | tag checking command path
103+ tagCheckingCommand :: Command
104104 , infoCommand :: Command
105105 , notificationCommand :: Maybe Command
106− , lockedDeployments :: LockedDeployments
107− -- ^ Deployments currently being processed which has not yet been
108− -- recorded in the database.
109− } deriving Generic
106+ , -- | Deployments currently being processed which has not yet been
107+ -- recorded in the database.
108+ lockedDeployments :: LockedDeployments
109+ }
110+ deriving stock (Generic)
110111
111112-- | Deployment exception definition.
112113data DeploymentException
113114 = DeploymentFailed Int
114115 | ThereIsActiveDeployment
115− deriving (Show)
116+ deriving stock (Show)
116117
117118instance Exception DeploymentException
118119
@@ -121,13 +122,13 @@ data DeploymentListType
121122 = AllDeployments
122123 | ArchivedOnlyDeployments
123124 | ActiveOnlyDeployments
124− deriving (Show)
125+ deriving stock (Show)
125126
126127-- | Full info list type definition.
127128data FullInfoListType
128129 = FullInfoForAll
129130 | FullInfoOnlyForOne DeploymentName
130− deriving (Show)
131+ deriving stock (Show)
131132
132133runOctopodServer :: IO ()
133134runOctopodServer = do
@@ -137,13 +138,11 @@ runOctopodServer = do
137138 gracefulShutdownAct <- newIORef False
138139 shutdownS <- newEmptyMVar
139140 void $ do
140− let
141− termHandler = terminationHandler bgWorkersC gracefulShutdownAct shutdownS
141+ let termHandler = terminationHandler bgWorkersC gracefulShutdownAct shutdownS
142142 installShutdownHandler logger' [sigTERM] termHandler
143143 opts <- parseArgs
144− let
145− a ?! e = a >>= maybe (die e) pure
146− getEnvOrDie eName = lookupEnv eName ?! (eName <> " is not set")
144+ let a ?! e = a >>= maybe (die e) pure
145+ getEnvOrDie eName = lookupEnv eName ?! (eName <> " is not set")
147146 projName <- coerce . pack <$> getEnvOrDie "PROJECT_NAME"
148147 domain <- coerce . pack <$> getEnvOrDie "BASE_DOMAIN"
149148 ns <- coerce . pack <$> getEnvOrDie "NAMESPACE"
@@ -157,55 +156,53 @@ runOctopodServer = do
157156 archiveCheckingCmd <- coerce . pack <$> getEnvOrDie "ARCHIVE_CHECKING_COMMAND"
158157 tagCheckingCmd <- coerce . pack <$> getEnvOrDie "TAG_CHECKING_COMMAND"
159158 infoCmd <- coerce . pack <$> getEnvOrDie "INFO_COMMAND"
160− notificationCmd <- (fmap . fmap) (Command . pack)
161− $ lookupEnv "NOTIFICATION_COMMAND" <&> \case
162− Just "" -> Nothing
163− x -> x
164− pgPool <- initConnectionPool
165− (unDBConnectionString $ octopodDB opts)
166− (unDBPoolSize $ octopodDBPoolSize opts)
159+ powerAuthorizationHeader <- AuthHeader . BSC.pack <$> getEnvOrDie "POWER_AUTHORIZATION_HEADER"
160+ notificationCmd <-
161+ (fmap . fmap) (Command . pack) $
162+ lookupEnv "NOTIFICATION_COMMAND" <&> \case
163+ Just "" -> Nothing
164+ x -> x
165+ pgPool <-
166+ initConnectionPool
167+ (unDBConnectionString $ octopodDB opts)
168+ (unDBPoolSize $ octopodDBPoolSize opts)
167169 channel <- liftIO . atomically $ newBroadcastTChan
168170 lockedDs <- initLockedDeployments
169− let
170− appSt =
171− AppState
172− pgPool
173− logger'
174− channel
175− bgWorkersC
176− gracefulShutdownAct
177− shutdownS
178− projName
179− domain
180− ns
181− archRetention
182− stUpdateTimeout
183− creationCmd
184− updateCmd
185− archiveCmd
186− checkingCmd
187− cleanupCmd
188− archiveCheckingCmd
189− tagCheckingCmd
190− infoCmd
191− notificationCmd
192− lockedDs
193− app' = app appSt
194− powerApp' = powerApp appSt
195− wsApp' = wsApp channel
196− serverPort = octopodPort opts
197− uiServerPort = unServerPort $ octopodUIPort opts
198− wsServerPort = unServerPort $ octopodWSPort opts
199− tlsOpts =
200− createTLSOpts (octopodTLSCertPath opts) (octopodTLSKeyPath opts)
201− (octopodTLSStorePath opts) serverPort
202− warpOpts = setPort (unServerPort serverPort) defaultSettings
203− in
204− (run uiServerPort app')
205− `race_` (runTLS tlsOpts warpOpts powerApp')
206− `race_` (run wsServerPort wsApp')
207− `race_` (runStatusUpdater appSt)
208− `race_` (runShutdownHandler appSt)
171+ let appSt =
172+ AppState
173+ pgPool
174+ logger'
175+ channel
176+ bgWorkersC
177+ gracefulShutdownAct
178+ shutdownS
179+ projName
180+ domain
181+ ns
182+ archRetention
183+ stUpdateTimeout
184+ creationCmd
185+ updateCmd
186+ archiveCmd
187+ checkingCmd
188+ cleanupCmd
189+ archiveCheckingCmd
190+ tagCheckingCmd
191+ infoCmd
192+ notificationCmd
193+ lockedDs
194+ app' = app appSt
195+ wsApp' = wsApp channel
196+ serverPort = octopodPort opts
197+ uiServerPort = unServerPort $ octopodUIPort opts
198+ powerServerPort = unServerPort serverPort
199+ wsServerPort = unServerPort $ octopodWSPort opts
200+ powerApp' <- powerApp powerAuthorizationHeader appSt
201+ (run uiServerPort app')
202+ `race_` (run powerServerPort powerApp')
203+ `race_` (run wsServerPort wsApp')
204+ `race_` (runStatusUpdater appSt)
205+ `race_` (runShutdownHandler appSt)
209206
210207-- | Initializes the connection pool.
211208initConnectionPool :: ByteString -> Int -> IO PgPool
@@ -226,21 +223,46 @@ app s = serve api $ hoistServer api (nt s) server
226223server :: ServerT API AppM
227224server =
228225 ( listH :<|> createH :<|> archiveH :<|> updateH
229− :<|> infoH :<|> fullInfoH :<|> statusH :<|> restoreH
230− ) :<|> pingH :<|> projectNameH
226+ :<|> infoH
227+ :<|> fullInfoH
228+ :<|> statusH
229+ :<|> restoreH
230+ )
231+ :<|> pingH
232+ :<|> projectNameH
231233
232234-- | Application with the octo CLI API.
233−powerApp :: AppState -> Application
234−powerApp s = serve api $ hoistServer api (nt s) powerServer
235+powerApp :: AuthHeader -> AppState -> IO Application
236+powerApp h s = do
237+ jwk' <- liftIO $ genJWK (RSAGenParam (4096 `div` 8))
238+ let ctx :: Context Ctx
239+ ctx =
240+ h
241+ :. (defaultJWTSettings jwk' :: JWTSettings)
242+ :. (defaultCookieSettings :: CookieSettings)
243+ :. EmptyContext
244+
245+ return $
246+ serveWithContext api ctx $
247+ hoistServerWithContext api (Proxy @Ctx) (nt s) powerServer
235248 where
236249 api = Proxy @PowerAPI
237250
251+type Ctx = '[AuthHeader, JWTSettings, CookieSettings]
252+
238253-- | Request handlers of application with the octo CLI API.
239254powerServer :: ServerT PowerAPI AppM
240−powerServer =
255+powerServer (Authenticated ()) =
241256 ( powerListH :<|> createH :<|> archiveH :<|> updateH
242− :<|> powerInfoH :<|> powerFullInfoH :<|> statusH :<|> cleanupH :<|> restoreH
243− ) :<|> getActionInfoH :<|> cleanArchiveH
257+ :<|> powerInfoH
258+ :<|> powerFullInfoH
259+ :<|> statusH
260+ :<|> cleanupH
261+ :<|> restoreH
262+ )
263+ :<|> getActionInfoH
264+ :<|> cleanArchiveH
265+powerServer _ = throwAll err401
244266
245267-- | Application with the WS API.
246268wsApp :: TChan WSEvent -> Application
@@ -269,16 +291,21 @@ powerListH :: AppM [DeploymentFullInfo]
269291powerListH = getFullInfo FullInfoForAll
270292
271293-- | Handles the 'full_info' request of the Web UI API.
272−fullInfoH
273− :: (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m)
274− => DeploymentName -> m DeploymentFullInfo
294+fullInfoH ::
295+ (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>
296+ DeploymentName ->
297+ m DeploymentFullInfo
275298fullInfoH dName = do
276− fullInfoList <- hidePrivateOverridesInFullInfos <$>
277− getFullInfo (FullInfoOnlyForOne dName)
299+ fullInfoList <-
300+ hidePrivateOverridesInFullInfos
301+ <$> getFullInfo (FullInfoOnlyForOne dName)
278302 case fullInfoList of
279303 fullInfo : _ -> pure fullInfo
280− [] -> throwError err404
281− { errBody = validationError ["Name not found"] [] }
304+ [] ->
305+ throwError
306+ err404
307+ { errBody = validationError ["Name not found"] []
308+ }
282309
283310-- | Handles the 'full_info' request of the octo CLI API.
284311powerFullInfoH :: DeploymentName -> AppM DeploymentFullInfo
@@ -286,64 +313,66 @@ powerFullInfoH dName = do
286313 fullInfoList <- getFullInfo $ FullInfoOnlyForOne dName
287314 case fullInfoList of
288315 fullInfo : _ -> pure fullInfo
289− [] -> throwError err404
290− { errBody = validationError ["Name not found"] [] }
316+ [] ->
317+ throwError
318+ err404
319+ { errBody = validationError ["Name not found"] []
320+ }
291321
292322-- | Hides private overrides in 'full_info' response.
293323hidePrivateOverridesInFullInfos :: [DeploymentFullInfo] -> [DeploymentFullInfo]
294−hidePrivateOverridesInFullInfos dFullInfos = do
324+hidePrivateOverridesInFullInfos dFullInfos = do
295325 dFullInfos <&> \(DeploymentFullInfo dep s ct ut u) ->
296− let
297− hidePrivate (Deployment n t appOvs depOvs) =
298− Deployment n t (hideP appOvs) (hideP depOvs)
299− hideP o =
300− coerce o <&> \(Override k v vis) ->
301− let
302− v' = case vis of
303− Private -> "*"
304− Public -> v
305− in coerce $ Override k v' vis
306− in DeploymentFullInfo (hidePrivate dep) s ct ut u
307−
308−getFullInfo
309− :: (MonadReader AppState m, MonadBaseControl IO m)
310− => FullInfoListType
311− -> m [DeploymentFullInfo]
326+ let hidePrivate (Deployment n t appOvs depOvs) =
327+ Deployment n t (hideP appOvs) (hideP depOvs)
328+ hideP o =
329+ coerce o <&> \(Override k v vis) ->
330+ let v' = case vis of
331+ Private -> "*"
332+ Public -> v
333+ in coerce $ Override k v' vis
334+ in DeploymentFullInfo (hidePrivate dep) s ct ut u
335+
336+getFullInfo ::
337+ (MonadReader AppState m, MonadBaseControl IO m) =>
338+ FullInfoListType ->
339+ m [DeploymentFullInfo]
312340getFullInfo lType = do
313341 p <- asks pool
314342 liftBaseOp (withResource p) $ \conn -> getFullInfo' conn lType
315343
316344-- | Helper to get full_info from the database.
317−getFullInfo'
318− :: (MonadReader AppState m, MonadBase IO m)
319− => Connection
320− -> FullInfoListType
321− -> m [DeploymentFullInfo]
345+getFullInfo' ::
346+ (MonadReader AppState m, MonadBase IO m) =>
347+ Connection ->
348+ FullInfoListType ->
349+ m [DeploymentFullInfo]
322350getFullInfo' conn listType = do
323351 AppState {logger = l} <- ask
324352 deployments <- do
325353 rows <- case listType of
326354 FullInfoForAll -> liftBase $ query_ conn qAll
327− FullInfoOnlyForOne dName -> liftBase $ query conn qOne (Only dName)
355+ FullInfoOnlyForOne dName -> liftBase $ query conn qOne (Only dName)
328356 for rows $ \(n, t, ct, ut, st) -> do
329− (appOvs, depOvs) <- liftBase $ selectOverrides conn n
330− dMeta <- liftBase $ selectDeploymentMetadata conn n
331− st' <- isDeploymentLocked n <&> \case
332− True -> DeploymentPending st
333− False -> DeploymentNotPending st
357+ (appOvs, depOvs) <- liftBase $ selectOverrides conn n
358+ dMeta <- liftBase $ selectDeploymentMetadata conn n
359+ st' <-
360+ isDeploymentLocked n <&> \case
361+ True -> DeploymentPending st
362+ False -> DeploymentNotPending st
334363 pure $ do
335364 let dep = Deployment n t appOvs depOvs
336365 DeploymentFullInfo dep st' dMeta ct ut
337366 liftBase . logInfo l $ "get deployments: " <> (pack . show $ deployments)
338367 return deployments
339368 where
340− qAll =
369+ qAll =
341370 "SELECT name, tag, extract(epoch from created_at)::int, \
342− \extract(epoch from updated_at)::int, status \
371+ \extract(epoch from updated_at)::int, status \
343372 \FROM deployments ORDER BY name"
344− qOne =
373+ qOne =
345374 "SELECT name, tag, extract(epoch from created_at)::int, \
346− \extract(epoch from updated_at)::int, status \
375+ \extract(epoch from updated_at)::int, status \
347376 \FROM deployments \
348377 \WHERE name = ?"
349378
@@ -352,39 +381,46 @@ createH :: Deployment -> AppM CommandResponse
352381createH dep = do
353382 failIfGracefulShutdownActivated
354383 unless (isNameValid $ name dep) $ do
355− let
356− badNameText =
357− "Deployment name length should be longer than 2 characters, \
358− \under 17 characters and begin with a letter."
359− throwError err400
360− { errBody = validationError [badNameText] [] }
384+ let badNameText =
385+ "Deployment name length should be longer than 2 characters, \
386+ \under 17 characters and begin with a letter."
387+ throwError
388+ err400
389+ { errBody = validationError [badNameText] []
390+ }
361391 t1 <- liftIO $ now
362392 st <- ask
363393 let pgPool = pool st
364394 failIfImageNotFound (name dep) (tag dep)
365395 failIfGracefulShutdownActivated
366− runDeploymentBgWorker Nothing (name dep)
396+ runDeploymentBgWorker
397+ Nothing
398+ (name dep)
367399 ( do
368− let
369− q =
370− "INSERT INTO deployments (name, tag, status) \
371− \VALUES (?, ?, ?) RETURNING id"
372− createDep :: PgPool -> Deployment -> IO [Only Int]
373− createDep p Deployment { name = n, tag = t } =
374− withResource p $ \conn ->
375− query conn q (n, t, CreatePending)
376− res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep
377− case res of
378− Right ((Only depId) : _) ->
379− pure . DeploymentId $ depId
380− Right [] ->
381− throwError err404
382− { errBody = validationError ["Name not found"] [] }
383− Left (SqlError code _ _ _ _) | code == unique_violation ->
384− throwError err400
385− { errBody = validationError ["Deployment already exists"] [] }
386− Left (SqlError _ _ _ _ _) ->
387− throwError err409 { errBody = appError "Some database error" }
400+ let q =
401+ "INSERT INTO deployments (name, tag, status) \
402+ \VALUES (?, ?, ?) RETURNING id"
403+ createDep :: PgPool -> Deployment -> IO [Only Int]
404+ createDep p Deployment {name = n, tag = t} =
405+ withResource p $ \conn ->
406+ query conn q (n, t, CreatePending)
407+ res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep
408+ case res of
409+ Right ((Only depId) : _) ->
410+ pure . DeploymentId $ depId
411+ Right [] ->
412+ throwError
413+ err404
414+ { errBody = validationError ["Name not found"] []
415+ }
416+ Left (SqlError code _ _ _ _)
417+ | code == unique_violation ->
418+ throwError
419+ err400
420+ { errBody = validationError ["Deployment already exists"] []
421+ }
422+ Left (SqlError _ _ _ _ _) ->
423+ throwError err409 {errBody = appError "Some database error"}
388424 )
389425 $ \dId -> do
390426 liftIO . withResource pgPool $ \conn ->
@@ -393,9 +429,8 @@ createH dep = do
393429 liftBase $ updateDeploymentInfo (name dep) st
394430 (ec, out, err) <- liftBase $ createDeployment dep st
395431 t2 <- liftBase $ now
396− let
397− elTime = elapsedTime t2 t1
398− liftIO . withResource pgPool $ \conn ->
432+ let elTime = elapsedTime t2 t1
433+ withResource pgPool $ \conn ->
399434 -- calling it directly now is fine since there is no previous status.
400435 createDeploymentLog conn dep "create" ec elTime out err
401436 liftBase $ sendReloadEvent st
@@ -405,10 +440,9 @@ createH dep = do
405440-- | Updates deployment info.
406441updateDeploymentInfo :: DeploymentName -> AppState -> IO ()
407442updateDeploymentInfo dName st = do
408− let
409− log = logWarning (logger st)
410− args = infoCommandArgs (projectName st) (baseDomain st) (namespace st) dName
411− cmd = coerce $ infoCommand st
443+ let log = logWarning (logger st)
444+ args = infoCommandArgs (projectName st) (baseDomain st) (namespace st) dName
445+ cmd = coerce $ infoCommand st
412446 liftIO $ do
413447 (ec, out, err) <- runCommand (unpack cmd) (coerce args)
414448 case ec of
@@ -418,23 +452,31 @@ updateDeploymentInfo dName st = do
418452 ExitFailure _ ->
419453 log $
420454 "could not get deployment info, exit code: " <> (pack . show $ ec)
421− <> ", stdout: " <> coerce out <> "stderr: " <> coerce err
455+ <> ", stdout: "
456+ <> coerce out
457+ <> "stderr: "
458+ <> coerce err
422459
423460-- | Helper to create a new deployment.
424461createDeployment :: Deployment -> AppState -> IO (ExitCode, Stdout, Stderr)
425462createDeployment dep st = do
426− let
427− log :: Text -> IO ()
428− log = logInfo (logger st)
429− args =
430− [ "--project-name", coerce $ projectName st
431− , "--base-domain", coerce $ baseDomain st
432− , "--namespace", coerce $ namespace st
433− , "--name", coerce $ name dep
434− , "--tag", coerce $ tag dep
435− ] ++ applicationOverridesToArgs (appOverrides dep)
436− ++ deploymentOverridesToArgs (deploymentOverrides dep)
437− cmd = coerce $ creationCommand st
463+ let log :: Text -> IO ()
464+ log = logInfo (logger st)
465+ args =
466+ [ "--project-name"
467+ , coerce $ projectName st
468+ , "--base-domain"
469+ , coerce $ baseDomain st
470+ , "--namespace"
471+ , coerce $ namespace st
472+ , "--name"
473+ , coerce $ name dep
474+ , "--tag"
475+ , coerce $ tag dep
476+ ]
477+ ++ applicationOverridesToArgs (appOverrides dep)
478+ ++ deploymentOverridesToArgs (deploymentOverrides dep)
479+ cmd = coerce $ creationCommand st
438480
439481 liftIO $ do
440482 log $ "call " <> unwords (cmd : args)
@@ -448,7 +490,7 @@ applicationOverrideToArg o = ["--app-env-override", overrideToArg . coerce $ o]
448490
449491-- | Helper to convert an application-level override to command arguments.
450492applicationOverridesToArgs :: ApplicationOverrides -> [Text]
451−applicationOverridesToArgs ovs = concat [applicationOverrideToArg o | o <- ovs ]
493+applicationOverridesToArgs ovs = concat [applicationOverrideToArg o | o <- ovs]
452494
453495-- | Converts a deployment-level override list to command arguments.
454496deploymentOverrideToArg :: DeploymentOverride -> [Text]
@@ -460,19 +502,18 @@ deploymentOverridesToArgs :: DeploymentOverrides -> [Text]
460502deploymentOverridesToArgs ovs = concat [deploymentOverrideToArg o | o <- ovs]
461503
462504-- | Helper to get deployment logs.
463−selectDeploymentLogs
464− :: PgPool
465− -> DeploymentId
466− -> IO [DeploymentLog]
505+selectDeploymentLogs ::
506+ PgPool ->
507+ DeploymentId ->
508+ IO [DeploymentLog]
467509selectDeploymentLogs pgPool dId = do
468− let
469− q =
470− "SELECT id, action::text, tag, exit_code, \
510+ let q =
511+ "SELECT id, action::text, tag, exit_code, \
471512 \duration, extract(epoch from created_at)::int \
472− \FROM deployment_logs \
473− \WHERE deployment_id = ? \
474− \ORDER BY created_at DESC \
475− \LIMIT 20"
513+ \FROM deployment_logs \
514+ \WHERE deployment_id = ? \
515+ \ORDER BY created_at DESC \
516+ \LIMIT 20"
476517 withResource pgPool $ \conn -> do
477518 rows <- query conn q (Only . unDeploymentId $ dId)
478519 -- FIXME: use FromRow instance instead
@@ -481,9 +522,9 @@ selectDeploymentLogs pgPool dId = do
481522 pure $ DeploymentLog (ActionId ai) a t appOvs depOvs ec (Duration d) ts
482523
483524-- | Helper to get a deployment.
484−selectDeployment
485− :: DeploymentName
486− -> AppM Deployment
525+selectDeployment ::
526+ DeploymentName ->
527+ AppM Deployment
487528selectDeployment dName = do
488529 pgPool <- asks pool
489530 let q = "SELECT name, tag FROM deployments WHERE name = ?"
@@ -501,7 +542,8 @@ data StatusTransitionProcessOutput = StatusTransitionProcessOutput
501542 , duration :: Duration
502543 , stdout :: Stdout
503544 , stderr :: Stderr
504− } deriving (Generic, Show)
545+ }
546+ deriving stock (Generic, Show)
505547
506548data DeploymentStatusTransition
507549 = TransitionArchived
@@ -512,7 +554,7 @@ data DeploymentStatusTransition
512554 | TransitionUpdatePending StatusTransitionProcessOutput
513555 | TransitionCreatePending StatusTransitionProcessOutput
514556 | TransitionFailure FailureType
515− deriving Show
557+ deriving stock (Show)
516558
517559transitionStatus :: DeploymentStatusTransition -> DeploymentStatus
518560transitionStatus TransitionArchived {} = Archived
@@ -534,107 +576,125 @@ processOutput (TransitionUpdatePending x) = Just (x, Action "update")
534576processOutput (TransitionCreatePending x) = Just (x, Action "create")
535577processOutput TransitionFailure {} = Nothing
536578
537−transitionToStatusS
538− :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m)
539− => DeploymentName -> DeploymentStatusTransition -> m ()
579+transitionToStatusS ::
580+ (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m, MonadIO m) =>
581+ DeploymentName ->
582+ DeploymentStatusTransition ->
583+ m ()
540584transitionToStatusS dName tran =
541585 runExceptT (transitionToStatus dName tran) >>= transitionErrorToServerError
542586
543587transitionErrorToServerError :: MonadError ServerError m => Either StatusTransitionError a -> m a
544588transitionErrorToServerError = \case
545589 Right x -> return x
546− Left (InvalidStatusTransition dName a b) -> throwError err409
547− { errBody
548− = "Unable to transition deployment "
549− <> (BSL.fromStrict . T.encodeUtf8 . unDeploymentName) dName
550− <> " from " <> show'' a <> " to " <> show'' b <> "."
551− }
552− Left (DeploymentNotFound dName) -> throwError err404
553− { errBody
554− = "Couldn't find deployment "
555− <> (BSL.fromStrict . T.encodeUtf8 . unDeploymentName) dName <> "."
556− }
590+ Left (InvalidStatusTransition dName a b) ->
591+ throwError
592+ err409
593+ { errBody =
594+ "Unable to transition deployment "
595+ <> (BSL.fromStrict . T.encodeUtf8 . unDeploymentName) dName
596+ <> " from "
597+ <> show'' a
598+ <> " to "
599+ <> show'' b
600+ <> "."
601+ }
602+ Left (DeploymentNotFound dName) ->
603+ throwError
604+ err404
605+ { errBody =
606+ "Couldn't find deployment "
607+ <> (BSL.fromStrict . T.encodeUtf8 . unDeploymentName) dName
608+ <> "."
609+ }
557610 where
558611 show'' = BSLC.pack . show
559612
560−getDeploymentS
561− :: (MonadReader AppState m, MonadBase IO m, MonadError ServerError m)
562− => Connection -> DeploymentName -> m DeploymentFullInfo
563−getDeploymentS conn dName = (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case
564− [x] -> return x
565− _ -> throwError err404 {errBody = "Deployment not found."}
613+getDeploymentS ::
614+ (MonadReader AppState m, MonadBase IO m, MonadError ServerError m) =>
615+ Connection ->
616+ DeploymentName ->
617+ m DeploymentFullInfo
618+getDeploymentS conn dName =
619+ (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case
620+ [x] -> return x
621+ _ -> throwError err404 {errBody = "Deployment not found."}
566622
567−transitionToStatus
568− :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m)
569− => DeploymentName -> DeploymentStatusTransition -> ExceptT StatusTransitionError m ()
623+transitionToStatus ::
624+ (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m, MonadIO m) =>
625+ DeploymentName ->
626+ DeploymentStatusTransition ->
627+ ExceptT StatusTransitionError m ()
570628transitionToStatus dName s = do
571629 p <- asks pool
572630 st <- ask
573631 let log = liftBase . logInfo (logger st)
574632 (oldS, newS, dep :: DeploymentFullInfo) <- withResource p $ \conn -> liftBaseOp_ (withTransaction conn) $ do
575633 dep <- lift $ getDeploymentS conn dName
576− let
577− oldS = recordedStatus $ dep ^. #status
578− newS = transitionStatus s
634+ let oldS = recordedStatus $ dep ^. #status
635+ newS = transitionStatus s
579636 assertStatusTransitionPossible dName oldS newS
580637 log $ "Transitioning deployment " <> (show' . unDeploymentName) dName <> " " <> show' s
581− let
582− q =
583− "UPDATE deployments \
584− \SET status = ?, status_updated_at = now() "
585− <> (if newS == ArchivePending then ", archived_at = now()" else mempty)
586− <> " WHERE name = ?"
638+ let q =
639+ "UPDATE deployments \
640+ \SET status = ?, status_updated_at = now() "
641+ <> (if newS == ArchivePending then ", archived_at = now()" else mempty)
642+ <> " WHERE name = ?"
587643 void . liftBase $ execute conn q (newS, dName)
588− liftBase $ forM_ (processOutput s) $ \(output, act) ->
589− createDeploymentLog
590− conn
591− (dep ^. #deployment)
592− act
593− (output ^. #exitCode)
594− (output ^. #duration)
595− (output ^. #stdout)
596− (output ^. #stderr)
644+ lift $
645+ forM_ (processOutput s) $ \(output, act) ->
646+ createDeploymentLog
647+ conn
648+ (dep ^. #deployment)
649+ act
650+ (output ^. #exitCode)
651+ (output ^. #duration)
652+ (output ^. #stdout)
653+ (output ^. #stderr)
597654 return (oldS, newS, dep)
598655 notificationCmd <- asks notificationCommand
599656 forM_ notificationCmd $ \nCmd ->
600− runBgWorker . void $ runCommandArgs' nCmd
601− =<< notificationCommandArgs dName (dep ^. #deployment . #tag) oldS newS
657+ runBgWorker . void $
658+ runCommandArgs' nCmd
659+ =<< notificationCommandArgs dName (dep ^. #deployment . #tag) oldS newS
602660 liftBase $ sendReloadEvent st
603661
604−assertStatusTransitionPossible
605− :: MonadError StatusTransitionError m
606− => DeploymentName
607− -> DeploymentStatus
608− -> DeploymentStatus
609− -> m ()
662+assertStatusTransitionPossible ::
663+ MonadError StatusTransitionError m =>
664+ DeploymentName ->
665+ DeploymentStatus ->
666+ DeploymentStatus ->
667+ m ()
610668assertStatusTransitionPossible dName old new =
611669 unless
612670 (possibleTransitions old new)
613671 (throwError $ InvalidStatusTransition dName old new)
614672
615−assertDeploymentTransitionPossible
616− :: (MonadError StatusTransitionError m, MonadReader AppState m, MonadBaseControl IO m)
617− => DeploymentName
618− -> DeploymentStatus
619− -> m ()
673+assertDeploymentTransitionPossible ::
674+ (MonadError StatusTransitionError m, MonadReader AppState m, MonadBaseControl IO m) =>
675+ DeploymentName ->
676+ DeploymentStatus ->
677+ m ()
620678assertDeploymentTransitionPossible dName new = do
621679 p <- asks pool
622− dep <- withResource p $ \conn -> (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case
623− [x] -> return x
624− _ -> throwError $ DeploymentNotFound dName
680+ dep <- withResource p $ \conn ->
681+ (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case
682+ [x] -> return x
683+ _ -> throwError $ DeploymentNotFound dName
625684 assertStatusTransitionPossible dName (recordedStatus $ dep ^. #status) new
626685
627−assertDeploymentTransitionPossibleS
628− :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m)
629− => DeploymentName
630− -> DeploymentStatus
631− -> m ()
686+assertDeploymentTransitionPossibleS ::
687+ (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) =>
688+ DeploymentName ->
689+ DeploymentStatus ->
690+ m ()
632691assertDeploymentTransitionPossibleS dName new =
633692 runExceptT (assertDeploymentTransitionPossible dName new) >>= transitionErrorToServerError
693+
634694data StatusTransitionError
635695 = InvalidStatusTransition DeploymentName DeploymentStatus DeploymentStatus
636696 | DeploymentNotFound DeploymentName
637− deriving Show
697+ deriving stock (Show)
638698
639699possibleTransitions :: DeploymentStatus -> DeploymentStatus -> Bool
640700possibleTransitions CreatePending = anyPred [is #_Running, is #_Failure]
@@ -653,26 +713,31 @@ archiveH dName = do
653713 failIfGracefulShutdownActivated
654714 t1 <- liftBase now
655715 st <- ask
656− let
657− log = liftBase . logInfo (logger st)
658− args =
659− [ "--project-name", coerce $ projectName st
660− , "--base-domain", coerce $ baseDomain st
661− , "--namespace", coerce $ namespace st
662− , "--name", coerce dName
663− ]
664− cmd = coerce $ archiveCommand st
716+ let log = liftBase . logInfo (logger st)
717+ args =
718+ [ "--project-name"
719+ , coerce $ projectName st
720+ , "--base-domain"
721+ , coerce $ baseDomain st
722+ , "--namespace"
723+ , coerce $ namespace st
724+ , "--name"
725+ , coerce dName
726+ ]
727+ cmd = coerce $ archiveCommand st
665728 runDeploymentBgWorker (Just ArchivePending) dName (pure ()) $ \() -> do
666729 log $ "call " <> unwords (cmd : args)
667730 (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
668731 t2 <- liftBase now
669732 let elTime = elapsedTime t2 t1
670− transitionToStatusS dName $ TransitionArchivePending StatusTransitionProcessOutput
671− { exitCode = ec
672− , duration = elTime
673− , stdout = out
674− , stderr = err
675− }
733+ transitionToStatusS dName $
734+ TransitionArchivePending
735+ StatusTransitionProcessOutput
736+ { exitCode = ec
737+ , duration = elTime
738+ , stdout = out
739+ , stderr = err
740+ }
676741 handleExitCode ec
677742 pure Success
678743
@@ -682,16 +747,15 @@ updateH dName dUpdate = do
682747 failIfGracefulShutdownActivated
683748 t1 <- liftIO $ now
684749 st <- ask
685− let
686− DeploymentUpdate
687− { newTag = dTag
688− , newAppOverrides = newAppOvs
689− , oldAppOverrides = oldAppOvs
690− , newDeploymentOverrides = newDepOvs
691− , oldDeploymentOverrides = oldDepOvs
692− } = dUpdate
693− pgPool = pool st
694− log = logInfo (logger st)
750+ let DeploymentUpdate
751+ { newTag = dTag
752+ , newAppOverrides = newAppOvs
753+ , oldAppOverrides = oldAppOvs
754+ , newDeploymentOverrides = newDepOvs
755+ , oldDeploymentOverrides = oldDepOvs
756+ } = dUpdate
757+ pgPool = pool st
758+ log = logInfo (logger st)
695759 dId <- selectDeploymentId pgPool dName
696760 failIfImageNotFound dName dTag
697761 failIfGracefulShutdownActivated
@@ -704,157 +768,169 @@ updateH dName dUpdate = do
704768 selectOverrides conn dName
705769 liftBase $ updateDeploymentInfo dName st
706770 liftBase $ sendReloadEvent st
707− let
708− args =
709− [ "--project-name", coerce $ projectName st
710− , "--base-domain", coerce $ baseDomain st
711− , "--namespace", coerce $ namespace st
712− , "--name", coerce $ dName
713− , "--tag", coerce $ dTag
714− ] ++ applicationOverridesToArgs appOvs
715− ++ deploymentOverridesToArgs depOvs
716− cmd = coerce $ updateCommand st
771+ let args =
772+ [ "--project-name"
773+ , coerce $ projectName st
774+ , "--base-domain"
775+ , coerce $ baseDomain st
776+ , "--namespace"
777+ , coerce $ namespace st
778+ , "--name"
779+ , coerce $ dName
780+ , "--tag"
781+ , coerce $ dTag
782+ ]
783+ ++ applicationOverridesToArgs appOvs
784+ ++ deploymentOverridesToArgs depOvs
785+ cmd = coerce $ updateCommand st
717786 liftBase . log $ "call " <> unwords (cmd : args)
718787 (ec, out, err) <- liftBase $ runCommand (unpack cmd) (unpack <$> args)
719− liftBase . log $ "deployment updated, name: "
720− <> coerce dName <> ", tag: " <> coerce dTag
788+ liftBase . log $
789+ "deployment updated, name: "
790+ <> coerce dName
791+ <> ", tag: "
792+ <> coerce dTag
721793 t2 <- liftBase now
722794 let elTime = elapsedTime t2 t1
723− transitionToStatusS dName $ TransitionUpdatePending StatusTransitionProcessOutput
724− { exitCode = ec
725− , duration = elTime
726− , stdout = out
727− , stderr = err
728− }
795+ transitionToStatusS dName $
796+ TransitionUpdatePending
797+ StatusTransitionProcessOutput
798+ { exitCode = ec
799+ , duration = elTime
800+ , stdout = out
801+ , stderr = err
802+ }
729803 handleExitCode ec
730804 return Success
731805
732806-- | Helper to get overrides from the database.
733−selectOverrides
734− :: Connection
735− -> DeploymentName
736− -> IO (ApplicationOverrides, DeploymentOverrides)
807+selectOverrides ::
808+ Connection ->
809+ DeploymentName ->
810+ IO (ApplicationOverrides, DeploymentOverrides)
737811selectOverrides conn dName = do
738− let
739− q =
740− "SELECT key, value, scope::text, visibility::text \
741− \FROM deployment_overrides \
742− \WHERE deployment_id = ( \
812+ let q =
813+ "SELECT key, value, scope::text, visibility::text \
814+ \FROM deployment_overrides \
815+ \WHERE deployment_id = ( \
743816 \SELECT id FROM deployments WHERE name = ? \
744− \)"
745− parseVis :: Text -> OverrideVisibility
746− parseVis = read . unpack
747− parseScope :: Text -> OverrideScope
748− parseScope = read . unpack
749− toOverrides (k, v, s, vis) (appOvs, depOvs) =
750− pure $ case parseScope s of
751− ApplicationScope ->
752− (ApplicationOverride (Override k v $ parseVis vis) : appOvs, depOvs)
753− DeploymentScope ->
754− (appOvs, DeploymentOverride (Override k v $ parseVis vis) : depOvs)
817+ \)"
818+ parseVis :: Text -> OverrideVisibility
819+ parseVis = read . unpack
820+ parseScope :: Text -> OverrideScope
821+ parseScope = read . unpack
822+ toOverrides (k, v, s, vis) (appOvs, depOvs) =
823+ pure $ case parseScope s of
824+ ApplicationScope ->
825+ (ApplicationOverride (Override k v $ parseVis vis) : appOvs, depOvs)
826+ DeploymentScope ->
827+ (appOvs, DeploymentOverride (Override k v $ parseVis vis) : depOvs)
755828 rows <- query conn q (Only dName)
756829 foldrM toOverrides ([], []) rows
757830
758831-- | Helper to get override logs from the database.
759−selectLogOverrides
760− :: Connection
761− -> ActionId
762− -> IO (ApplicationOverrides, DeploymentOverrides)
832+selectLogOverrides ::
833+ Connection ->
834+ ActionId ->
835+ IO (ApplicationOverrides, DeploymentOverrides)
763836selectLogOverrides conn aId = do
764− let
765− q =
766− "SELECT key, value, scope::text, visibility::text \
767− \FROM deployment_log_overrides \
768− \WHERE deployment_log_id = ?"
769− parseVis :: Text -> OverrideVisibility
770− parseVis = read . unpack
771− parseScope :: Text -> OverrideScope
772− parseScope = read . unpack
773− toOverrides (k, v, s, vis) (appOvs, depOvs) =
774− pure $ case parseScope s of
775− ApplicationScope ->
776− (ApplicationOverride (Override k v $ parseVis vis) : appOvs, depOvs)
777− DeploymentScope ->
778− (appOvs, DeploymentOverride (Override k v $ parseVis vis) : depOvs)
837+ let q =
838+ "SELECT key, value, scope::text, visibility::text \
839+ \FROM deployment_log_overrides \
840+ \WHERE deployment_log_id = ?"
841+ parseVis :: Text -> OverrideVisibility
842+ parseVis = read . unpack
843+ parseScope :: Text -> OverrideScope
844+ parseScope = read . unpack
845+ toOverrides (k, v, s, vis) (appOvs, depOvs) =
846+ pure $ case parseScope s of
847+ ApplicationScope ->
848+ (ApplicationOverride (Override k v $ parseVis vis) : appOvs, depOvs)
849+ DeploymentScope ->
850+ (appOvs, DeploymentOverride (Override k v $ parseVis vis) : depOvs)
779851 rows <- query conn q (Only . unActionId $ aId)
780852 foldrM toOverrides ([], []) rows
781853
782854-- | Helper to delete overrides from the database.
783−deleteOldOverrides
784− :: Connection
785− -> DeploymentId
786− -> ApplicationOverrides
787− -> DeploymentOverrides
788− -> IO ()
855+deleteOldOverrides ::
856+ Connection ->
857+ DeploymentId ->
858+ ApplicationOverrides ->
859+ DeploymentOverrides ->
860+ IO ()
789861deleteOldOverrides conn dId appOvs depOvs = do
790− let
791− q =
792− "DELETE FROM deployment_overrides \
793− \WHERE deployment_id = ? AND key = ? AND scope = ?"
794− dId' = unDeploymentId dId
795− void $ for appOvs $ \o -> do
796− let
797− oKey = overrideKey . unApplicationOverride $ o
798− oScope = show ApplicationScope
799− execute conn q (dId', oKey, oScope)
800− void $ for depOvs $ \o -> do
801− let
802− oKey = overrideKey . unDeploymentOverride $ o
803− oScope = show DeploymentScope
804− execute conn q (dId', oKey, oScope)
862+ let q =
863+ "DELETE FROM deployment_overrides \
864+ \WHERE deployment_id = ? AND key = ? AND scope = ?"
865+ dId' = unDeploymentId dId
866+ void $
867+ for appOvs $ \o -> do
868+ let oKey = overrideKey . unApplicationOverride $ o
869+ oScope = show ApplicationScope
870+ execute conn q (dId', oKey, oScope)
871+ void $
872+ for depOvs $ \o -> do
873+ let oKey = overrideKey . unDeploymentOverride $ o
874+ oScope = show DeploymentScope
875+ execute conn q (dId', oKey, oScope)
805876
806877-- | Helper to get the deployment id from the database.
807878selectDeploymentId :: PgPool -> DeploymentName -> AppM DeploymentId
808879selectDeploymentId pgPool dName = do
809− dIds :: [(Only Int)] <- liftIO $ withResource pgPool $ \conn ->
810− query conn "SELECT id FROM deployments WHERE name = ?" (Only dName)
880+ dIds :: [(Only Int)] <- liftIO $
881+ withResource pgPool $ \conn ->
882+ query conn "SELECT id FROM deployments WHERE name = ?" (Only dName)
811883 case dIds of
812884 [(Only dId)] -> pure . DeploymentId $ dId
813− [] -> throwError err404
814− { errBody = validationError ["Name not found"] [] }
815− _ -> throwError err406
816− { errBody = validationError ["More than one name found"] [] }
885+ [] ->
886+ throwError
887+ err404
888+ { errBody = validationError ["Name not found"] []
889+ }
890+ _ ->
891+ throwError
892+ err406
893+ { errBody = validationError ["More than one name found"] []
894+ }
817895
818896-- | Helper to insert or update overrides.
819−upsertNewOverrides
820− :: Connection
821− -> DeploymentId
822− -> ApplicationOverrides
823− -> DeploymentOverrides
824− -> IO ()
897+upsertNewOverrides ::
898+ Connection ->
899+ DeploymentId ->
900+ ApplicationOverrides ->
901+ DeploymentOverrides ->
902+ IO ()
825903upsertNewOverrides conn dId appOvs depOvs = do
826− let
827− q =
828− "INSERT INTO deployment_overrides \
829− \(key, value, deployment_id, scope, visibility) \
830− \VALUES (?, ?, ?, ?, ?) \
831− \ON CONFLICT (key, deployment_id, scope) \
832− \DO \
904+ let q =
905+ "INSERT INTO deployment_overrides \
906+ \(key, value, deployment_id, scope, visibility) \
907+ \VALUES (?, ?, ?, ?, ?) \
908+ \ON CONFLICT (key, deployment_id, scope) \
909+ \DO \
833910 \UPDATE SET value = ?, visibility = ?, updated_at = now()"
834− dId' = unDeploymentId dId
835− void $ for appOvs $ \o -> do
836− let
837− oKey = overrideKey . unApplicationOverride $ o
838− oValue = overrideValue . unApplicationOverride $ o
839− oScope = show ApplicationScope
840− oVis = show . overrideVisibility . unApplicationOverride $ o
841− execute conn q (oKey, oValue, dId', oScope, oVis, oValue, oVis)
842− void $ for depOvs $ \o -> do
843− let
844− oKey = overrideKey . unDeploymentOverride $ o
845− oValue = overrideValue . unDeploymentOverride $ o
846− oScope = show DeploymentScope
847− oVis = show . overrideVisibility . unDeploymentOverride $ o
848− execute conn q (oKey, oValue, dId', oScope, oVis, oValue, oVis)
849−
850−updateTag
851− :: Connection
852− -> DeploymentId
853− -> DeploymentTag
854− -> IO ()
911+ dId' = unDeploymentId dId
912+ void $
913+ for appOvs $ \o -> do
914+ let oKey = overrideKey . unApplicationOverride $ o
915+ oValue = overrideValue . unApplicationOverride $ o
916+ oScope = show ApplicationScope
917+ oVis = show . overrideVisibility . unApplicationOverride $ o
918+ execute conn q (oKey, oValue, dId', oScope, oVis, oValue, oVis)
919+ void $
920+ for depOvs $ \o -> do
921+ let oKey = overrideKey . unDeploymentOverride $ o
922+ oValue = overrideValue . unDeploymentOverride $ o
923+ oScope = show DeploymentScope
924+ oVis = show . overrideVisibility . unDeploymentOverride $ o
925+ execute conn q (oKey, oValue, dId', oScope, oVis, oValue, oVis)
926+
927+updateTag ::
928+ Connection ->
929+ DeploymentId ->
930+ DeploymentTag ->
931+ IO ()
855932updateTag conn (DeploymentId dId) (DeploymentTag dTag) = do
856− let
857− q = "UPDATE deployments SET tag=? WHERE id=?;"
933+ let q = "UPDATE deployments SET tag=? WHERE id=?;"
858934 void $ execute conn q (dTag, dId)
859935
860936-- | Handles the 'info' request of the Web UI API.
@@ -878,19 +954,19 @@ powerInfoH dName = do
878954-- | Hides private overrides of 'info' response.
879955hidePrivateOverridesInInfo :: DeploymentInfo -> DeploymentInfo
880956hidePrivateOverridesInInfo (DeploymentInfo dep dMeta dLogs) =
881− let
882− dep' =
883− let (Deployment n t ao so) = dep
884− in Deployment n t (hideP ao) (hideP so)
885− dLogs' = dLogs <&> \(DeploymentLog ai a t ao so ec d ct) ->
886− DeploymentLog ai a t (hideP ao) (hideP so) ec d ct
887− hideP o = coerce o <&> \(Override k v vis) ->
888− let
889− v' = case vis of
890− Private -> "*"
891− Public -> v
892− in coerce $ Override k v' vis
893− in DeploymentInfo dep' dMeta dLogs'
957+ let dep' =
958+ let (Deployment n t ao so) = dep
959+ in Deployment n t (hideP ao) (hideP so)
960+ dLogs' =
961+ dLogs <&> \(DeploymentLog ai a t ao so ec d ct) ->
962+ DeploymentLog ai a t (hideP ao) (hideP so) ec d ct
963+ hideP o =
964+ coerce o <&> \(Override k v vis) ->
965+ let v' = case vis of
966+ Private -> "*"
967+ Public -> v
968+ in coerce $ Override k v' vis
969+ in DeploymentInfo dep' dMeta dLogs'
894970
895971-- | Helper to get deployment info from the database.
896972getInfo :: DeploymentName -> AppM DeploymentInfo
@@ -910,8 +986,9 @@ getInfo dName = do
910986pingH :: AppM NoContent
911987pingH = do
912988 pgPool <- pool <$> ask
913− _ :: [Only Int] <- liftIO $ withResource pgPool $ \conn ->
914− query_ conn "SELECT 1"
989+ _ :: [Only Int] <- liftIO $
990+ withResource pgPool $ \conn ->
991+ query_ conn "SELECT 1"
915992 pure NoContent
916993
917994-- | Handles the 'project_name' request.
@@ -934,22 +1011,25 @@ cleanupH :: DeploymentName -> AppM CommandResponse
9341011cleanupH dName = do
9351012 failIfGracefulShutdownActivated
9361013 st <- ask
937− runDeploymentBgWorker Nothing dName (pure ()) $ \ () -> liftBase $ cleanupDeployment dName st
1014+ runDeploymentBgWorker Nothing dName (pure ()) $ \() -> liftBase $ cleanupDeployment dName st
9381015 pure Success
9391016
9401017-- | Helper to cleanup deployment.
9411018cleanupDeployment :: DeploymentName -> AppState -> IO ()
9421019cleanupDeployment dName st = do
943− let
944− log = logInfo (logger st)
945− pgPool = pool st
946− args =
947− [ "--project-name", coerce $ projectName st
948− , "--base-domain", coerce $ baseDomain st
949− , "--namespace", coerce $ namespace st
950− , "--name", coerce dName
951− ]
952− cmd = coerce $ cleanupCommand st
1020+ let log = logInfo (logger st)
1021+ pgPool = pool st
1022+ args =
1023+ [ "--project-name"
1024+ , coerce $ projectName st
1025+ , "--base-domain"
1026+ , coerce $ baseDomain st
1027+ , "--namespace"
1028+ , coerce $ namespace st
1029+ , "--name"
1030+ , coerce dName
1031+ ]
1032+ cmd = coerce $ cleanupCommand st
9531033 log $ "call " <> unwords (cmd : args)
9541034 (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
9551035 print out >> print err
@@ -964,30 +1044,33 @@ cleanupDeployment dName st = do
9641044
9651045-- | Helper to delete deployment log overrides.
9661046deleteDeploymentLogOverrides :: PgPool -> DeploymentName -> IO Int64
967−deleteDeploymentLogOverrides p n = withResource p $ \conn -> execute
968− conn
969− "DELETE FROM deployment_log_overrides WHERE deployment_log_id in ( \
1047+deleteDeploymentLogOverrides p n = withResource p $ \conn ->
1048+ execute
1049+ conn
1050+ "DELETE FROM deployment_log_overrides WHERE deployment_log_id in ( \
9701051 \SELECT id FROM deployment_logs WHERE deployment_id in ( \
971− \SELECT id FROM deployments where name = ? \
1052+ \SELECT id FROM deployments where name = ? \
9721053 \) \
973− \)"
974− (Only n)
1054+ \)"
1055+ (Only n)
9751056
9761057-- | Helper to delete deployment logs.
9771058deleteDeploymentLogs :: PgPool -> DeploymentName -> IO Int64
978−deleteDeploymentLogs p n = withResource p $ \conn -> execute
979− conn
980− "DELETE FROM deployment_logs WHERE deployment_id in\
981− \ (SELECT id FROM deployments where name = ?)"
982− (Only n)
1059+deleteDeploymentLogs p n = withResource p $ \conn ->
1060+ execute
1061+ conn
1062+ "DELETE FROM deployment_logs WHERE deployment_id in\
1063+ \ (SELECT id FROM deployments where name = ?)"
1064+ (Only n)
9831065
9841066-- | Helper to delete deployment overrides.
9851067deleteDeploymentOverrides :: PgPool -> DeploymentName -> IO Int64
986−deleteDeploymentOverrides p n = withResource p $ \conn -> execute
987− conn
988− "DELETE FROM deployment_overrides WHERE deployment_id in\
989− \ (SELECT id FROM deployments where name = ?)"
990− (Only n)
1068+deleteDeploymentOverrides p n = withResource p $ \conn ->
1069+ execute
1070+ conn
1071+ "DELETE FROM deployment_overrides WHERE deployment_id in\
1072+ \ (SELECT id FROM deployments where name = ?)"
1073+ (Only n)
9911074
9921075-- | Helper to delete a deployment.
9931076deleteDeployment :: PgPool -> DeploymentName -> IO Int64
@@ -999,12 +1082,11 @@ cleanArchiveH :: AppM CommandResponse
9991082cleanArchiveH = do
10001083 failIfGracefulShutdownActivated
10011084 st <- ask
1002− let
1003− pgPool = pool st
1004− archRetention = unArchiveRetention . archiveRetention $ st
1005− q =
1006− "SELECT name FROM deployments \
1007− \WHERE status in ? AND archived_at + interval '?' second < now()"
1085+ let pgPool = pool st
1086+ archRetention = unArchiveRetention . archiveRetention $ st
1087+ q =
1088+ "SELECT name FROM deployments \
1089+ \WHERE status in ? AND archived_at + interval '?' second < now()"
10081090 retrieved :: [Only DeploymentName] <- liftIO $
10091091 withResource pgPool $ \conn -> query conn q (In archivedStatuses, archRetention)
10101092 runBgWorker . void $
@@ -1028,12 +1110,14 @@ restoreH dName = do
10281110 (ec, out, err) <- liftBase $ createDeployment dep' st
10291111 t2 <- liftBase now
10301112 let elTime = elapsedTime t2 t1
1031− transitionToStatusS dName $ TransitionCreatePending StatusTransitionProcessOutput
1032− { exitCode = ec
1033− , duration = elTime
1034− , stdout = out
1035− , stderr = err
1036− }
1113+ transitionToStatusS dName $
1114+ TransitionCreatePending
1115+ StatusTransitionProcessOutput
1116+ { exitCode = ec
1117+ , duration = elTime
1118+ , stdout = out
1119+ , stderr = err
1120+ }
10371121 handleExitCode ec
10381122 pure Success
10391123
@@ -1041,16 +1125,15 @@ restoreH dName = do
10411125getActionInfoH :: ActionId -> AppM ActionInfo
10421126getActionInfoH aId = do
10431127 st <- ask
1044− let
1045− pgPool = pool st
1046− aId' = Only . unActionId $ aId
1047− q = "SELECT stdout, stderr FROM deployment_logs WHERE id = ?"
1128+ let pgPool = pool st
1129+ aId' = Only . unActionId $ aId
1130+ q = "SELECT stdout, stderr FROM deployment_logs WHERE id = ?"
10481131 rows :: [(Text, Text)] <- liftIO $
10491132 withResource pgPool $ \conn -> query conn q aId'
10501133 case rows of
10511134 (out, err) : _ -> pure $ ActionInfo out err
10521135 _ ->
1053− throwError err400 { errBody = appError "Action not found" }
1136+ throwError err400 {errBody = appError "Action not found"}
10541137
10551138-- | Helper to handle exit code.
10561139handleExitCode :: MonadBaseControl IO m => ExitCode -> m ()
@@ -1058,96 +1141,103 @@ handleExitCode ExitSuccess = return ()
10581141handleExitCode (ExitFailure c) = liftBase . throwIO $ DeploymentFailed c
10591142
10601143-- | Helper to log a deployment action.
1061−createDeploymentLog
1062− :: Connection
1063− -> Deployment
1064− -> Action
1065− -> ExitCode
1066− -> Duration
1067− -> Stdout
1068− -> Stderr
1069− -> IO ()
1144+createDeploymentLog ::
1145+ (MonadError ServerError m, MonadIO m) =>
1146+ Connection ->
1147+ Deployment ->
1148+ Action ->
1149+ ExitCode ->
1150+ Duration ->
1151+ Stdout ->
1152+ Stderr ->
1153+ m ()
10701154createDeploymentLog conn dep act ec dur out err = do
1071− let
1072− (Deployment dName dTag appOvs depOvs) = dep
1073− exitCode' =
1074− case ec of
1075− ExitSuccess -> 0
1076− ExitFailure errCode -> errCode
1077− dur' = unDuration dur
1078− out' = unStdout out
1079− err' = unStderr err
1080− qInsertLog =
1081− "INSERT INTO deployment_logs \
1082− \(deployment_id, action, tag, exit_code, \
1083− \duration, stdout, stderr) \
1084− \(\
1155+ let (Deployment dName dTag appOvs depOvs) = dep
1156+ exitCode' =
1157+ case ec of
1158+ ExitSuccess -> 0
1159+ ExitFailure errCode -> errCode
1160+ dur' = unDuration dur
1161+ out' = unStdout out
1162+ err' = unStderr err
1163+ qInsertLog =
1164+ "INSERT INTO deployment_logs \
1165+ \(deployment_id, action, tag, exit_code, \
1166+ \duration, stdout, stderr) \
1167+ \(\
10851168 \SELECT id, ?, ?, ?, ?, ?, ? \
10861169 \FROM deployments \
10871170 \WHERE name = ? \
1088− \) RETURNING id"
1089− qInsertLogOverride =
1090− "INSERT INTO deployment_log_overrides \
1091− \(key, value, deployment_log_id, scope, visibility) \
1092− \VALUES (?, ?, ?, ?, ?)"
1093− aIds :: [Only Int] <- query conn qInsertLog
1094− (act, dTag, exitCode', dur', out', err', dName)
1095− void $ for appOvs $ \o -> do
1096− let
1097− [Only aId] = aIds
1098− oKey = overrideKey . unApplicationOverride $ o
1099− oValue = overrideValue . unApplicationOverride $ o
1100− oScope = show ApplicationScope
1101− oVis = show . overrideVisibility . unApplicationOverride $ o
1102− execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1103− void $ for depOvs $ \o -> do
1104− let
1105− [Only aId] = aIds
1106− oKey = overrideKey . unDeploymentOverride $ o
1107− oValue = overrideValue . unDeploymentOverride $ o
1108− oScope = show DeploymentScope
1109− oVis = show . overrideVisibility . unDeploymentOverride $ o
1110− execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1171+ \) RETURNING id"
1172+ qInsertLogOverride =
1173+ "INSERT INTO deployment_log_overrides \
1174+ \(key, value, deployment_log_id, scope, visibility) \
1175+ \VALUES (?, ?, ?, ?, ?)"
1176+ (Only aId) :: Only Int <-
1177+ liftIO
1178+ ( query
1179+ conn
1180+ qInsertLog
1181+ (act, dTag, exitCode', dur', out', err', dName)
1182+ )
1183+ >>= ensureOne
1184+ void $
1185+ for appOvs $ \o -> do
1186+ let oKey = overrideKey . unApplicationOverride $ o
1187+ oValue = overrideValue . unApplicationOverride $ o
1188+ oScope = show ApplicationScope
1189+ oVis = show . overrideVisibility . unApplicationOverride $ o
1190+ liftIO $ execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1191+ void $
1192+ for depOvs $ \o -> do
1193+ let oKey = overrideKey . unDeploymentOverride $ o
1194+ oValue = overrideValue . unDeploymentOverride $ o
1195+ oScope = show DeploymentScope
1196+ oVis = show . overrideVisibility . unDeploymentOverride $ o
1197+ liftIO $ execute conn qInsertLogOverride (oKey, oValue, aId, oScope, oVis)
1198+
1199+ensureOne :: MonadError ServerError m => [a] -> m a
1200+ensureOne [x] = return x
1201+ensureOne _ = throwError err500
11111202
11121203-- | Helper to get deployment metadata from the database.
1113−selectDeploymentMetadata
1114− :: Connection
1115− -> DeploymentName
1116− -> IO [DeploymentMetadata]
1204+selectDeploymentMetadata ::
1205+ Connection ->
1206+ DeploymentName ->
1207+ IO [DeploymentMetadata]
11171208selectDeploymentMetadata conn dName = do
1118− let
1119− q =
1120− "SELECT key, value FROM deployment_metadata \
1121− \WHERE deployment_id = (SELECT id FROM deployments WHERE name = ?) \
1122− \ORDER BY id ASC"
1209+ let q =
1210+ "SELECT key, value FROM deployment_metadata \
1211+ \WHERE deployment_id = (SELECT id FROM deployments WHERE name = ?) \
1212+ \ORDER BY id ASC"
11231213 rows <- query conn q (Only dName)
11241214 for rows $ \(k, v) -> pure $ DeploymentMetadata k v
11251215
11261216-- | Helper to delete deployment metadata.
1127−deleteDeploymentMetadata
1128− :: PgPool
1129− -> DeploymentName
1130− -> IO ()
1217+deleteDeploymentMetadata ::
1218+ PgPool ->
1219+ DeploymentName ->
1220+ IO ()
11311221deleteDeploymentMetadata pgPool dName = do
1132− let
1133− q =
1134− "DELETE FROM deployment_metadata \
1135− \WHERE deployment_id = (SELECT id FROM deployments WHERE name = ?)"
1222+ let q =
1223+ "DELETE FROM deployment_metadata \
1224+ \WHERE deployment_id = (SELECT id FROM deployments WHERE name = ?)"
11361225 void $ withResource pgPool $ \conn -> execute conn q (Only dName)
11371226
11381227-- | Helper to insert or update deployment metadata.
1139−upsertDeploymentMetadata
1140− :: PgPool
1141− -> DeploymentName
1142− -> [DeploymentMetadata]
1143− -> IO ()
1228+upsertDeploymentMetadata ::
1229+ PgPool ->
1230+ DeploymentName ->
1231+ [DeploymentMetadata] ->
1232+ IO ()
11441233upsertDeploymentMetadata pgPool dName dMetadatas = do
11451234 withResource pgPool $ \conn -> withTransactionSerializable conn $ do
1146− void $ execute
1147− conn
1148− "DELETE FROM deployment_metadata \
1149− \WHERE deployment_id = (SELECT id FROM deployments WHERE name = ?)"
1150− (Only dName)
1235+ void $
1236+ execute
1237+ conn
1238+ "DELETE FROM deployment_metadata \
1239+ \WHERE deployment_id = (SELECT id FROM deployments WHERE name = ?)"
1240+ (Only dName)
11511241 forM_ dMetadatas $ \dMeta ->
11521242 execute
11531243 conn
@@ -1161,17 +1251,21 @@ upsertDeploymentMetadata pgPool dName dMetadatas = do
11611251failIfImageNotFound :: DeploymentName -> DeploymentTag -> AppM ()
11621252failIfImageNotFound dName dTag = do
11631253 st <- ask
1164− let
1165− log :: Text -> IO ()
1166− log = logInfo (logger st)
1167− args =
1168− [ "--project-name", coerce $ projectName st
1169− , "--base-domain", coerce $ baseDomain st
1170− , "--namespace", coerce $ namespace st
1171− , "--name", coerce $ dName
1172− , "--tag", coerce $ dTag
1173− ]
1174− cmd = coerce $ tagCheckingCommand st
1254+ let log :: Text -> IO ()
1255+ log = logInfo (logger st)
1256+ args =
1257+ [ "--project-name"
1258+ , coerce $ projectName st
1259+ , "--base-domain"
1260+ , coerce $ baseDomain st
1261+ , "--namespace"
1262+ , coerce $ namespace st
1263+ , "--name"
1264+ , coerce $ dName
1265+ , "--tag"
1266+ , coerce $ dTag
1267+ ]
1268+ cmd = coerce $ tagCheckingCommand st
11751269
11761270 ec <- liftIO $ do
11771271 log $ "call " <> unwords (cmd : args)
@@ -1179,7 +1273,7 @@ failIfImageNotFound dName dTag = do
11791273 case ec of
11801274 ExitSuccess -> pure ()
11811275 ExitFailure _ ->
1182− throwError err400 { errBody = validationError [] ["Tag not found"] }
1276+ throwError err400 {errBody = validationError [] ["Tag not found"]}
11831277
11841278-- | Helper to create an application-level error.
11851279appError :: Text -> BSL.ByteString
@@ -1203,27 +1297,25 @@ elapsedTime t1 t2 =
12031297-- | Runs the status updater.
12041298runStatusUpdater :: AppState -> IO ()
12051299runStatusUpdater state = do
1206− let
1207− pgPool = pool state
1208− interval = 30 :: Int
1209− selectDeps =
1210− "SELECT name, status::text, \
1211− \extract(epoch from now())::int - \
1300+ let pgPool = pool state
1301+ interval = 30 :: Int
1302+ selectDeps =
1303+ "SELECT name, status::text, \
1304+ \extract(epoch from now())::int - \
12121305 \extract(epoch from status_updated_at)::int \
1213− \, tag \
1214− \FROM deployments \
1215− \WHERE checked_at < now() - interval '?' second AND status != 'Archived'"
1216− updateCheckedAt =
1217− "UPDATE deployments SET checked_at = now() WHERE name = ? AND status = ?"
1218− logErr :: Text -> IO ()
1219− logErr = logWarning (logger state)
1306+ \, tag \
1307+ \FROM deployments \
1308+ \WHERE checked_at < now() - interval '?' second AND status != 'Archived'"
1309+ updateCheckedAt =
1310+ "UPDATE deployments SET checked_at = now() WHERE name = ? AND status = ?"
1311+ logErr :: Text -> IO ()
1312+ logErr = logWarning (logger state)
12201313
12211314 forever $ do
12221315 rows :: [(DeploymentName, DeploymentStatus, Int, DeploymentTag)] <- liftIO $
12231316 withResource pgPool $ \conn -> query conn selectDeps (Only interval)
1224− let
1225− checkList :: [(DeploymentName, DeploymentStatus, Timestamp, DeploymentTag)] =
1226− (\(n, s, t, dTag) -> (n, s, coerce t, dTag)) <$> rows
1317+ let checkList :: [(DeploymentName, DeploymentStatus, Timestamp, DeploymentTag)] =
1318+ (\(n, s, t, dTag) -> (n, s, coerce t, dTag)) <$> rows
12271319 checkResult <- for checkList $ \(dName, dStatus, ts, dTag) -> do
12281320 let timeout = statusUpdateTimeout state
12291321 (ec, _, _) <- flip runReaderT state case dStatus of
@@ -1236,28 +1328,31 @@ runStatusUpdater state = do
12361328 case transitionM of
12371329 Nothing -> execute conn updateCheckedAt (dName, dStatus) $> False
12381330 Just transition ->
1239− ($> True) $ (flip runReaderT state . runExceptT . runExceptT) (transitionToStatus dName transition) >>= \case
1240− Right (Right ()) -> void $ execute conn updateCheckedAt (dName, transitionStatus transition)
1241− Left e -> logErr $ show' e
1242− Right (Left e) -> logErr $ show' e
1331+ ($> True) $
1332+ (flip runReaderT state . runExceptT . runExceptT) (transitionToStatus dName transition) >>= \case
1333+ Right (Right ()) -> void $ execute conn updateCheckedAt (dName, transitionStatus transition)
1334+ Left e -> logErr $ show' e
1335+ Right (Left e) -> logErr $ show' e
12431336 when (or updated) $ sendReloadEvent state
12441337 threadDelay 5000000
12451338
12461339-- | Returns the new deployment status.
1247−statusTransition
1248− :: ExitCode
1249− -> DeploymentStatus
1250− -> Timestamp
1251− -> Timeout
1252− -> Maybe DeploymentStatusTransition
1253−statusTransition ExitSuccess ArchivePending _ _ = Just TransitionArchived
1254−statusTransition ExitSuccess Running _ _ = Nothing
1255−statusTransition ExitSuccess _ _ _ = Just TransitionCreate
1256−statusTransition (ExitFailure n) Running _ _ = Just . TransitionFailure $ failureStatusType n
1257−statusTransition (ExitFailure n) CreatePending ts timeout | ts > coerce timeout =
1258− Just . TransitionFailure $ failureStatusType n
1259−statusTransition (ExitFailure n) UpdatePending ts timeout | ts > coerce timeout =
1260− Just . TransitionFailure $ failureStatusType n
1340+statusTransition ::
1341+ ExitCode ->
1342+ DeploymentStatus ->
1343+ Timestamp ->
1344+ Timeout ->
1345+ Maybe DeploymentStatusTransition
1346+statusTransition ExitSuccess ArchivePending _ _ = Just TransitionArchived
1347+statusTransition ExitSuccess Running _ _ = Nothing
1348+statusTransition ExitSuccess _ _ _ = Just TransitionCreate
1349+statusTransition (ExitFailure n) Running _ _ = Just . TransitionFailure $ failureStatusType n
1350+statusTransition (ExitFailure n) CreatePending ts timeout
1351+ | ts > coerce timeout =
1352+ Just . TransitionFailure $ failureStatusType n
1353+statusTransition (ExitFailure n) UpdatePending ts timeout
1354+ | ts > coerce timeout =
1355+ Just . TransitionFailure $ failureStatusType n
12611356statusTransition (ExitFailure _) _ _ _ = Nothing
12621357
12631358failureStatusType :: Int -> FailureType
@@ -1273,7 +1368,7 @@ failIfGracefulShutdownActivated = do
12731368 gracefulShutdownAct <- gracefulShutdownActivated <$> ask
12741369 gracefulShutdown <- liftIO . readIORef $ gracefulShutdownAct
12751370 if gracefulShutdown
1276− then throwError err405 { errBody = appError "Graceful shutdown activated" }
1371+ then throwError err405 {errBody = appError "Graceful shutdown activated"}
12771372 else pure ()
12781373
12791374-- | Handles the graceful shutdown signal.
@@ -1314,36 +1409,38 @@ runBgWorker act = void $ L.forkFinally act' cleanup
13141409 else pure ()
13151410
13161411-- | Same as 'runBgWorker' but also locks the specified deployment.
1317−runDeploymentBgWorker
1318− :: forall m a. (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m)
1319− => Maybe DeploymentStatus
1320− -> DeploymentName
1321− -> m a
1322− -- ^ Think of this as running synchronously.
1412+runDeploymentBgWorker ::
1413+ forall m a.
1414+ (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>
1415+ Maybe DeploymentStatus ->
1416+ DeploymentName ->
1417+ -- | Think of this as running synchronously.
13231418 -- The resulting monad state will be forwarded to the calling context.
1324− -> (a -> m ())
1325− -- ^ The computation to run asynchronously.
1326− -> m ()
1419+ m a ->
1420+ -- | The computation to run asynchronously.
1421+ (a -> m ()) ->
1422+ m ()
13271423runDeploymentBgWorker newS dName pre post = do
13281424 st <- ask
13291425 mainThread <- L.myThreadId
13301426 (err :: MVar (Either ServerError (StM m a))) <- L.newEmptyMVar
1331− runBgWorker $ withLockedDeployment
1332− dName
1333− (L.putMVar err $ Left err409 {errBody = "The deployment is currently being processed."})
1334− ( do
1335− L.try (liftBaseWith \runInBase -> runInBase pre) >>= \case
1336− Left (e :: L.SomeException) -> L.throwTo mainThread e
1337− Right x -> do
1338− proceed <- flip L.finally (L.tryPutMVar err (Left err500)) $ case newS of
1339− Just newS' -> do
1340− runExceptT (assertDeploymentTransitionPossibleS dName newS') >>= \case
1427+ runBgWorker $
1428+ withLockedDeployment
1429+ dName
1430+ (L.putMVar err $ Left err409 {errBody = "The deployment is currently being processed."})
1431+ ( do
1432+ L.try (liftBaseWith \runInBase -> runInBase pre) >>= \case
1433+ Left (e :: L.SomeException) -> L.throwTo mainThread e
1434+ Right x -> do
1435+ proceed <- flip L.finally (L.tryPutMVar err (Left err500)) $ case newS of
1436+ Just newS' -> do
1437+ runExceptT (assertDeploymentTransitionPossibleS dName newS') >>= \case
13411438 Left e -> L.putMVar err (Left e) $> False
13421439 Right () -> L.putMVar err (Right x) $> True
1343− Nothing -> L.putMVar err (Right x) $> True
1344− liftBase (sendReloadEvent st)
1345− when proceed $ restoreM x >>= post
1346− )
1440+ Nothing -> L.putMVar err (Right x) $> True
1441+ liftBase (sendReloadEvent st)
1442+ when proceed $ restoreM x >>= post
1443+ )
13471444 L.readMVar err >>= \case
13481445 Left e -> throwError e
13491446 Right (stm :: StM m a) -> do