Merge pull request #17787 from MinaProtocol/lyh/nit-arcihve-cli-cleanups

Clean up Archive CLI a bit

Author: glyh

src/app/archive/cli/archive_cli.ml

@@ -42,8 +42,8 @@ let command_run =
          ~doc:
            "int The number of accounts to insert from the database in one \
             transaction, when processing genesis ledger. This is to prevent \
-            Postgres Out of Memory errors \n\
-           \            when handling very big genesis file. Default is 100."
+            Postgres Out of Memory errors when handling very big genesis file. \
+            Default is 100."
          (optional_with_default 100 int)
      in
      let runtime_config_opt =
@@ -94,16 +94,17 @@ let command_prune =
             Format: 2000-00-00 12:00:00+0100"
      and postgres = Flag.Uri.Archive.postgres in
      fun () ->
+       let logger = Logger.create () in
        let timestamp =
          timestamp
          |> Option.map ~f:Block_time.of_time
          |> Option.map ~f:Block_time.to_int64
        in
-       let go () =
+       let execute () =
          let open Deferred.Result.Let_syntax in
          let%bind ((module Conn) as conn) = Mina_caqti.connect postgres.value in
          let%bind () = Conn.start () in
-         match%bind.Async.Deferred
+         match%bind.Deferred
            let%bind () =
              Archive_lib.Processor.Block.delete_if_older_than ?height
                ?num_blocks ?timestamp conn
@@ -112,11 +113,13 @@ let command_prune =
          with
          | Ok () ->
              return ()
-         | Error err ->
-             let%bind.Async.Deferred _ = Conn.rollback () in
-             Deferred.Result.fail err
+         | Error txn_error ->
+             let%map.Deferred rollback_result = Conn.rollback () in
+             Result.iter_error rollback_result ~f:(fun err ->
+                 [%log error] "Failed to rollback txn on failure"
+                   ~metadata:[ ("error", `String (Caqti_error.show err)) ] ) ;
+             Error txn_error
        in
-       let logger = Logger.create () in
        let cmd_metadata =
          List.filter_opt
            [ Option.map height ~f:(fun v -> ("height", `Int v))
@@ -125,7 +128,7 @@ let command_prune =
                  ("timestamp", `String (Int64.to_string v)) )
            ]
        in
-       match%map.Async.Deferred go () with
+       match%map.Async.Deferred execute () with
        | Ok () ->
            [%log info] "Successfully purged blocks." ~metadata:cmd_metadata
        | Error err ->

src/app/archive/lib/processor.ml

@@ -4804,7 +4804,7 @@ let add_genesis_accounts ~logger ~(runtime_config_opt : Runtime_config.t option)
       | Ok () ->
           () )
 
-let create_metrics_server ~logger ~metrics_server_port ~missing_blocks_width
+let serve_metrics_server ~logger ~metrics_server_port ~missing_blocks_width
     ~block_window_duration_ms pool =
   match metrics_server_port with
   | None ->
@@ -4814,18 +4814,19 @@ let create_metrics_server ~logger ~metrics_server_port ~missing_blocks_width
         Option.value ~default:Metrics.default_missing_blocks_width
           missing_blocks_width
       in
-      let%bind metric_server =
+      let%map metric_server =
         Mina_metrics.Archive.create_archive_server ~port ~logger ()
       in
-      let interval = Float.of_int (block_window_duration_ms * 2) in
-      let rec go () =
+      let interval =
+        Time.Span.of_ms @@ Float.of_int (block_window_duration_ms * 2)
+      in
+      let serve () =
         let%bind () =
           Metrics.update pool metric_server ~logger ~missing_blocks_width
         in
-        let%bind () = after (Time.Span.of_ms interval) in
-        go ()
+        after interval
       in
-      go ()
+      Deferred.forever () serve
 
 (* for running the archive process *)
 let setup_server ~proof_cache_db ~(genesis_constants : Genesis_constants.t)
@@ -4938,7 +4939,7 @@ let setup_server ~proof_cache_db ~(genesis_constants : Genesis_constants.t)
                      Deferred.unit ) ) )
       |> don't_wait_for ;
       (*Update archive metrics*)
-      create_metrics_server ~logger ~metrics_server_port ~missing_blocks_width
+      serve_metrics_server ~logger ~metrics_server_port ~missing_blocks_width
         ~block_window_duration_ms:constraint_constants.block_window_duration_ms
         pool
       |> don't_wait_for ;