archive-hardfork-toolbox: only check on migration record to ensure migration succeeded, integrity is maintained by the migration SQL

Author: glyh

src/app/archive_hardfork_toolbox/archive_hardfork_toolbox.ml

@@ -66,12 +66,18 @@ let verify_upgrade_command =
   Async.Command.async
     ~summary:"Verify upgrade from pre-fork to post-fork schema"
     (let%map_open.Command { value = postgres_uri; _ } = Uri.Archive.postgres
-     and version =
-       Command.Param.flag "--version"
+     and expected_protocol_version =
+       Command.Param.flag "--protocol-version"
          Command.Param.(required string)
-         ~doc:"String Version to upgrade to (e.g. 3.2.0 etc)"
+         ~doc:"String Protocol Version to upgrade to (e.g. 3.2.0 etc)"
+     and expected_migration_version =
+       Command.Param.flag "--migration-version"
+         Command.Param.(required string)
+         ~doc:"String Migration Version that generates current schema"
      in
-     run_check_and_exit (verify_upgrade ~postgres_uri ~version) )
+     run_check_and_exit
+       (verify_upgrade ~postgres_uri ~expected_protocol_version
+          ~expected_migration_version ) )
 
 let validate_fork_command =
   Async.Command.async ~summary:"Validate fork block and its ancestors"

src/app/archive_hardfork_toolbox/logic.ml

@@ -133,89 +133,52 @@ let no_commands_after ~postgres_uri ~fork_state_hash ~fork_slot () =
   in
   Deferred.return [ check_result ]
 
-let verify_upgrade ~postgres_uri ~version () =
+let verify_upgrade ~postgres_uri ~expected_protocol_version
+    ~expected_migration_version () =
   let open Deferred.Let_syntax in
-  let results = ref [] in
   let%bind pool = connect postgres_uri in
   let query_db = Mina_caqti.query pool in
-  let%bind res =
-    query_db ~f:(Sql.SchemaVerification.fetch_schema_row ~version)
-  in
-  let%bind missing_cols_zkapp_states =
-    query_db
-      ~f:(Sql.SchemaVerification.fetch_missing_cols ~table:"zkapp_states")
-  in
-  let%bind missing_cols_zkapp_states_nullable =
-    query_db
-      ~f:
-        (Sql.SchemaVerification.fetch_missing_cols
-           ~table:"zkapp_states_nullable" )
-  in
-
-  let%bind () =
-    match res with
-    | None ->
-        results :=
+  let%map res = query_db ~f:Sql.fetch_latest_migration_history in
+  match res with
+  | Some (status, protocol_version, migration_version) -> (
+      let results = Queue.create () in
+      if String.(status <> "applied") then
+        Queue.enqueue results
           { id = "4.S"
-          ; name = "Schema migration status"
+          ; name = "Schema migration"
+          ; result = Failure (sprintf "Latest migration has status %s" status)
+          } ;
+      if String.(protocol_version <> expected_protocol_version) then
+        Queue.enqueue results
+          { id = "4.S"
+          ; name = "Schema migration"
           ; result =
               Failure
-                (sprintf "No schema migration found for version %s" version)
-          }
-          :: !results ;
-        Deferred.return ()
-    | Some status ->
-        let expected = "applied" in
-        let result =
-          if String.equal status expected then Success
-          else
-            Failure
-              (sprintf
-                 "Expected schema migration with version %s to be \"%s\" \
-                  however got status %s"
-                 version expected status )
-        in
-        results :=
-          { id = "4.S"; name = "Schema migration status"; result } :: !results ;
-        Deferred.return ()
-  in
-
-  let%bind () =
-    let result =
-      if Int.( = ) missing_cols_zkapp_states 0 then Success
-      else
-        Failure
-          (sprintf
-             "Missing columns for zkapp_states detected during upgrade \
-              verification: %d"
-             missing_cols_zkapp_states )
-    in
-    results :=
-      { id = "5.M"; name = "Missing columns check [zkapp_states]"; result }
-      :: !results ;
-    Deferred.return ()
-  in
-
-  let%bind () =
-    let result =
-      if Int.( = ) missing_cols_zkapp_states_nullable 0 then Success
-      else
-        Failure
-          (sprintf
-             "Missing columns for zkapp_states_nullable detected during \
-              upgrade verification: %d"
-             missing_cols_zkapp_states_nullable )
-    in
-    results :=
-      { id = "6.M"
-      ; name = "Missing columns check [zkapp_states_nullable]"
-      ; result
-      }
-      :: !results ;
-    Deferred.return ()
-  in
-
-  Deferred.return !results
+                (sprintf
+                   "Latest protool version mismatch: actual %s vs expected %s"
+                   protocol_version expected_protocol_version )
+          } ;
+      if String.(migration_version <> expected_migration_version) then
+        Queue.enqueue results
+          { id = "4.S"
+          ; name = "Schema migration"
+          ; result =
+              Failure
+                (sprintf
+                   "Latest migration version mismatch: actual %s vs expected %s"
+                   migration_version expected_protocol_version )
+          } ;
+      match Queue.to_list results with
+      | [] ->
+          [ { id = "4.S"; name = "Schema migration"; result = Success } ]
+      | _ :: _ as results ->
+          results )
+  | None ->
+      [ { id = "4.S"
+        ; name = "Schema migration"
+        ; result = Failure "Can't find latest migration record"
+        }
+      ]
 
 let validate_fork ~postgres_uri ~fork_state_hash ~fork_slot () =
   let open Deferred.Let_syntax in

