Added ability to delete deployments, made cli output prettier (#157)

* Added ability to delete deployment, made cli output prettier

* stop failing script

dev/default.nix

@@ -115,7 +115,7 @@ in
 
         sleep 4
 
-        for i in {1..50}
+        for i in {1..10}
         do
           echo "key$i,value"
         done
@@ -128,7 +128,7 @@ in
 
         sleep 4
 
-        for i in {1..50}
+        for i in {1..10}
         do
           echo "key$i"
         done

octo-cli/src/Octopod/CLI.hs

@@ -82,6 +82,8 @@ runOcto = do
       Restore tName ->
         handleRestore auth . coerce $ tName
       GetActionLogs aId l -> handleGetActionInfo auth aId l
+      Delete tName ->
+        handleDelete auth . coerce $ tName
 
 -- | Returns BaseUrl from 'OCTOPOD_URL' environment variable
 -- or exit with exit_code=1.
@@ -181,6 +183,13 @@ handleCleanup auth dName = do
   liftIO $
     handleResponse (const $ pure ()) =<< runClientM (cleanupH auth dName) clientEnv
 
+-- | Handles the 'delete' subcommand.
+handleDelete :: AuthContext AuthHeaderAuth -> DeploymentName -> ReaderT ClientEnv IO ()
+handleDelete auth dName = do
+  clientEnv <- ask
+  liftIO $
+    handleResponse (const $ pure ()) =<< runClientM (deleteH auth dName) clientEnv
+
 -- | Handles the 'restore' subcommand.
 handleRestore :: AuthContext AuthHeaderAuth -> DeploymentName -> ReaderT ClientEnv IO ()
 handleRestore auth dName = do
@@ -214,6 +223,7 @@ _statusH :: AuthContext AuthHeaderAuth -> DeploymentName -> ClientM CurrentDeplo
 cleanupH :: AuthContext AuthHeaderAuth -> DeploymentName -> ClientM CommandResponse
 restoreH :: AuthContext AuthHeaderAuth -> DeploymentName -> ClientM CommandResponse
 getActionInfoH :: AuthContext AuthHeaderAuth -> ActionId -> ClientM ActionInfo
+deleteH :: AuthContext AuthHeaderAuth -> DeploymentName -> ClientM CommandResponse
 ( listH
     :<|> createH
     :<|> archiveH
@@ -223,6 +233,7 @@ getActionInfoH :: AuthContext AuthHeaderAuth -> ActionId -> ClientM ActionInfo
     :<|> _statusH
     :<|> cleanupH
     :<|> restoreH
+    :<|> deleteH
   )
   :<|> getActionInfoH = pushArrowIntoServantAlt $ client (Proxy @PowerAPI)
 
@@ -264,13 +275,13 @@ decodeError body =
 printInfo :: DeploymentInfo -> IO ()
 printInfo (DeploymentInfo (Deployment _ dAppOvs dStOvs) (DeploymentMetadata dMeta) dLogs) = do
   T.putStrLn "Current settings:"
-  T.putStrLn $
-    "application config: "
-      <> formatOverrides dAppOvs
-  T.putStrLn $
-    "deployment config: "
-      <> formatOverrides dStOvs
-  T.putStrLn $ "metadata: "
+  T.putStrLn "Application config:"
+  putStrLn $ unlines $ formatOverrides False dAppOvs
+  T.putStrLn ""
+  T.putStrLn "Deployment config: "
+  putStrLn $ unlines $ formatOverrides False dStOvs
+  T.putStrLn ""
+  T.putStrLn $ "Metadata: "
   forM_ dMeta $ \m ->
     T.putStrLn $
       "  " <> m ^. #name <> ": " <> m ^. #link
@@ -282,15 +293,14 @@ ppDeploymentLogs :: [DeploymentLog] -> IO ()
 ppDeploymentLogs ds =
   putStrLn
     . tableString
-      [ column expand right noAlign def
+      [ column expand center noAlign def
+      , column expand center noAlign def
       , column expand center noAlign def
       , column expand center noAlign def
       , column expand center noAlign def
-      , column expand left (charAlign '=') def
-      , column expand left (charAlign '=') def
       , column expand center noAlign def
       ]
-      unicodeBoldHeaderS
+      unicodeDoubleFrameS
       ( titlesH
           [ "Created at"
           , "Action id"
@@ -303,17 +313,35 @@ ppDeploymentLogs ds =
     $ ppDeploymentLogRow <$> ds
 
 -- | Pretty-prints the deployment log.
-ppDeploymentLogRow :: DeploymentLog -> RowGroup Text
+ppDeploymentLogRow :: DeploymentLog -> RowGroup String
 ppDeploymentLogRow dLog =
   colsAllG
     top
     [
-      [ T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) $
+      [ formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) $
           dLog ^. field @"createdAt"
       ]
     , [dLog ^. field @"actionId" . to unActionId . re _Show . packed]
-    , [dLog ^. field @"action" . to actionToText]
-    , dLog ^. field @"deploymentAppOverrides" . to formatOverrides'
-    , dLog ^. field @"deploymentDepOverrides" . to formatOverrides'
+    , [dLog ^. field @"action" . to (T.unpack . actionToText)]
+    , dLog ^. field @"deploymentAppOverrides" . to (stripBorder . formatOverrides True)
+    , dLog ^. field @"deploymentDepOverrides" . to (stripBorder . formatOverrides True)
     , [dLog ^. field @"exitCode" . re _Show . packed]
     ]
+
+stripBorder :: [String] -> [String]
+stripBorder = fmap (init . tail) . init . tail
+
+formatOverrides :: Bool -> Overrides l -> [String]
+formatOverrides splitlines (Overrides m) =
+  tableLines
+    [ column expand right noAlign def
+    , column expand left noAlign def
+    ]
+    unicodeS
+    def
+    $ showOverride <$> (reverse . OM.assocs) m
+  where
+    showOverride (k, v) =
+      colsAllG top $ [if splitlines then T.chunksOf 15 k else [k], showValue v]
+    showValue (ValueAdded v) = if splitlines then T.chunksOf 25 v else [v]
+    showValue ValueDeleted = ["<<REMOVED>>"]

octo-cli/src/Octopod/CLI/Args.hs

@@ -49,6 +49,9 @@ data Args
         name :: Text
       }
   | GetActionLogs ActionId LogOutput
+  | Delete
+      { name :: Text
+      }
   deriving stock (Show)
 
 data LogOutput = Err | Out | ErrOut
@@ -81,13 +84,14 @@ commandArgs =
         <> command
           "logs"
           (info actionLogsArgs (progDesc "get deployment logs of a given action"))
+        <> command "delete" (info deleteArgs (progDesc "delete the deployment from Octopod. Does no cleanup."))
     )
 
 -- | Parses arguments of 'create' subcommand.
 createArgs :: Parser Args
 createArgs =
   Create
-    <$> strOption (long "name" <> short 'n' <> help "deployment name")
+    <$> deploymentNameArgument
     <*> many
       ( strOption
           ( long "set-app-config"
@@ -110,15 +114,13 @@ listArgs =
 
 -- | Parses arguments of 'archive' subcommand.
 archiveArgs :: Parser Args
-archiveArgs =
-  Archive
-    <$> strOption (long "name" <> short 'n' <> help "deployment name")
+archiveArgs = Archive <$> deploymentNameArgument
 
 -- | Parses arguments of 'update' subcommand.
 updateArgs :: Parser Args
 updateArgs =
   Update
-    <$> strOption (long "name" <> short 'n' <> help "deployment name")
+    <$> deploymentNameArgument
     <*> many
       ( strOption
           ( long "set-app-config"
@@ -150,21 +152,19 @@ updateArgs =
 
 -- | Parses arguments of 'info' subcommand.
 infoArgs :: Parser Args
-infoArgs =
-  Info
-    <$> strOption (long "name" <> short 'n' <> help "deployment name")
+infoArgs = Info <$> deploymentNameArgument
 
 -- | Parses arguments of 'cleanup' subcommand.
 cleanupArgs :: Parser Args
-cleanupArgs =
-  Cleanup
-    <$> strOption (long "name" <> short 'n' <> help "deployment name")
+cleanupArgs = Cleanup <$> deploymentNameArgument
+
+-- | Parses arguments of 'delete' subcommand.
+deleteArgs :: Parser Args
+deleteArgs = Delete <$> deploymentNameArgument
 
 -- | Parses arguments of 'restore' subcommand.
 restoreArgs :: Parser Args
-restoreArgs =
-  Restore
-    <$> strOption (long "name" <> short 'n' <> help "deployment name")
+restoreArgs = Restore <$> deploymentNameArgument
 
 actionLogsArgs :: Parser Args
 actionLogsArgs =
@@ -178,3 +178,6 @@ actionLogsArgs =
           <> value ErrOut
           <> completeWith ["stdout", "stderr", "all"]
       )
+
+deploymentNameArgument :: Parser Text
+deploymentNameArgument = strOption (long "name" <> short 'n' <> help "deployment name")

octopod-api/src/Octopod/PowerAPI.hs

@@ -36,6 +36,9 @@ type StatusEndpoint c = c :> "status" :> Get '[JSON] CurrentDeploymentStatus
 type CleanupEndpoint c =
   c :> "cleanup" :> Delete '[JSON] CommandResponse
 
+type DeleteEndpoint c =
+  c :> "delete" :> Delete '[JSON] CommandResponse
+
 type RestoreEndpoint c =
   c :> "restore" :> Patch '[JSON] CommandResponse
 
@@ -63,6 +66,8 @@ type DeploymentAPI' c =
                 -- endpoint to clean up resources of an archived deployment
                 :<|> RestoreEndpoint c
                 -- endpoint to restore an archived deployment
+                :<|> DeleteEndpoint c
+                -- endpoint to clean up resources of an archived deployment
              )
           :<|> GetActionInfoEndpoint
           -- endpoint to get action logs

octopod-backend/src/Octopod/Server.hs

@@ -420,6 +420,7 @@ powerServer (Authenticated ()) =
       :<|> statusH
       :<|> cleanupH
       :<|> restoreH
+      :<|> deleteH
   )
     :<|> getActionInfoH
 powerServer _ = throwAll err401
@@ -921,6 +922,13 @@ cleanupH dName = do
   runDeploymentBgWorker Nothing dName (pure ()) $ \() -> cleanupDeployment dName
   pure Success
 
+-- | Deletes the deployment from the DB.
+deleteH :: DeploymentName -> AppM CommandResponse
+deleteH dName = do
+  failIfGracefulShutdownActivated
+  runDeploymentBgWorker Nothing dName (pure ()) $ \() -> deleteAllDeployment dName
+  pure Success
+
 -- | Helper to cleanup deployment.
 cleanupDeployment ::
   (KatipContext m, MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>
@@ -951,6 +959,15 @@ cleanupDeployment dName = do
   sendReloadEvent
   handleExitCode ec
 
+deleteAllDeployment ::
+  (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) =>
+  DeploymentName ->
+  m ()
+deleteAllDeployment dName = do
+  deleteDeploymentLogs dName
+  deleteDeployment dName
+  logLocM InfoS $ logStr $ "deployment destroyed, name: " <> unDeploymentName dName
+
 -- | Helper to delete deployment logs.
 deleteDeploymentLogs ::
   (KatipContext m, MonadBaseControl IO m, MonadReader AppState m) =>

octopod-common/src/Common/Types.hs

@@ -397,12 +397,3 @@ parseSetOverrides texts = do
 
 parseUnsetOverrides :: [Text] -> Overrides l
 parseUnsetOverrides = Overrides . OM.fromList . fmap (,ValueDeleted)
-
-formatOverrides :: Overrides l -> Text
-formatOverrides = T.unlines . formatOverrides'
-
-formatOverrides' :: Overrides l -> [Text]
-formatOverrides' (Overrides m) = fmap (\(k, v) -> k <> "=" <> showValue v) . OM.assocs $ m
-  where
-    showValue (ValueAdded v) = v
-    showValue ValueDeleted = "<removed>"