0a95ea8 · typeable/octopod

git.iko.soy/typeable/octopod

wi[

commit0a95ea857b67f64110c616c94877c7bb84fc2169 authorAnisimov Nikita <anisimoff.nikita@gmail.com> dateFri 15 Sep 2023, 17:50 (3 years ago) parent00470c4

3 files changed+28−29

compare with master

unifiedsplit

octopod-backend/src/Octopod/Server.hs+19−22 octopod-backend/src/Octopod/Server/ControlScriptUtils.hs+4−4 octopod-backend/src/Octopod/Server/Logging.hs+5−3

octopod-backend/src/Octopod/Server.hs+19−22

@@ -562,10 +562,10 @@ updateDeploymentInfo ::

562562 (KatipContext m, MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>

563563 DeploymentName ->

564564 m ()

565−updateDeploymentInfo dName = do

565+updateDeploymentInfo dName = katipAddContext (sl "deployment" dName) $ do

566566 DeploymentFullInfo {deployment = dep} <- getDeploymentS dName

567567 cfg <- getDeploymentConfig dep

568− (ec, out, err, _) <- katipAddContext (sl "deployemnt" dName) $ runCommandArgs infoCommand =<< infoCommandArgs cfg dep

568+ (ec, out, err, _) <- runCommandArgs infoCommand =<< infoCommandArgs cfg dep

569569 case ec of

570570 ExitSuccess -> case parseDeploymentMetadata (unStdout out) of

571571 Right dMeta -> upsertDeploymentMetadatum dName dMeta

@@ -593,9 +593,9 @@ createDeployment ::

593593 (KatipContext m, MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>

594594 Deployment ->

595595 m (ExitCode, Stdout, Stderr, Duration)

596−createDeployment dep = do

596+createDeployment dep = katipAddContext (sl "deployment" (dep ^. #name)) $ do

597597 cfg <- getDeploymentConfig dep

598− res <- katipAddContext (sl "deployemnt" (dep ^. #name)) $ runCommandArgs creationCommand =<< createCommandArgs cfg dep

598+ res <- runCommandArgs creationCommand =<< createCommandArgs cfg dep

599599 logLocM InfoS $ "deployment created, deployment: " <> show' dep

600600 pure res

601601

@@ -750,7 +750,7 @@ transitionToStatus dName s = do

750750 notificationCmd <- asks notificationCommand

751751 for_ notificationCmd $ \nCmd ->

752752 runBgWorker . void $

753− katipAddContext (sl "deployemnt" dName) $

753+ katipAddContext (sl "deployment" dName) $

754754 runCommandArgs' nCmd

755755 =<< notificationCommandArgs dName oldS newS

756756 sendReloadEvent

@@ -805,12 +805,12 @@ anyPred preds x = any ($ x) preds

805805

806806-- | Handles the 'archive' request.

807807archiveH :: DeploymentName -> AppM CommandResponse

808−archiveH dName = do

808+archiveH dName = katipAddContext (sl "deployment" dName) $ do

809809 failIfGracefulShutdownActivated

810810 runDeploymentBgWorker (Just ArchivePending) dName (pure ()) $ \() -> do

811811 (view #deployment -> dep) <- getDeploymentS dName

812812 cfg <- getDeploymentConfig dep

813− (ec, out, err, elTime) <- katipAddContext (sl "deployemnt" dName) $ runCommandArgs archiveCommand =<< archiveCommandArgs cfg dep

813+ (ec, out, err, elTime) <- runCommandArgs archiveCommand =<< archiveCommandArgs cfg dep

814814 transitionToStatusS dName $

815815 TransitionArchivePending

816816 StatusTransitionProcessOutput

@@ -853,7 +853,7 @@ updateH dName dUpdate = do

853853 updateDeploymentInfo dName

854854 sendReloadEvent

855855 cfg <- getDeploymentConfig dep

856− (ec, out, err, elTime) <- katipAddContext (sl "deployemnt" dName) $ runCommandArgs updateCommand =<< updateCommandArgs cfg dep

856+ (ec, out, err, elTime) <- katipAddContext (sl "deployment" dName) $ runCommandArgs updateCommand =<< updateCommandArgs cfg dep

857857 logLocM DebugS $

858858 logStr $

859859 "deployment updated, name: "

@@ -907,10 +907,10 @@ projectNameH = asks projectName

907907

908908-- | Handles the 'status' request.

909909statusH :: DeploymentName -> AppM CurrentDeploymentStatus

910−statusH dName = do

910+statusH dName = katipAddContext (sl "deployment" dName) $ do

911911 (view #deployment -> dep) <- getDeploymentS dName

912912 cfg <- getDeploymentConfig dep

913− (ec, _, _, _) <- katipAddContext (sl "deployemnt" dName) $ runCommandArgs checkingCommand =<< checkCommandArgs cfg dep

913+ (ec, _, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep

914914 pure . CurrentDeploymentStatus $

915915 case ec of

916916 ExitSuccess -> Ok

@@ -935,13 +935,10 @@ cleanupDeployment ::

935935 (KatipContext m, MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>

936936 DeploymentName ->

937937 m ()

938−cleanupDeployment dName = do

938+cleanupDeployment dName = katipAddContext (sl "deployment" dName) $ do

939939 (view #deployment -> dep) <- getDeploymentS dName

940940 cfg <- getDeploymentConfig dep

941− (ec, out, err, elTime) <- katipAddContext (sl "deployemnt" dName) $ runCommandArgs cleanupCommand =<< cleanupCommandArgs cfg dep

942− katipAddContext (FilePayload "stdout" $ T.encodeUtf8 $ unStdout out) $

943− katipAddContext (FilePayload "stdout" $ T.encodeUtf8 $ unStderr err) $

944− logLocM DebugS "deployment destroyed"

941+ (ec, out, err, elTime) <- runCommandArgs cleanupCommand =<< cleanupCommandArgs cfg dep

945942 case ec of

946943 ExitSuccess -> do

947944 deleteDeploymentLogs dName

@@ -1001,7 +998,7 @@ deleteDeployment dName =

1001998

1002999-- | Handles the 'restore' request.

10031000restoreH :: DeploymentName -> AppM CommandResponse

1004−restoreH dName = do

1001+restoreH dName = katipAddContext (sl "deployment" dName) $ do

10051002 failIfGracefulShutdownActivated

10061003 dep <- getDeploymentS dName

10071004 failIfImageNotFound $ dep ^. #deployment

@@ -1010,7 +1007,7 @@ restoreH dName = do

10101007 (view #deployment -> dep') <- getDeploymentS dName

10111008 updateDeploymentInfo dName

10121009 cfg <- getDeploymentConfig dep'

1013− (ec, out, err, elTime) <- katipAddContext (sl "deployemnt" dName) $ runCommandArgs unarchiveCommand =<< unarchiveCommandArgs cfg dep'

1010+ (ec, out, err, elTime) <- runCommandArgs unarchiveCommand =<< unarchiveCommandArgs cfg dep'

10141011 transitionToStatusS dName $

10151012 TransitionRestore

10161013 StatusTransitionProcessOutput

@@ -1107,9 +1104,9 @@ upsertDeploymentMetadatum dName dMetadata =

11071104-- | Checks the existence of a deployment tag.

11081105-- Returns 404 'Tag not found' response if the deployment tag doesn't exist.

11091106failIfImageNotFound :: Deployment -> AppM ()

1110−failIfImageNotFound dep = do

1107+failIfImageNotFound dep = katipAddContext (sl "deployment" (dep ^. #name)) $ do

11111108 cfg <- getDeploymentConfig dep

1112− (ec, Stdout out, _, _) <- katipAddContext (sl "deployemnt" (dep ^. #name)) $ runCommandArgs configCheckingCommand =<< configCheckCommandArgs cfg dep

1109+ (ec, Stdout out, _, _) <- runCommandArgs configCheckingCommand =<< configCheckCommandArgs cfg dep

11131110 case ec of

11141111 ExitSuccess -> pure ()

11151112 ExitFailure _ ->

@@ -1151,14 +1148,14 @@ runStatusUpdater = do

11511148 Nothing -> do

11521149 logLocM ErrorS $ logStr $ "Couldn't find deployment: " <> unDeploymentName dName

11531150 pure Nothing

1154− Just (view #deployment -> dep) -> do

1151+ Just (view #deployment -> dep) -> katipAddContext (sl "deployment" (dep ^. #name)) $ do

11551152 cfg <- getDeploymentConfig dep

11561153 case dStatus of

11571154 ArchivePending -> do

1158− (ec, _, _, _) <- katipAddContext (sl "deployemnt" (dep ^. #name)) $ runCommandArgs archiveCheckingCommand =<< archiveCheckArgs cfg dep

1155+ (ec, _, _, _) <- runCommandArgs archiveCheckingCommand =<< archiveCheckArgs cfg dep

11591156 pure $ Just ec

11601157 _ -> do

1161− (ec, _, _, _) <- katipAddContext (sl "deployemnt" (dep ^. #name)) $ runCommandArgs checkingCommand =<< checkCommandArgs cfg dep

1158+ (ec, _, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep

11621159 pure $ Just ec

11631160 pure $ mEc <&> \ec -> (dName, statusTransition ec dStatus ts timeout, dStatus)

11641161 updated <-

octopod-backend/src/Octopod/Server/ControlScriptUtils.hs+4−4

@@ -239,13 +239,13 @@ runCommand cmd args = do

239239 <$> waitExitCodeSTM p

240240 <*> getStdout p

241241 <*> getStderr p

242− let outs = TL.split (toEnum . fromEnum $ '\n') out

243− let errs = TL.split (toEnum . fromEnum $ '\n') err

242+ let outs = P.reverse $ TL.split (toEnum . fromEnum $ '\n') out

243+ let errs = P.reverse $ TL.split (toEnum . fromEnum $ '\n') err

244244 katipAddContext (sl "script" cmd) $ do

245245 katipAddContext (sl "file" ("stdout" :: T.Text)) $

246− forM_ (P.reverse $ P.filter (/= "") outs) $ \outLine -> logLocM (if ec /= ExitSuccess then WarningS else DebugS) $ logStr outLine

246+ forM_ outs $ \outLine -> logLocM (if ec /= ExitSuccess then WarningS else DebugS) $ logStr outLine

247247 katipAddContext (sl "file" ("stderr" :: T.Text)) $

248− forM_ (P.reverse $ P.filter (/= "") errs) $ \errLine -> logLocM (if ec /= ExitSuccess then WarningS else DebugS) $ logStr errLine

248+ forM_ errs $ \errLine -> logLocM (if ec /= ExitSuccess then WarningS else DebugS) $ logStr errLine

249249 logLocM (if ec /= ExitSuccess then WarningS else DebugS) $

250250 "Control script " <> logStr cmd <> " " <> show' args <> " exited with: " <> show' ec

251251 pure

octopod-backend/src/Octopod/Server/Logging.hs+5−3

@@ -74,15 +74,14 @@ makeLogEnv :: LogConfig -> IO LogEnv

7474makeLogEnv conf = do

7575 scribe <- mkHandleScribeWithFormatter formatter ColorIfTerminal stdout (permitItem severity) verbosity

7676 env <- initLogEnv "octopod" $ Environment $ uProjectName $ conf ^. #project

77− env' <- registerScribe "stdout" scribe defaultScribeSettings env

78− pure env'

77+ registerScribe "stdout" scribe defaultScribeSettings env

7978 where

8079 verbosity = if conf ^. #prodLogs then V3 else V0

8180 severity = if conf ^. #debug then DebugS else InfoS

8281 formatter :: LogItem a => ItemFormatter a

8382 formatter =

8483 if conf ^. #prodLogs

85− then \color verb item -> bracketFormat color verb item {_itemPayload = SingleLineify $ _itemPayload item}

84+ then jsonFormat

8685 else \color verb item ->

8786 brackets (fromText $ formatAsLogTime $ _itemTime item)

8887 <> brackets (fromText $ colorBySeverity color (_itemSeverity item) $ renderSeverity $ _itemSeverity item)

@@ -119,3 +118,6 @@ instance ToObject FilePayload where

119118instance LogItem FilePayload where

120119 payloadKeys V3 _ = AllKeys

121120 payloadKeys _ _ = SomeKeys []

121+

122+newtype ContextPayload = ContextPayload { unContextPayload :: T.Text }

123+ deriving stock (Generic)