@@ -2,13 +2,12 @@ module Octopod.Server (runOctopodServer) where
22
33import Common.Validation
44import Control.Applicative
5−import Control.Concurrent (threadDelay)
6−import Control.Concurrent.Async (race_)
7−import qualified Control.Concurrent.Lifted as L
8−import Control.Concurrent.MVar
5+import Control.CacheMap (CacheMap)
6+import qualified Control.CacheMap as CM
7+import Control.Concurrent.Async (race)
8+import Control.Concurrent.Lifted hiding (yield)
99import Control.Concurrent.STM
10−import Control.Exception (Exception (displayException), throwIO)
11−import qualified Control.Exception.Lifted as L
10+import Control.Exception.Lifted hiding (Handler)
1211import Control.Lens hiding (Context, each, pre, (<.))
1312import Control.Lens.Extras
1413import Control.Monad
@@ -24,27 +23,32 @@ import qualified Data.ByteString.Lazy as BSL
2423import qualified Data.ByteString.Lazy.Char8 as BSLC
2524import Data.Coerce
2625import Data.Conduit (ConduitT, yield)
26+import qualified Data.ConfigTree as CT
2727import qualified Data.Csv as C
28+import Data.Fixed
2829import Data.Foldable
2930import Data.Functor
31+import Data.Functor.Contravariant
3032import Data.Generics.Labels ()
3133import Data.Generics.Product
32−import Data.IORef
34+import Data.IORef.Lifted
3335import Data.Int
34−import qualified Data.Map.Ordered.Strict as OM
3536import Data.Maybe
3637import Data.Pool
37−import Data.Text (pack, unpack, unwords)
38+import Data.Text (pack)
3839import qualified Data.Text as T
3940import qualified Data.Text.Encoding as T
4041import Data.Time
4142import Data.Traversable
4243import qualified Data.Vector as V
44+import GHC.Exception
45+import GHC.Stack
4346import Hasql.Connection
4447import qualified Hasql.Session as HasQL
4548import Hasql.Statement
4649import Hasql.Transaction
4750import Hasql.Transaction.Sessions
51+import Katip hiding (Namespace)
4852import Network.Wai.Handler.Warp
4953import Octopod.API
5054import Octopod.PowerAPI
@@ -52,7 +56,7 @@ import Octopod.PowerAPI.Auth.Server
5256import Octopod.Schema
5357import Octopod.Server.Args
5458import Octopod.Server.ControlScriptUtils
55−import Octopod.Server.Logger
59+import Octopod.Server.Logging
5660import Octopod.Server.Posix
5761import Options.Generic
5862import Orphans ()
@@ -63,61 +67,66 @@ import Servant
6367import Servant.Auth.Server
6468import System.Environment (lookupEnv)
6569import System.Exit
66−import System.Log.FastLogger
6770import System.Posix.Signals (sigTERM)
71+import Text.Read (readMaybe)
6872import Types
6973import Prelude hiding (lines, log, unlines, unwords)
7074
71−type AppM = ReaderT AppState Handler
75+type AppM = ReaderT AppState (KatipContextT Handler)
76+
77+class (KatipContext m, MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) => AppMConstraints m
78+instance (KatipContext m, MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) => AppMConstraints m
7279
7380-- | Octopod Server state definition.
7481data AppState = AppState
7582 { -- | postgres pool
76− dbPool :: Pool Connection
77− , -- | logger
78− logger :: TimedFastLogger
83+ dbPool :: !(Pool Connection)
7984 , -- | channel for WS events for the frontend
80− eventSink :: TChan WSEvent
85+ eventSink :: !(TChan WSEvent)
8186 , -- | background workers counter
82− bgWorkersCounter :: IORef Int
87+ bgWorkersCounter :: !(IORef Int)
8388 , -- | flag of activating graceful shutdown
84− gracefulShutdownActivated :: IORef Bool
89+ gracefulShutdownActivated :: !(IORef Bool)
8590 , -- | semaphore for graceful shutdown
86− shutdownSem :: MVar ()
91+ shutdownSem :: !(MVar ())
8792 , -- | project name
88− projectName :: ProjectName
93+ projectName :: !ProjectName
8994 , -- | base domain
90− baseDomain :: Domain
95+ baseDomain :: !Domain
9196 , -- | namespace
92− namespace :: Namespace
93− , -- | archive retention
94− archiveRetention :: ArchiveRetention
97+ namespace :: !Namespace
9598 , -- | status update timeout
96− statusUpdateTimeout :: Timeout
99+ statusUpdateTimeout :: !Timeout
97100 , -- | creation command path
98− creationCommand :: Command
101+ creationCommand :: !Command
99102 , -- | update command path
100− updateCommand :: Command
103+ updateCommand :: !Command
101104 , -- | deletion command path
102− archiveCommand :: Command
105+ archiveCommand :: !Command
103106 , -- | checking command path
104− checkingCommand :: Command
107+ checkingCommand :: !Command
105108 , -- | cleanup command path
106− cleanupCommand :: Command
109+ cleanupCommand :: !Command
107110 , -- | archive checking command path
108− archiveCheckingCommand :: Command
111+ archiveCheckingCommand :: !Command
109112 , -- | tag checking command path
110− tagCheckingCommand :: Command
111− , infoCommand :: Command
112− , notificationCommand :: Maybe Command
113− , deploymentOverridesCommand :: Command
114− , deploymentOverrideKeysCommand :: Command
115− , applicationOverridesCommand :: Command
116− , applicationOverrideKeysCommand :: Command
117− , unarchiveCommand :: Command
113+ configCheckingCommand :: !Command
114+ , infoCommand :: !Command
115+ , notificationCommand :: !(Maybe Command)
116+ , deploymentOverridesCommand :: !Command
117+ , deploymentOverrideKeysCommand :: !Command
118+ , applicationOverridesCommand :: !Command
119+ , applicationOverrideKeysCommand :: !Command
120+ , unarchiveCommand :: !Command
118121 , -- | Deployments currently being processed which has not yet been
119122 -- recorded in the database.
120− lockedDeployments :: LockedDeployments
123+ lockedDeployments :: !LockedDeployments
124+ , depOverridesCache :: !(CacheMap ServerError AppMConstraints () (DefaultConfig 'DeploymentLevel))
125+ , depOverrideKeysCache :: !(CacheMap ServerError AppMConstraints () [Text])
126+ , appOverridesCache :: !(CacheMap ServerError AppMConstraints (Config 'DeploymentLevel) (DefaultConfig 'ApplicationLevel))
127+ , appOverrideKeysCache :: !(CacheMap ServerError AppMConstraints (Config 'DeploymentLevel) [Text])
128+ , gitSha :: !Text
129+ , controlScriptTimeout :: !ControlScriptTimeout
121130 }
122131 deriving stock (Generic)
123132
@@ -142,130 +151,215 @@ data FullInfoListType
142151 | FullInfoOnlyForOne DeploymentName
143152 deriving stock (Show)
144153
145−runOctopodServer :: IO ()
146−runOctopodServer = do
147− logger' <- newLogger
148− logInfo logger' "started"
154+runOctopodServer ::
155+ -- | The git SHA
156+ Text ->
157+ IO ()
158+runOctopodServer sha = do
149159 bgWorkersC <- newIORef 0
150160 gracefulShutdownAct <- newIORef False
151161 shutdownS <- newEmptyMVar
152− void $ do
153− let termHandler = terminationHandler bgWorkersC gracefulShutdownAct shutdownS
154− installShutdownHandler logger' [sigTERM] termHandler
155162 opts <- parseArgs
156163 let a ?! e = a >>= maybe (die e) pure
157164 getEnvOrDie eName = lookupEnv eName ?! (eName <> " is not set")
165+ getEnvOrDieWith eName f = fmap (>>= f) (lookupEnv eName) ?! (eName <> " is not set")
158166 projName <- coerce . pack <$> getEnvOrDie "PROJECT_NAME"
159167 domain <- coerce . pack <$> getEnvOrDie "BASE_DOMAIN"
160168 ns <- coerce . pack <$> getEnvOrDie "NAMESPACE"
161− archRetention <- ArchiveRetention . fromIntegral . read @Int <$> getEnvOrDie "ARCHIVE_RETENTION"
162− stUpdateTimeout <- Timeout . CalendarDiffTime 0 . fromIntegral . read @Int <$> getEnvOrDie "STATUS_UPDATE_TIMEOUT"
169+ archRetention <- fromInteger <$> getEnvOrDieWith "ARCHIVE_RETENTION" readMaybe
170+ stUpdateTimeout <- Timeout . CalendarDiffTime 0 . fromInteger <$> getEnvOrDieWith "STATUS_UPDATE_TIMEOUT" readMaybe
171+ scriptTimeout <- ControlScriptTimeout . fromInteger . maybe (60 * 30) read <$> lookupEnv "CONTROL_SCRIPT_TIMEOUT"
163172 creationCmd <- Command . pack <$> getEnvOrDie "CREATION_COMMAND"
164173 updateCmd <- Command . pack <$> getEnvOrDie "UPDATE_COMMAND"
165174 archiveCmd <- Command . pack <$> getEnvOrDie "ARCHIVE_COMMAND"
166175 checkingCmd <- Command . pack <$> getEnvOrDie "CHECKING_COMMAND"
167176 cleanupCmd <- Command . pack <$> getEnvOrDie "CLEANUP_COMMAND"
168177 archiveCheckingCmd <- Command . pack <$> getEnvOrDie "ARCHIVE_CHECKING_COMMAND"
169− tagCheckingCmd <- Command . pack <$> getEnvOrDie "TAG_CHECKING_COMMAND"
178+ tagCheckingCmd <- Command . pack <$> getEnvOrDie "CONFIG_CHECKING_COMMAND"
170179 infoCmd <- Command . pack <$> getEnvOrDie "INFO_COMMAND"
171− dOverridesCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_OVERRIDES_COMMAND"
180+ dOverridesCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_CONFIG_COMMAND"
172181 dKeysCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_KEYS_COMMAND"
173− aOverridesCmd <- Command . pack <$> getEnvOrDie "APPLICATION_OVERRIDES_COMMAND"
182+ aOverridesCmd <- Command . pack <$> getEnvOrDie "APPLICATION_CONFIG_COMMAND"
174183 aKeysCmd <- Command . pack <$> getEnvOrDie "APPLICATION_KEYS_COMMAND"
175184 unarchiveCmd <- Command . pack <$> getEnvOrDie "UNARCHIVE_COMMAND"
176185 powerAuthorizationHeader <- AuthHeader . BSC.pack <$> getEnvOrDie "POWER_AUTHORIZATION_HEADER"
186+ invalidationTime <- fromInteger . maybe (60 * 60 * 24) read <$> lookupEnv "CACHE_INVALIDATION_TIME"
187+ updateTime <- fromInteger . maybe (60 * 10) read <$> lookupEnv "CACHE_UPDATE_TIME"
188+ isDebug <- (== Just "true") <$> lookupEnv "DEBUG"
189+ isProdLogs <- (/= Just "false") <$> lookupEnv "PROD_LOGS"
190+ let cacheMap :: forall a x. (forall m. AppMConstraints m => x -> m a) -> IO (CacheMap ServerError AppMConstraints x a)
191+ cacheMap = CM.initCacheMap invalidationTime updateTime
192+ decodeCSVDefaultConfig :: BSL.ByteString -> Either String (DefaultConfig l)
193+ decodeCSVDefaultConfig bs = do
194+ x <- C.decode C.NoHeader bs
195+ pure $ DefaultConfig . CT.fromFlatList . V.toList $ x
196+ either500S :: (KatipContext m, MonadError ServerError m) => Either String x -> m x
197+ either500S (Right x) = pure x
198+ either500S (Left err) = do
199+ logLocM ErrorS $ logStr err
200+ throwError err500 {errBody = BSLC.pack err}
177201 notificationCmd <-
178202 (fmap . fmap) (Command . pack) $
179203 lookupEnv "NOTIFICATION_COMMAND" <&> \case
180204 Just "" -> Nothing
181205 x -> x
182− dbPool' <-
183− createPool
184− (fmap (either (error . show) id) . acquire $ unDBConnectionString $ octopodDB opts)
185− release
186− 1
187− 30
188− (unDBPoolSize $ octopodDBPoolSize opts)
189− channel <- liftIO . atomically $ newBroadcastTChan
190− lockedDs <- initLockedDeployments
191− let appSt =
192− AppState
193− dbPool'
194− logger'
195− channel
196− bgWorkersC
197− gracefulShutdownAct
198− shutdownS
199− projName
200− domain
201− ns
202− archRetention
203− stUpdateTimeout
204− creationCmd
205− updateCmd
206− archiveCmd
207− checkingCmd
208− cleanupCmd
209− archiveCheckingCmd
210− tagCheckingCmd
211− infoCmd
212− notificationCmd
213− dOverridesCmd
214− dKeysCmd
215− aOverridesCmd
216− aKeysCmd
217− unarchiveCmd
218− lockedDs
219− app' = app appSt
220− wsApp' = wsApp channel
221− serverPort = octopodPort opts
222− uiServerPort = unServerPort $ octopodUIPort opts
223− powerServerPort = unServerPort serverPort
224− wsServerPort = unServerPort $ octopodWSPort opts
225− powerApp' <- powerApp powerAuthorizationHeader appSt
226− (run uiServerPort app')
227− `race_` (run powerServerPort powerApp')
228− `race_` (run wsServerPort wsApp')
229− `race_` (runStatusUpdater appSt)
230− `race_` (runShutdownHandler appSt)
206+ depOverrideKeysCache' <- cacheMap $ \() -> do
207+ (_, Stdout out, _, _) <- deploymentOverrideKeys >>= runCommandArgs deploymentOverrideKeysCommand
208+ pure $ T.lines out
209+ depOverridesCache' <- cacheMap $ \() -> do
210+ (_, Stdout out, _, _) <- defaultDeploymentOverridesArgs >>= runCommandArgs deploymentOverridesCommand
211+ either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
212+ appOverrideKeysCache' <- cacheMap $ \cfg -> do
213+ (_, Stdout out, _, _) <- applicationOverrideKeys cfg >>= runCommandArgs applicationOverrideKeysCommand
214+ pure $ T.lines out
215+ appOverridesCache' <- cacheMap $ \cfg -> do
216+ (_, Stdout out, _, _) <- defaultApplicationOverridesArgs cfg >>= runCommandArgs applicationOverridesCommand
217+ either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
218+ let logConfig =
219+ LogConfig
220+ { project = projName
221+ , debug = isDebug
222+ , prodLogs = isProdLogs
223+ }
224+ runLog logConfig $ do
225+ void $ do
226+ let termHandler = terminationHandler bgWorkersC gracefulShutdownAct shutdownS
227+ installShutdownHandler [sigTERM] termHandler
228+ dbPool' <-
229+ liftBase $
230+ createPool
231+ (fmap (either (error . show) id) . acquire $ unDBConnectionString $ octopodDB opts)
232+ release
233+ 1
234+ 30
235+ (unDBPoolSize $ octopodDBPoolSize opts)
236+ channel <- liftBase . atomically $ newBroadcastTChan
237+ lockedDs <- initLockedDeployments
238+ let appSt =
239+ AppState
240+ { dbPool = dbPool'
241+ , eventSink = channel
242+ , bgWorkersCounter = bgWorkersC
243+ , gracefulShutdownActivated = gracefulShutdownAct
244+ , shutdownSem = shutdownS
245+ , projectName = projName
246+ , baseDomain = domain
247+ , namespace = ns
248+ , statusUpdateTimeout = stUpdateTimeout
249+ , creationCommand = creationCmd
250+ , updateCommand = updateCmd
251+ , archiveCommand = archiveCmd
252+ , checkingCommand = checkingCmd
253+ , cleanupCommand = cleanupCmd
254+ , archiveCheckingCommand = archiveCheckingCmd
255+ , configCheckingCommand = tagCheckingCmd
256+ , infoCommand = infoCmd
257+ , notificationCommand = notificationCmd
258+ , deploymentOverridesCommand = dOverridesCmd
259+ , deploymentOverrideKeysCommand = dKeysCmd
260+ , applicationOverridesCommand = aOverridesCmd
261+ , applicationOverrideKeysCommand = aKeysCmd
262+ , unarchiveCommand = unarchiveCmd
263+ , lockedDeployments = lockedDs
264+ , depOverridesCache = depOverridesCache'
265+ , depOverrideKeysCache = depOverrideKeysCache'
266+ , appOverridesCache = appOverridesCache'
267+ , appOverrideKeysCache = appOverrideKeysCache'
268+ , gitSha = sha
269+ , controlScriptTimeout = scriptTimeout
270+ }
271+ serverPort = octopodPort opts
272+ powerServerPort = unServerPort serverPort
273+ uiServerPort = unServerPort $ octopodUIPort opts
274+ wsServerPort = unServerPort $ octopodWSPort opts
275+ (`runReaderT` appSt) $ do
276+ runServer uiServerPort
277+ `raceM_` runPowerServer powerServerPort powerAuthorizationHeader
278+ `raceM_` runWsServer wsServerPort channel
279+ `raceM_` runStatusUpdater
280+ `raceM_` runShutdownHandler
281+ `raceM_` runArchiveCleanup archRetention
282+
283+raceM_ :: MonadBaseControl IO m => m a -> m b -> m ()
284+raceM_ a b = liftBaseWith $ \runInBase ->
285+ race (runInBase a) (runInBase b) >>= \case
286+ Left x -> void $ restoreM x
287+ Right y -> void $ restoreM y
288+
289+runHasQL ::
290+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m) =>
291+ HasQL.Session a ->
292+ m a
293+runHasQL s = do
294+ p <- asks dbPool
295+ liftBaseOp (withResource p) $ \conn ->
296+ liftBase (HasQL.run s conn) >>= \case
297+ Right x -> pure x
298+ Left err -> do
299+ logLocM ErrorS $ logStr $ displayException err
300+ throwIO err
301+
302+runArchiveCleanup ::
303+ forall m.
304+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m) =>
305+ NominalDiffTime ->
306+ m ()
307+runArchiveCleanup retention = do
308+ isShuttingDown >>= \case
309+ True -> pure ()
310+ False -> do
311+ cutoff <- liftBase getCurrentTime <&> addUTCTime (negate retention)
312+ dNames <- runStatement $
313+ select $ do
314+ ds <- each deploymentSchema
315+ where_ $ (ds ^. #status) ==. litExpr Archived
316+ where_ $ ds ^. #archivedAt <. litExpr (Just cutoff)
317+ pure $ ds ^. #name
318+ for_ dNames $ \dName -> (>>= logLeft) . runExceptT $
319+ runDeploymentBgWorker Nothing dName (pure ()) $ \() -> cleanupDeployment dName
320+ threadDelayMicro (realToFrac $ retention / 10)
321+ runArchiveCleanup retention
322+ where
323+ threadDelayMicro :: Micro -> m ()
324+ threadDelayMicro (MkFixed i) = threadDelay (fromInteger i)
231325
232326runTransaction ::
233− (MonadReader AppState m, MonadBaseControl IO m) =>
327+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m) =>
234328 Transaction a ->
235329 m a
236−runTransaction q = do
237− p <- asks dbPool
238− log <- asks logger
239− let logErr = logWarning log
240− handleException e = do
241− liftBase $ logErr . T.pack $ displayException e
242− throwIO e
243− withResource p $ \conn ->
244− liftBase $ HasQL.run (transaction Serializable Write q) conn >>= either handleException pure
330+runTransaction q = katipAddNamespace "transaction" $ runHasQL $ transaction Serializable Write q
245331
246332runStatement ::
247− (MonadReader AppState m, MonadBaseControl IO m) =>
333+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m) =>
248334 Statement () a ->
249335 m a
250−runStatement q = do
251− p <- asks dbPool
252− log <- asks logger
253− let logErr = logWarning log
254− handleException e = do
255− liftBase $ logErr . T.pack $ displayException e
256− throwIO e
257− withResource p $ \conn ->
258− liftBase $ HasQL.run (HasQL.statement () q) conn >>= either handleException pure
259−
260−-- | Helper to run the server.
261−nt :: AppState -> AppM a -> Handler a
262−nt s x = runReaderT x s
263−
264−-- | Application with the Web UI API.
265−app :: AppState -> Application
266−app s = serve api $ hoistServer api (nt s) server
267− where
268− api = Proxy @API
336+runStatement q = katipAddNamespace "statement" $ runHasQL $ HasQL.statement () q
337+
338+runApp ::
339+ forall api context m.
340+ ( HasServer api context
341+ , KatipContext m
342+ , MonadBase IO m
343+ , MonadReader AppState m
344+ , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
345+ ) =>
346+ Port ->
347+ Proxy api ->
348+ Servant.Context context ->
349+ ServerT api AppM ->
350+ m ()
351+runApp portNum api ctx srv = do
352+ appstate <- ask
353+ logEnv <- getLogEnv
354+ logCtx <- getKatipContext
355+ ns <- getKatipNamespace
356+ let hoist :: AppM a -> Handler a
357+ hoist act = runKatipContextT logEnv logCtx ns $ runReaderT act appstate
358+ log req respStatus mSize = runKatipContextT logEnv logCtx ns $ do
359+ logLocM DebugS $ show' req <> " " <> show' respStatus <> " " <> show' mSize
360+ liftBase $
361+ runSettings (setPort portNum $ setLogger log defaultSettings) $
362+ serveWithContext api ctx $ hoistServerWithContext api (Proxy @context) hoist srv
269363
270364-- | Request handlers of the Web UI API application.
271365server :: ServerT API AppM
@@ -283,51 +377,37 @@ server =
283377 :<|> pingH
284378 :<|> projectNameH
285379
286−decodeCSVDefaultConfig :: BSL.ByteString -> Either String (DefaultConfig l)
287−decodeCSVDefaultConfig bs = do
288− x <- C.decode C.NoHeader bs
289− pure $ DefaultConfig . OM.fromList . V.toList $ x
380+lookupCache :: (Ord x, AppMConstraints m) => (AppState -> CacheMap ServerError AppMConstraints x y) -> x -> m y
381+lookupCache f x = do
382+ cm <- asks f
383+ CM.lookupBlocking cm x
290384
291−either500S :: MonadError ServerError m => Either String x -> m x
292−either500S (Right x) = pure x
293−either500S (Left err) = throwError err500 {errBody = BSLC.pack err}
385+defaultDeploymentKeysH :: AppMConstraints m => m [Text]
386+defaultDeploymentKeysH = lookupCache depOverrideKeysCache ()
294387
295−defaultDeploymentKeysH :: AppM [Text]
296−defaultDeploymentKeysH = do
297− (_, Stdout out, _) <- deploymentOverrideKeys >>= runCommandArgs deploymentOverrideKeysCommand
298− pure $ T.lines out
388+defaultDeploymentOverridesH :: AppMConstraints m => m (DefaultConfig 'DeploymentLevel)
389+defaultDeploymentOverridesH = lookupCache depOverridesCache ()
299390
300−defaultDeploymentOverridesH :: AppM (DefaultConfig 'DeploymentLevel)
301−defaultDeploymentOverridesH = do
302− (_, Stdout out, _) <- defaultDeploymentOverridesArgs >>= runCommandArgs deploymentOverridesCommand
303− either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
391+defaultApplicationKeysH :: AppMConstraints m => Config 'DeploymentLevel -> m [Text]
392+defaultApplicationKeysH = lookupCache appOverrideKeysCache
304393
305−defaultApplicationKeysH :: Config 'DeploymentLevel -> AppM [Text]
306−defaultApplicationKeysH cfg = do
307− (_, Stdout out, _) <- applicationOverrideKeys cfg >>= runCommandArgs applicationOverrideKeysCommand
308− pure $ T.lines out
394+defaultApplicationOverridesH :: AppMConstraints m => Config 'DeploymentLevel -> m (DefaultConfig 'ApplicationLevel)
395+defaultApplicationOverridesH = lookupCache appOverridesCache
309396
310−defaultApplicationOverridesH :: Config 'DeploymentLevel -> AppM (DefaultConfig 'ApplicationLevel)
311−defaultApplicationOverridesH cfg = do
312− (_, Stdout out, _) <- defaultApplicationOverridesArgs cfg >>= runCommandArgs applicationOverridesCommand
313− either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
397+runServer :: (KatipContext m, MonadBase IO m, MonadReader AppState m) => Port -> m ()
398+runServer portNum = katipAddNamespace "app" $ runApp portNum (Proxy @API) EmptyContext server
314399
315400-- | Application with the octo CLI API.
316−powerApp :: AuthHeader -> AppState -> IO Application
317−powerApp h s = do
318− jwk' <- liftIO $ genJWK (RSAGenParam (4096 `div` 8))
401+runPowerServer :: (KatipContext m, MonadBase IO m, MonadReader AppState m) => Port -> AuthHeader -> m ()
402+runPowerServer portNum h = katipAddNamespace "powerApp" $ do
403+ jwk' <- liftBase $ genJWK (RSAGenParam (4096 `div` 8))
319404 let ctx :: Servant.Context Ctx
320405 ctx =
321406 h
322407 :. (defaultJWTSettings jwk' :: JWTSettings)
323408 :. (defaultCookieSettings :: CookieSettings)
324409 :. EmptyContext
325−
326− return $
327− serveWithContext api ctx $
328− hoistServerWithContext api (Proxy @Ctx) (nt s) powerServer
329− where
330− api = Proxy @PowerAPI
410+ runApp portNum (Proxy @PowerAPI) ctx powerServer
331411
332412type Ctx = '[AuthHeader, JWTSettings, CookieSettings]
333413
@@ -340,16 +420,16 @@ powerServer (Authenticated ()) =
340420 :<|> statusH
341421 :<|> cleanupH
342422 :<|> restoreH
423+ :<|> deleteH
343424 )
344425 :<|> getActionInfoH
345− :<|> cleanArchiveH
346426powerServer _ = throwAll err401
347427
348428-- | Application with the WS API.
349−wsApp :: TChan WSEvent -> Application
350−wsApp channel = serve api $ wsServer channel
351− where
352− api = Proxy @WebSocketAPI
429+runWsServer :: (KatipContext m, MonadBase IO m, MonadReader AppState m) => Port -> TChan WSEvent -> m ()
430+runWsServer portNum channel =
431+ katipAddNamespace "wsApp" $
432+ runApp portNum (Proxy @WebSocketAPI) EmptyContext $ wsServer channel
353433
354434-- | Request handlers of the application with the WS API.
355435wsServer :: TChan WSEvent -> Server WebSocketAPI
@@ -373,7 +453,7 @@ powerListH = getFullInfo
373453
374454-- | Handles the 'full_info' request of the Web UI API.
375455fullInfoH ::
376− (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>
456+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>
377457 DeploymentName ->
378458 m DeploymentFullInfo
379459fullInfoH dName = do
@@ -382,7 +462,7 @@ fullInfoH dName = do
382462 Nothing ->
383463 throwError
384464 err404
385− { errBody = validationError ["Name not found"] []
465+ { errBody = validationError ["Name not found"]
386466 }
387467
388468-- | Handles the 'full_info' request of the octo CLI API.
@@ -390,27 +470,27 @@ powerFullInfoH :: DeploymentName -> AppM DeploymentFullInfo
390470powerFullInfoH = fullInfoH
391471
392472getSingleFullInfo ::
393− (MonadReader AppState m, MonadBaseControl IO m) =>
473+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m) =>
394474 DeploymentName ->
395475 m (Maybe DeploymentFullInfo)
396476getSingleFullInfo dName = do
397− AppState {logger = l} <- ask
398477 deploymentsSchema <- runStatement . select $ do
399478 d <- each deploymentSchema
400479 where_ $ d ^. #name ==. litExpr dName
401480 pure d
402− deployments <- forM deploymentsSchema extractDeploymentFullInfo
403− liftBase . logInfo l $ "get deployments: " <> (pack . show $ deployments)
481+ deployments <- for deploymentsSchema extractDeploymentFullInfo
482+ logLocM DebugS $ "get deployments: " <> show' deployments
404483 return $ listToMaybe deployments
405484
406485getFullInfo ::
407− (MonadReader AppState m, MonadBaseControl IO m) =>
486+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m) =>
408487 m [DeploymentFullInfo]
409488getFullInfo = do
410− AppState {logger = l} <- ask
411− deploymentsSchema <- runStatement . select $ each deploymentSchema
412− deployments <- forM deploymentsSchema extractDeploymentFullInfo
413− liftBase . logInfo l $ "get deployments: " <> (pack . show $ deployments)
489+ deploymentsSchema <-
490+ runStatement . select . orderBy (view #updatedAt >$< desc) $
491+ each deploymentSchema
492+ deployments <- for deploymentsSchema extractDeploymentFullInfo
493+ logLocM DebugS $ "get deployments: " <> show' deployments
414494 return deployments
415495
416496-- | Handles the 'create' request.
@@ -423,9 +503,8 @@ createH dep = do
423503 \under 17 characters and begin with a letter."
424504 throwError
425505 err400
426− { errBody = validationError [badNameText] []
506+ { errBody = validationError [badNameText]
427507 }
428− t1 <- liftBase getCurrentTime
429508 failIfImageNotFound dep
430509 failIfGracefulShutdownActivated
431510 runDeploymentBgWorker
@@ -433,7 +512,7 @@ createH dep = do
433512 (dep ^. #name)
434513 ( do
435514 res <-
436− L.try $
515+ try $
437516 runStatement $
438517 insert
439518 Insert
@@ -443,13 +522,12 @@ createH dep = do
443522 [ DeploymentSchema
444523 { id_ = unsafeDefault
445524 , name = litExpr $ dep ^. #name
446− , tag = litExpr $ dep ^. #tag
447525 , appOverrides = litExpr $ dep ^. #appOverrides
448526 , deploymentOverrides = litExpr $ dep ^. #deploymentOverrides
449527 , createdAt = now
450528 , updatedAt = now
451529 , archivedAt = litExpr Nothing
452− , status = litExpr Running
530+ , status = litExpr CreatePending
453531 , statusUpdatedAt = now
454532 , checkedAt = now
455533 , metadata = litExpr (DeploymentMetadata [])
@@ -464,94 +542,76 @@ createH dep = do
464542 | code == unique_violation ->
465543 throwError
466544 err400
467− { errBody = validationError ["Deployment already exists"] []
545+ { errBody = validationError ["Deployment already exists"]
468546 }
469547 Left _ ->
470548 throwError err409 {errBody = appError "Some database error"}
471549 )
472550 $ \() -> do
473− st <- ask
474− liftBase $ sendReloadEvent st
551+ sendReloadEvent
475552 updateDeploymentInfo (dep ^. #name)
476− (ec, out, err) <- createDeployment dep
477− t2 <- liftBase getCurrentTime
478− let elTime = elapsedTime t2 t1
553+ (ec, out, err, elTime) <- createDeployment dep
479554 -- calling it directly now is fine since there is no previous status.
480555 createDeploymentLog dep CreateAction ec elTime out err
481− liftBase $ sendReloadEvent st
482− liftBase $ handleExitCode ec
556+ sendReloadEvent
557+ handleExitCode ec
483558 pure Success
484559
485560-- | Updates deployment info.
486561updateDeploymentInfo ::
487− (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>
562+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>
488563 DeploymentName ->
489564 m ()
490565updateDeploymentInfo dName = do
491− log <- asks (logWarning . logger)
492566 DeploymentFullInfo {deployment = dep} <- getDeploymentS dName
493− dc <- getDefaultConfig dName
494− (ec, out, err) <- runCommandArgs infoCommand =<< infoCommandArgs dc dep
567+ cfg <- getDeploymentConfig dep
568+ (ec, out, err, _) <- runCommandArgs infoCommand =<< infoCommandArgs cfg dep
495569 case ec of
496570 ExitSuccess -> case parseDeploymentMetadata (unStdout out) of
497571 Right dMeta -> upsertDeploymentMetadatum dName dMeta
498− Left err' -> liftBase $ log $ "could not get deployment info, could not parse CSV: " <> T.pack err'
572+ Left err' -> logLocM ErrorS $ "could not get deployment info, could not parse CSV: " <> logStr err'
499573 ExitFailure _ ->
500− liftBase $
501− log $
502− "could not get deployment info, exit code: " <> (pack . show $ ec)
503− <> ", stdout: "
504− <> coerce out
505− <> "stderr: "
506− <> coerce err
507−
508−getDefaultConfig :: Monad m => DeploymentName -> m FullDefaultConfig
509−getDefaultConfig _ =
574+ logLocM ErrorS $
575+ "could not get deployment info, exit code: " <> show' ec
576+ <> ", stdout: "
577+ <> logStr (unStdout out)
578+ <> "stderr: "
579+ <> logStr (unStderr err)
580+
581+getDeploymentConfig :: AppMConstraints m => Deployment -> m FullConfig
582+getDeploymentConfig dep = do
583+ depCfg <- applyOverrides (dep ^. #deploymentOverrides) <$> defaultDeploymentOverridesH
584+ appCfg <- applyOverrides (dep ^. #appOverrides) <$> defaultApplicationOverridesH depCfg
510585 pure
511− FullDefaultConfig
512− { appDefaultConfig = DefaultConfig OM.empty
513− , depDefaultConfig = DefaultConfig OM.empty
586+ FullConfig
587+ { appConfig = appCfg
588+ , depConfig = depCfg
514589 }
515590
516591-- | Helper to create a new deployment.
517592createDeployment ::
518− (MonadBaseControl IO m, MonadReader AppState m) =>
593+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>
519594 Deployment ->
520− m (ExitCode, Stdout, Stderr)
595+ m (ExitCode, Stdout, Stderr, Duration)
521596createDeployment dep = do
522− st <- ask
523− dCfg <- getDefaultConfig $ dep ^. #name
524− let log :: Text -> IO ()
525− log = logInfo (logger st)
526− args =
527− ControlScriptArgs
528− [ "--project-name"
529− , T.unpack . coerce $ projectName st
530− , "--base-domain"
531− , T.unpack . coerce $ baseDomain st
532− , "--namespace"
533− , T.unpack . coerce $ namespace st
534− , "--name"
535− , T.unpack . coerce $ dep ^. #name
536− , "--tag"
537− , T.unpack . coerce $ dep ^. #tag
538− ]
539− <> fullConfigArgs dCfg dep
540− (ec, out, err) <- runCommandArgs creationCommand args
541− liftBase . log $ "deployment created, deployment: " <> (pack . show $ dep)
542− pure (ec, out, err)
597+ cfg <- getDeploymentConfig dep
598+ res <- runCommandArgs creationCommand =<< createCommandArgs cfg dep
599+ logLocM InfoS $ "deployment created, deployment: " <> show' dep
600+ pure res
543601
544602-- | Helper to get deployment logs.
545603selectDeploymentLogs ::
546− (MonadBaseControl IO m, MonadReader AppState m) =>
604+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) =>
547605 DeploymentName ->
548606 m [DeploymentLog]
549−selectDeploymentLogs dName = (fmap . fmap) extractDeploymentLog . runStatement . select $ do
550− dls <- each deploymentLogSchema
551− ds <- each deploymentSchema
552− where_ $ ds ^. #name ==. litExpr dName
553− where_ $ dls ^. #deploymentId ==. ds ^. #id_
554− pure dls
607+selectDeploymentLogs dName = (fmap . fmap) extractDeploymentLog . runStatement . select
608+ . orderBy (view #createdAt >$< desc)
609+ $ do
610+ dls <- each deploymentLogSchema
611+ ds <- each deploymentSchema
612+ where_ $ ds ^. #name ==. litExpr dName
613+ where_ $ dls ^. #deploymentId ==. ds ^. #id_
614+ pure dls
555615
556616data StatusTransitionProcessOutput = StatusTransitionProcessOutput
557617 { exitCode :: ExitCode
@@ -569,6 +629,7 @@ data DeploymentStatusTransition
569629 | TransitionArchivePending StatusTransitionProcessOutput
570630 | TransitionUpdatePending StatusTransitionProcessOutput
571631 | TransitionCreatePending StatusTransitionProcessOutput
632+ | TransitionCleanupFailed StatusTransitionProcessOutput
572633 | TransitionFailure FailureType
573634 deriving stock (Show)
574635
@@ -580,6 +641,7 @@ transitionStatus TransitionRestore {} = CreatePending
580641transitionStatus TransitionArchivePending {} = ArchivePending
581642transitionStatus TransitionUpdatePending {} = UpdatePending
582643transitionStatus TransitionCreatePending {} = CreatePending
644+transitionStatus TransitionCleanupFailed {} = CleanupFailed
583645transitionStatus (TransitionFailure t) = Failure t
584646
585647processOutput :: DeploymentStatusTransition -> Maybe (StatusTransitionProcessOutput, Action)
@@ -590,10 +652,11 @@ processOutput (TransitionRestore x) = Just (x, RestoreAction)
590652processOutput (TransitionArchivePending x) = Just (x, ArchiveAction)
591653processOutput (TransitionUpdatePending x) = Just (x, UpdateAction)
592654processOutput (TransitionCreatePending x) = Just (x, CreateAction)
655+processOutput (TransitionCleanupFailed x) = Just (x, CleanupAction)
593656processOutput TransitionFailure {} = Nothing
594657
595658transitionToStatusS ::
596− (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) =>
659+ (KatipContext m, MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) =>
597660 DeploymentName ->
598661 DeploymentStatusTransition ->
599662 m ()
@@ -627,7 +690,7 @@ transitionErrorToServerError = \case
627690 show'' = BSLC.pack . show
628691
629692getDeploymentS ::
630− (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>
693+ (KatipContext m, MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>
631694 DeploymentName ->
632695 m DeploymentFullInfo
633696getDeploymentS dName =
@@ -636,15 +699,13 @@ getDeploymentS dName =
636699 Nothing -> throwError err404 {errBody = "Deployment not found."}
637700
638701transitionToStatus ::
639− (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) =>
702+ (KatipContext m, MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) =>
640703 DeploymentName ->
641704 DeploymentStatusTransition ->
642705 ExceptT StatusTransitionError m ()
643706transitionToStatus dName s = do
644− st <- ask
645− let log = liftBase . logInfo (logger st)
646− newS = transitionStatus s
647− log $ "Transitioning deployment " <> (show' . unDeploymentName) dName <> " " <> show' s
707+ let newS = transitionStatus s
708+ logLocM InfoS $ "Transitioning deployment " <> show' (unDeploymentName dName) <> " " <> show' s
648709 res <- runTransaction . runExceptT $ do
649710 oldS <-
650711 (lift . statement () . select)
@@ -669,6 +730,7 @@ transitionToStatus dName s = do
669730 dep
670731 & #status .~ litExpr newS
671732 & #updatedAt .~ now
733+ & #statusUpdatedAt .~ now
672734 & if newS == Archived then #archivedAt .~ nullify now else id
673735 , updateWhere = \() dep -> dep ^. #name ==. litExpr dName
674736 , returning = Projection id
@@ -677,7 +739,7 @@ transitionToStatus dName s = do
677739 (deps, oldS) <- either throwError pure res
678740 dep <- lift $ ensureOne deps
679741 lift $
680− forM_ (processOutput s) $ \(output, act) ->
742+ for_ (processOutput s) $ \(output, act) ->
681743 createDeploymentLog
682744 dep
683745 act
@@ -686,11 +748,11 @@ transitionToStatus dName s = do
686748 (output ^. #stdout)
687749 (output ^. #stderr)
688750 notificationCmd <- asks notificationCommand
689− forM_ notificationCmd $ \nCmd ->
751+ for_ notificationCmd $ \nCmd ->
690752 runBgWorker . void $
691753 runCommandArgs' nCmd
692− =<< notificationCommandArgs dName (dep ^. #tag) oldS newS
693− liftBase $ sendReloadEvent st
754+ =<< notificationCommandArgs dName oldS newS
755+ sendReloadEvent
694756
695757assertStatusTransitionPossible ::
696758 MonadError StatusTransitionError m =>
@@ -704,7 +766,7 @@ assertStatusTransitionPossible dName old new =
704766 (throwError $ InvalidStatusTransition dName old new)
705767
706768assertDeploymentTransitionPossible ::
707− (MonadError StatusTransitionError m, MonadReader AppState m, MonadBaseControl IO m) =>
769+ (KatipContext m, MonadError StatusTransitionError m, MonadReader AppState m, MonadBaseControl IO m) =>
708770 DeploymentName ->
709771 DeploymentStatus ->
710772 m ()
@@ -716,7 +778,7 @@ assertDeploymentTransitionPossible dName new = do
716778 assertStatusTransitionPossible dName (recordedStatus $ dep ^. #status) new
717779
718780assertDeploymentTransitionPossibleS ::
719− (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) =>
781+ (KatipContext m, MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) =>
720782 DeploymentName ->
721783 DeploymentStatus ->
722784 m ()
@@ -732,9 +794,10 @@ possibleTransitions :: DeploymentStatus -> DeploymentStatus -> Bool
732794possibleTransitions CreatePending = anyPred [is #_Running, is #_Failure]
733795possibleTransitions Running = anyPred [is #_Failure, is #_ArchivePending, is #_UpdatePending]
734796possibleTransitions UpdatePending = anyPred [is #_Failure, is #_Running]
735−possibleTransitions (Failure _) = anyPred [is #_UpdatePending, is #_Running, is #_ArchivePending]
797+possibleTransitions (Failure _) = anyPred [is #_UpdatePending, is #_Running, is #_ArchivePending, is #_CleanupFailed]
736798possibleTransitions ArchivePending = anyPred [is #_ArchivePending, is #_Archived]
737−possibleTransitions Archived = anyPred [is #_CreatePending]
799+possibleTransitions Archived = anyPred [is #_CreatePending, is #_CleanupFailed]
800+possibleTransitions CleanupFailed = const False
738801
739802anyPred :: [a -> Bool] -> a -> Bool
740803anyPred preds x = any ($ x) preds
@@ -743,25 +806,10 @@ anyPred preds x = any ($ x) preds
743806archiveH :: DeploymentName -> AppM CommandResponse
744807archiveH dName = do
745808 failIfGracefulShutdownActivated
746− t1 <- liftBase getCurrentTime
747− st <- ask
748− let log = liftBase . logInfo (logger st)
749− args =
750− [ "--project-name"
751− , coerce $ projectName st
752− , "--base-domain"
753− , coerce $ baseDomain st
754− , "--namespace"
755− , coerce $ namespace st
756− , "--name"
757− , coerce dName
758− ]
759− cmd = coerce $ archiveCommand st
760809 runDeploymentBgWorker (Just ArchivePending) dName (pure ()) $ \() -> do
761− log $ "call " <> unwords (cmd : args)
762− (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
763− t2 <- liftBase getCurrentTime
764− let elTime = elapsedTime t2 t1
810+ (view #deployment -> dep) <- getDeploymentS dName
811+ cfg <- getDeploymentConfig dep
812+ (ec, out, err, elTime) <- runCommandArgs archiveCommand =<< archiveCommandArgs cfg dep
765813 transitionToStatusS dName $
766814 TransitionArchivePending
767815 StatusTransitionProcessOutput
@@ -777,9 +825,6 @@ archiveH dName = do
777825updateH :: DeploymentName -> DeploymentUpdate -> AppM CommandResponse
778826updateH dName dUpdate = do
779827 failIfGracefulShutdownActivated
780− t1 <- liftIO getCurrentTime
781− st <- ask
782− let log = logInfo (logger st)
783828 olDep <- getDeploymentS dName <&> (^. #deployment)
784829 failIfImageNotFound
785830 ( olDep
@@ -798,7 +843,6 @@ updateH dName dUpdate = do
798843 , set = \() ds ->
799844 ds & #appOverrides .~ litExpr (dUpdate ^. #appOverrides)
800845 & #deploymentOverrides .~ litExpr (dUpdate ^. #deploymentOverrides)
801− & #tag .~ litExpr (dUpdate ^. #newTag)
802846 , updateWhere = \() ds -> ds ^. #name ==. litExpr dName
803847 , returning = Projection id
804848 }
@@ -806,30 +850,13 @@ updateH dName dUpdate = do
806850 >>= ensureOne
807851
808852 updateDeploymentInfo dName
809− liftBase $ sendReloadEvent st
810− dCfg <- getDefaultConfig dName
811− let args =
812− ControlScriptArgs
813− [ "--project-name"
814− , T.unpack . coerce $ projectName st
815− , "--base-domain"
816− , T.unpack . coerce $ baseDomain st
817− , "--namespace"
818− , T.unpack . coerce $ namespace st
819− , "--name"
820− , T.unpack . coerce $ dName
821− , "--tag"
822− , T.unpack . coerce $ dep ^. #tag
823− ]
824− <> fullConfigArgs dCfg dep
825− (ec, out, err) <- runCommandArgs updateCommand args
826− liftBase . log $
827− "deployment updated, name: "
828− <> coerce dName
829− <> ", tag: "
830− <> coerce (dep ^. #tag)
831− t2 <- liftBase getCurrentTime
832− let elTime = elapsedTime t2 t1
853+ sendReloadEvent
854+ cfg <- getDeploymentConfig dep
855+ (ec, out, err, elTime) <- runCommandArgs updateCommand =<< updateCommandArgs cfg dep
856+ logLocM DebugS $
857+ logStr $
858+ "deployment updated, name: "
859+ <> unDeploymentName dName
833860 transitionToStatusS dName $
834861 TransitionUpdatePending
835862 StatusTransitionProcessOutput
@@ -844,19 +871,15 @@ updateH dName dUpdate = do
844871-- | Handles the 'info' request of the Web UI API.
845872infoH :: DeploymentName -> AppM [DeploymentInfo]
846873infoH dName = do
847− st <- ask
848874 dInfo <- getInfo dName
849− liftIO . logInfo (logger st) $
850− "get deployment info: " <> (pack . show $ dInfo)
875+ logLocM DebugS $ "get deployment info: " <> show' dInfo
851876 pure [dInfo]
852877
853878-- | Handles the 'info' request of the octo CLI API.
854879powerInfoH :: DeploymentName -> AppM [DeploymentInfo]
855880powerInfoH dName = do
856− st <- ask
857881 dInfo <- getInfo dName
858− liftIO . logInfo (logger st) $
859− "get deployment info: " <> (pack . show $ dInfo)
882+ logLocM DebugS $ "get deployment info: " <> show' dInfo
860883 pure [dInfo]
861884
862885-- | Helper to get deployment info from the database.
@@ -872,10 +895,10 @@ getInfo dName = do
872895 }
873896
874897-- | Handles the 'ping' request.
875−pingH :: AppM NoContent
898+pingH :: AppM Text
876899pingH = do
877900 _ <- runStatement $ select $ pure $ litExpr True
878− pure NoContent
901+ asks gitSha
879902
880903-- | Handles the 'project_name' request.
881904projectNameH :: AppM ProjectName
@@ -884,9 +907,9 @@ projectNameH = asks projectName
884907-- | Handles the 'status' request.
885908statusH :: DeploymentName -> AppM CurrentDeploymentStatus
886909statusH dName = do
887− dep <- getDeploymentS dName
888− dCfg <- getDefaultConfig dName
889− (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs dCfg (dep ^. #deployment)
910+ (view #deployment -> dep) <- getDeploymentS dName
911+ cfg <- getDeploymentConfig dep
912+ (ec, _, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep
890913 pure . CurrentDeploymentStatus $
891914 case ec of
892915 ExitSuccess -> Ok
@@ -899,37 +922,55 @@ cleanupH dName = do
899922 runDeploymentBgWorker Nothing dName (pure ()) $ \() -> cleanupDeployment dName
900923 pure Success
901924
925+-- | Deletes the deployment from the DB.
926+deleteH :: DeploymentName -> AppM CommandResponse
927+deleteH dName = do
928+ failIfGracefulShutdownActivated
929+ runDeploymentBgWorker Nothing dName (pure ()) $ \() -> deleteAllDeployment dName
930+ pure Success
931+
902932-- | Helper to cleanup deployment.
903933cleanupDeployment ::
904− (MonadBaseControl IO m, MonadReader AppState m) =>
934+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>
905935 DeploymentName ->
906936 m ()
907937cleanupDeployment dName = do
908− st <- ask
909− let log = logInfo (logger st)
910− args =
911− [ "--project-name"
912− , coerce $ projectName st
913− , "--base-domain"
914− , coerce $ baseDomain st
915− , "--namespace"
916− , coerce $ namespace st
917− , "--name"
918− , coerce dName
919− ]
920− cmd = coerce $ cleanupCommand st
921− liftBase . log $ "call " <> unwords (cmd : args)
922− (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
923− liftBase $ print out >> print err
938+ (view #deployment -> dep) <- getDeploymentS dName
939+ cfg <- getDeploymentConfig dep
940+ (ec, out, err, elTime) <- runCommandArgs cleanupCommand =<< cleanupCommandArgs cfg dep
941+ katipAddContext (FilePayload "stdout" $ T.encodeUtf8 $ unStdout out) $
942+ katipAddContext (FilePayload "stdout" $ T.encodeUtf8 $ unStderr err) $
943+ logLocM DebugS "deployment destroyed"
944+ case ec of
945+ ExitSuccess -> do
946+ deleteDeploymentLogs dName
947+ deleteDeployment dName
948+ logLocM InfoS $ logStr $ "deployment destroyed, name: " <> unDeploymentName dName
949+ ExitFailure _ -> do
950+ transitionToStatusS dName $
951+ TransitionCleanupFailed
952+ StatusTransitionProcessOutput
953+ { exitCode = ec
954+ , duration = elTime
955+ , stdout = out
956+ , stderr = err
957+ }
958+ pure ()
959+ sendReloadEvent
960+ handleExitCode ec
961+
962+deleteAllDeployment ::
963+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) =>
964+ DeploymentName ->
965+ m ()
966+deleteAllDeployment dName = do
924967 deleteDeploymentLogs dName
925968 deleteDeployment dName
926− liftBase $ log $ "deployment destroyed, name: " <> coerce dName
927− liftBase $ sendReloadEvent st
928− handleExitCode ec
969+ logLocM InfoS $ logStr $ "deployment destroyed, name: " <> unDeploymentName dName
929970
930971-- | Helper to delete deployment logs.
931972deleteDeploymentLogs ::
932− (MonadBaseControl IO m, MonadReader AppState m) =>
973+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) =>
933974 DeploymentName ->
934975 m ()
935976deleteDeploymentLogs dName =
@@ -944,7 +985,7 @@ deleteDeploymentLogs dName =
944985
945986-- | Helper to delete a deployment.
946987deleteDeployment ::
947− (MonadBaseControl IO m, MonadReader AppState m) =>
988+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) =>
948989 DeploymentName ->
949990 m ()
950991deleteDeployment dName =
@@ -957,40 +998,18 @@ deleteDeployment dName =
957998 , returning = pure ()
958999 }
9591000
960−-- | Handles the 'clean-archive' request.
961−cleanArchiveH :: AppM CommandResponse
962−cleanArchiveH = do
963− failIfGracefulShutdownActivated
964− st <- ask
965− let archRetention = unArchiveRetention . archiveRetention $ st
966− cutoff <- liftBase getCurrentTime <&> addUTCTime (negate archRetention)
967− dNames <- runStatement $
968− select $ do
969− ds <- each deploymentSchema
970− where_ $ (ds ^. #status) `in_` (litExpr <$> archivedStatuses)
971− where_ $ ds ^. #archivedAt <. litExpr (Just cutoff)
972− pure $ ds ^. #name
973− runBgWorker . void $
974− for dNames $ \dName ->
975− runDeploymentBgWorker Nothing dName (pure ()) $ \() -> cleanupDeployment dName
976−
977− pure Success
978−
9791001-- | Handles the 'restore' request.
9801002restoreH :: DeploymentName -> AppM CommandResponse
9811003restoreH dName = do
9821004 failIfGracefulShutdownActivated
983− t1 <- liftBase getCurrentTime
9841005 dep <- getDeploymentS dName
9851006 failIfImageNotFound $ dep ^. #deployment
9861007 failIfGracefulShutdownActivated
9871008 runDeploymentBgWorker (Just CreatePending) dName (pure ()) $ \() -> do
988− dep' <- getDeploymentS dName
1009+ (view #deployment -> dep') <- getDeploymentS dName
9891010 updateDeploymentInfo dName
990− dCfg <- getDefaultConfig dName
991− (ec, out, err) <- runCommandArgs unarchiveCommand =<< unarchiveCommandArgs dCfg (dep' ^. #deployment)
992− t2 <- liftBase getCurrentTime
993− let elTime = elapsedTime t2 t1
1011+ cfg <- getDeploymentConfig dep'
1012+ (ec, out, err, elTime) <- runCommandArgs unarchiveCommand =<< unarchiveCommandArgs cfg dep'
9941013 transitionToStatusS dName $
9951014 TransitionRestore
9961015 StatusTransitionProcessOutput
@@ -1016,13 +1035,13 @@ getActionInfoH aId = do
10161035 throwError err400 {errBody = appError "Action not found"}
10171036
10181037-- | Helper to handle exit code.
1019−handleExitCode :: MonadBaseControl IO m => ExitCode -> m ()
1038+handleExitCode :: MonadBase IO m => ExitCode -> m ()
10201039handleExitCode ExitSuccess = return ()
1021−handleExitCode (ExitFailure c) = liftBase . throwIO $ DeploymentFailed c
1040+handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c
10221041
10231042-- | Helper to log a deployment action.
10241043createDeploymentLog ::
1025− (MonadBaseControl IO m, MonadReader AppState m) =>
1044+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) =>
10261045 Deployment ->
10271046 Action ->
10281047 ExitCode ->
@@ -1047,7 +1066,6 @@ createDeploymentLog dep act ec dur out err = do
10471066 { actionId = unsafeDefault
10481067 , deploymentId = litExpr dId
10491068 , action = litExpr act
1050− , deploymentTag = litExpr $ dep ^. #tag
10511069 , exitCode = litExpr $ case ec of
10521070 ExitSuccess -> 0
10531071 ExitFailure errCode -> fromIntegral errCode
@@ -1070,7 +1088,7 @@ ensureOne _ = throwError err500
10701088
10711089-- | Helper to insert or update deployment metadata.
10721090upsertDeploymentMetadatum ::
1073− (MonadBaseControl IO m, MonadReader AppState m) =>
1091+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) =>
10741092 DeploymentName ->
10751093 DeploymentMetadata ->
10761094 m ()
@@ -1089,60 +1107,58 @@ upsertDeploymentMetadatum dName dMetadata =
10891107-- Returns 404 'Tag not found' response if the deployment tag doesn't exist.
10901108failIfImageNotFound :: Deployment -> AppM ()
10911109failIfImageNotFound dep = do
1092− dCfg <- getDefaultConfig $ dep ^. #name
1093− (ec, _, _) <- runCommandArgs tagCheckingCommand =<< tagCheckCommandArgs dCfg dep
1110+ cfg <- getDeploymentConfig dep
1111+ (ec, Stdout out, _, _) <- runCommandArgs configCheckingCommand =<< configCheckCommandArgs cfg dep
10941112 case ec of
10951113 ExitSuccess -> pure ()
10961114 ExitFailure _ ->
1097− throwError err400 {errBody = validationError [] ["Tag not found"]}
1115+ throwError err400 {errBody = BSL.fromStrict $ T.encodeUtf8 out}
10981116
10991117-- | Helper to create an application-level error.
11001118appError :: Text -> BSL.ByteString
11011119appError = encode . AppError
11021120
11031121-- | Helper to create a validation-level error.
1104−validationError :: [Text] -> [Text] -> BSL.ByteString
1105−validationError nameErrors tagErrors =
1106− encode $ ValidationError nameErrors tagErrors
1122+validationError :: [Text] -> BSL.ByteString
1123+validationError nameErrors =
1124+ encode $ ValidationError nameErrors
11071125
11081126-- | Helper to send an event to the WS event channel.
1109−sendReloadEvent :: AppState -> IO ()
1110−sendReloadEvent state =
1111− atomically $ writeTChan (eventSink state) FrontendPleaseUpdateEverything
1112−
1113−-- | Returns time delta between 2 timestamps.
1114−elapsedTime :: UTCTime -> UTCTime -> Duration
1115−elapsedTime t1 t2 = Duration . calendarTimeTime $ t2 `diffUTCTime` t1
1127+sendReloadEvent :: (MonadBase IO m, MonadReader AppState m) => m ()
1128+sendReloadEvent = do
1129+ sink <- asks eventSink
1130+ liftBase $ atomically $ writeTChan sink FrontendPleaseUpdateEverything
11161131
11171132-- | Runs the status updater.
1118−runStatusUpdater :: AppState -> IO ()
1119−runStatusUpdater state = do
1133+runStatusUpdater :: (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) => m ()
1134+runStatusUpdater = do
11201135 let interval = 15 :: NominalDiffTime
1121− logErr :: MonadBase IO m => Text -> m ()
1122− logErr = liftBase . logWarning (logger state)
11231136
11241137 forever $ do
11251138 currentTime <- liftBase getCurrentTime
11261139 let cutoff = addUTCTime (negate interval) currentTime
1127− flip runReaderT state $ do
1140+ (>>= logLeft) . runExceptT $ do
11281141 rows' <- runStatement . select $ do
11291142 ds <- each deploymentSchema
11301143 where_ $ ds ^. #checkedAt <. litExpr cutoff
1131− where_ $ ds ^. #status /=. litExpr Archived
1132− pure (ds ^. #name, ds ^. #status, now `diffTime` (ds ^. #statusUpdatedAt), ds ^. #tag)
1133− checkResult <- for rows' $ \(dName, dStatus, Timestamp -> ts, _) -> do
1134− let timeout = statusUpdateTimeout state
1135− mEc <- case dStatus of
1136− ArchivePending -> do
1137− (ec, _, _) <- runCommandArgs archiveCheckingCommand =<< archiveCheckArgs dName
1138− pure $ Just ec
1139− _ -> do
1140− getSingleFullInfo dName >>= \case
1141− Nothing -> liftBase (logErr $ "Couldn't find deployment: " <> coerce dName) $> Nothing
1142− Just dep -> do
1143− dCfg <- getDefaultConfig dName
1144− (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs dCfg (dep ^. #deployment)
1145− pure $ Just ec
1144+ where_ $ not_ $ (ds ^. #status) `in_` (litExpr <$> [Archived, CleanupFailed])
1145+ pure (ds ^. #name, ds ^. #status, now `diffTime` (ds ^. #statusUpdatedAt))
1146+ checkResult <- for rows' $ \(dName, dStatus, Timestamp -> ts) -> do
1147+ timeout <- asks statusUpdateTimeout
1148+ mEc <-
1149+ getSingleFullInfo dName >>= \case
1150+ Nothing -> do
1151+ logLocM ErrorS $ logStr $ "Couldn't find deployment: " <> unDeploymentName dName
1152+ pure Nothing
1153+ Just (view #deployment -> dep) -> do
1154+ cfg <- getDeploymentConfig dep
1155+ case dStatus of
1156+ ArchivePending -> do
1157+ (ec, _, _, _) <- runCommandArgs archiveCheckingCommand =<< archiveCheckArgs cfg dep
1158+ pure $ Just ec
1159+ _ -> do
1160+ (ec, _, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep
1161+ pure $ Just ec
11461162 pure $ mEc <&> \ec -> (dName, statusTransition ec dStatus ts timeout, dStatus)
11471163 updated <-
11481164 for (catMaybes checkResult) $ \(dName, transitionM, dStatus) ->
@@ -1162,10 +1178,14 @@ runStatusUpdater state = do
11621178 ($> True) $
11631179 (runExceptT . runExceptT) (transitionToStatus dName transition) >>= \case
11641180 Right (Right ()) -> updateCheckedAt (transitionStatus transition)
1165− Left e -> logErr $ show' e
1166− Right (Left e) -> logErr $ show' e
1167− when (Prelude.or updated) $ liftBase $ sendReloadEvent state
1168− liftBase $ threadDelay 2000000
1181+ Left e -> logLocM ErrorS $ show' e
1182+ Right (Left e) -> logLocM ErrorS $ show' e
1183+ when (Prelude.or updated) sendReloadEvent
1184+ threadDelay 2000000
1185+
1186+logLeft :: (HasCallStack, KatipContext m, Exception e) => Either e () -> m ()
1187+logLeft (Left err) = logLocM ErrorS $ logStr $ displayException err
1188+logLeft (Right ()) = pure ()
11691189
11701190-- | Returns the new deployment status.
11711191statusTransition ::
@@ -1196,16 +1216,20 @@ failureStatusType _ = GenericFailure
11961216-- if graceful shutdown has been activated.
11971217failIfGracefulShutdownActivated :: AppM ()
11981218failIfGracefulShutdownActivated = do
1199− gracefulShutdownAct <- gracefulShutdownActivated <$> ask
1200− gracefulShutdown <- liftIO . readIORef $ gracefulShutdownAct
1219+ gracefulShutdown <- isShuttingDown
12011220 if gracefulShutdown
12021221 then throwError err405 {errBody = appError "Graceful shutdown activated"}
12031222 else pure ()
12041223
1224+isShuttingDown :: (MonadReader AppState m, MonadBase IO m) => m Bool
1225+isShuttingDown = do
1226+ gracefulShutdownAct <- gracefulShutdownActivated <$> ask
1227+ readIORef $ gracefulShutdownAct
1228+
12051229-- | Handles the graceful shutdown signal.
12061230-- Sends a signal to the 'shutdownSem' semaphore
12071231-- if the background worker counter is 0.
1208−terminationHandler :: IORef Int -> IORef Bool -> MVar () -> IO ()
1232+terminationHandler :: MonadBase IO m => IORef Int -> IORef Bool -> MVar () -> m ()
12091233terminationHandler bgWorkersC gracefulShudownAct shutdownS = do
12101234 atomicWriteIORef gracefulShudownAct True
12111235 c <- readIORef bgWorkersC
@@ -1215,8 +1239,10 @@ terminationHandler bgWorkersC gracefulShudownAct shutdownS = do
12151239
12161240-- | Waits on the 'shutdownSem' semaphore to determine when the
12171241-- server can shut down.
1218−runShutdownHandler :: AppState -> IO ()
1219−runShutdownHandler = takeMVar . shutdownSem
1242+runShutdownHandler :: (MonadBase IO m, MonadReader AppState m) => m ()
1243+runShutdownHandler = do
1244+ sem <- asks shutdownSem
1245+ takeMVar sem
12201246
12211247-- | Runs background the worker and increases the background worker counter.
12221248-- Decreases background worker counter
@@ -1225,24 +1251,46 @@ runShutdownHandler = takeMVar . shutdownSem
12251251-- if the background worker counter is 0
12261252-- and graceful shutdown is activated.
12271253runBgWorker :: (MonadBaseControl IO m, MonadReader AppState m) => m () -> m ()
1228−runBgWorker act = void $ L.forkFinally act' cleanup
1254+runBgWorker act = void $ forkFinally act' cleanup
12291255 where
12301256 act' = do
12311257 state <- ask
1232− liftBase (atomicModifyIORef' (bgWorkersCounter state) (\c -> (c + 1, c))) >> act
1258+ atomicModifyIORef' (bgWorkersCounter state) $ \c -> (c + 1, ())
1259+ act
12331260 cleanup _ = do
12341261 state <- ask
1235− liftBase $ do
1236− c <- atomicModifyIORef' (bgWorkersCounter state) (\c -> (c - 1, c - 1))
1237− gracefulShutdown <- readIORef (gracefulShutdownActivated state)
1238− if gracefulShutdown && c == 0
1239− then putMVar (shutdownSem state) ()
1240− else pure ()
1262+ c <- atomicModifyIORef' (bgWorkersCounter state) $ \c -> (c - 1, c - 1)
1263+ isShutdown <- readIORef (gracefulShutdownActivated state)
1264+ if isShutdown && c == 0
1265+ then putMVar (shutdownSem state) ()
1266+ else pure ()
1267+
1268+runBgWorkerSync ::
1269+ (MonadBaseControl IO m, MonadReader AppState m) =>
1270+ -- | The computation to run, takes a callback for returning a result (and monadic state)
1271+ ((a -> m ()) -> m ()) ->
1272+ m a
1273+runBgWorkerSync act = do
1274+ result <- newEmptyMVar
1275+ runBgWorker $ do
1276+ let respondSync res = do
1277+ state <- liftBaseWith $ \runInBase -> runInBase $ pure res
1278+ tryPutMVar result (Right state) >>= \case
1279+ True -> pure ()
1280+ False -> error "result already submitted by bg worker"
1281+ void $
1282+ try (liftBaseWith $ \runInBase -> runInBase $ act respondSync) >>= \case
1283+ Left e -> tryPutMVar result (Left e)
1284+ Right _ -> tryPutMVar result $ Left $ errorCallException "bg worker did not submit result"
1285+ takeMVar result >>= \case
1286+ Left exc -> throwIO exc
1287+ Right stm -> restoreM stm
12411288
12421289-- | Same as 'runBgWorker' but also locks the specified deployment.
12431290runDeploymentBgWorker ::
12441291 forall m a.
1245− (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>
1292+ (KatipContext m, MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>
1293+ -- | Status to set after the first part has finished.
12461294 Maybe DeploymentStatus ->
12471295 DeploymentName ->
12481296 -- | Think of this as running synchronously.
@@ -1250,35 +1298,22 @@ runDeploymentBgWorker ::
12501298 m a ->
12511299 -- | The computation to run asynchronously.
12521300 (a -> m ()) ->
1253− m ()
1301+ m a
12541302runDeploymentBgWorker newS dName pre post = do
1255− st <- ask
1256− mainThread <- L.myThreadId
1257− (err :: MVar (Either ServerError (StM m a))) <- L.newEmptyMVar
1258− runBgWorker $
1259− withLockedDeployment
1260− dName
1261− (L.putMVar err $ Left err409 {errBody = "The deployment is currently being processed."})
1262− ( do
1263− L.try (liftBaseWith \runInBase -> runInBase pre) >>= \case
1264− Left (e :: L.SomeException) -> L.throwTo mainThread e
1265− Right x -> do
1266− proceed <- flip L.finally (L.tryPutMVar err (Left err500)) $ case newS of
1267− Just newS' -> do
1268− runExceptT (assertDeploymentTransitionPossibleS dName newS') >>= \case
1269− Left e -> L.putMVar err (Left e) $> False
1270− Right () -> L.putMVar err (Right x) $> True
1271− Nothing -> L.putMVar err (Right x) $> True
1272− liftBase (sendReloadEvent st)
1273− when proceed $ restoreM x >>= post
1274− )
1275− L.readMVar err >>= \case
1276− Left e -> throwError e
1277− Right (stm :: StM m a) -> do
1278− -- This might be a bad idea in general, but with just ReaderT and ExceptT
1279− -- it should be fine.
1280− _ :: a <- restoreM stm
1281− return ()
1303+ liftEither =<< runBgWorkerSync worker
1304+ where
1305+ worker respondSync = do
1306+ withLockedDeployment
1307+ dName
1308+ (respondSync $ Left err409 {errBody = "The deployment is currently being processed."})
1309+ ( do
1310+ let preWithAssert = pre <* for newS (assertDeploymentTransitionPossibleS dName)
1311+ result <- catchError (Right <$> preWithAssert) (pure . Left)
1312+ respondSync result
1313+ liftEither result >>= \res -> do
1314+ sendReloadEvent
1315+ post res
1316+ )
12821317
12831318extractDeploymentFullInfo ::
12841319 (MonadReader AppState m, MonadBase IO m) =>
@@ -1287,7 +1322,6 @@ extractDeploymentFullInfo ::
12871322extractDeploymentFullInfo d = do
12881323 let dName = d ^. #name
12891324 locked <- isDeploymentLocked dName
1290− dCfg <- getDefaultConfig dName
12911325 pure
12921326 DeploymentFullInfo
12931327 { deployment = extractDeployment d
@@ -1298,5 +1332,4 @@ extractDeploymentFullInfo d = do
12981332 , metadata = d ^. #metadata
12991333 , createdAt = d ^. #createdAt
13001334 , updatedAt = d ^. #updatedAt
1301− , deploymentDefaultConfig = dCfg
13021335 }