src/app/archive_hardfork_toolbox/sql.ml

@@ -120,59 +120,15 @@ let last_fork_block_query =
 let last_fork_block (module Conn : CONNECTION) =
   Conn.find last_fork_block_query ()
 
-module SchemaVerification = struct
-  module Types = struct
-    type schema_row =
-      { status : string option
-      ; description : string option
-      ; applied_at : string
-      ; validated_at : string option
-      }
-
-    type result =
-      { missing_cols : int
-      ; total_fks : int
-      ; valid_fks : int
-      ; expected_cols_min : int
-      ; expected_cols_max : int
-      ; expected_fk_count : int
-      ; schema : schema_row option
-      ; ok_cols : bool
-      ; ok_fk_present : bool
-      ; ok_fk_validated : bool
-      ; ok_schema_status : bool
-      ; ok : bool
-      }
-  end
-
-  module Queries = struct
-    (* 1) How many of element8..element31 are missing in table ? *)
-    let missing_cols_req =
-      Caqti_type.(string ->! int)
-      @@ {|
-      SELECT count(*) FROM generate_series(8,31) g(n)
-      LEFT JOIN information_schema.columns c
-        ON c.table_schema='public'
-       AND c.table_name=?
-       AND c.column_name='element'||g.n
-      WHERE c.column_name IS NULL
-    |}
-
-    (* 2) Row from public.schema_version for a given version.
-          We stringify timestamps for driver simplicity. *)
-    let schema_row_req =
-      Caqti_type.(string ->? string)
-      @@ {|
+let fetch_latest_migration_history_query =
+  Caqti_type.(unit ->? t3 string string string)
+    {|
       SELECT
-        status
+        status, protocol_version, migration_version
       FROM migration_history
-      WHERE protocol_version = ?
+      ORDER BY commit_start_at DESC
+      LIMIT 1;
     |}
-  end
-
-  let fetch_missing_cols (module Conn : CONNECTION) ~table =
-    Conn.find Queries.missing_cols_req table
 
-  let fetch_schema_row (module Conn : CONNECTION) ~version =
-    Conn.find_opt Queries.schema_row_req version
-end
+let fetch_latest_migration_history (module Conn : CONNECTION) =
+  Conn.find_opt fetch_latest_migration_history_query ()