Merge pull request #1108 from terrateamio/978-fix-hanging-status

978 fix hanging status

Author: orbitz

code/src/terrat_vcs_event_evaluator2/terrat_vcs_event_evaluator2_tasks.ml

@@ -282,6 +282,8 @@ struct
           Builder.run_db s ~f:(fun db ->
               S.Api.create_client ~request_id:(Builder.log_id s) (Builder.State.config s) account db))
 
+    let commit_checks = run ~name:"commit_checks" (fun _s _ -> Abb.Future.return (Ok []))
+
     let context_id =
       run ~name:"context_id" (fun s { Bs.Fetcher.fetch } ->
           let open Irm in
@@ -2446,12 +2448,12 @@ struct
           fetch Keys.work_manifest_event
           >>= function
           | Some event -> (
-              let work_manifest =
+              let work_manifest, event_type =
+                let module E = Keys.Work_manifest_event in
                 match event with
-                | Keys.Work_manifest_event.(
-                    ( Initiate { work_manifest; _ }
-                    | Fail { work_manifest; _ }
-                    | Result { work_manifest; _ } )) -> work_manifest
+                | E.Initiate { work_manifest; _ } -> (work_manifest, "INITIATE")
+                | E.Fail { work_manifest; _ } -> (work_manifest, "FAIL")
+                | E.Result { work_manifest; _ } -> (work_manifest, "RESULT")
               in
               fetch Keys.work_manifest_event_job
               >>= function
@@ -2465,8 +2467,10 @@ struct
                   let context = job.Tjc.Job.context in
                   Logs.info (fun m ->
                       m
-                        "%s : context_id=%a : log_id= %s : initiator=%s"
+                        "%s : EVENT : WORK_MANIFEST : %s : context_id=%a : log_id= %s : \
+                         initiator=%s"
                         (Builder.log_id s)
+                        event_type
                         Uuidm.pp
                         context.Tjc.Context.id
                         log_id
@@ -2494,25 +2498,33 @@ struct
     let iter_job =
       run ~name:"iter_job" (fun s { Bs.Fetcher.fetch } ->
           let open Irm in
-          fetch Keys.job
-          >>= fun job ->
-          match job.Tjc.Job.type_ with
-          | Tjc.Job.Type_.Apply _ | Tjc.Job.Type_.Autoapply -> fetch Keys.run_apply
-          | Tjc.Job.Type_.Autoplan | Tjc.Job.Type_.Plan _ ->
-              fetch Keys.run_plan
-              >>= fun () ->
-              let s' =
-                s
-                |> Builder.State.orig_store
-                |> Tasks_base.forward_std_keys s
-                |> CCFun.flip Builder.State.set_orig_store s
-              in
-              Builder.eval s' Keys.complete_no_change_dirspaces
-          | Tjc.Job.Type_.Repo_config -> fetch Keys.publish_repo_config
-          | Tjc.Job.Type_.Unlock _ -> fetch Keys.publish_unlock
-          | Tjc.Job.Type_.Index -> fetch Keys.publish_index_complete
-          | Tjc.Job.Type_.Push -> fetch Keys.eval_push_event
-          | Tjc.Job.Type_.Gate_approval _ -> fetch Keys.store_gate_approval)
+          fetch Keys.repo_config_raw'
+          >>= fun (_, repo_config) ->
+          let module V1 = Terrat_base_repo_config_v1 in
+          match V1.enabled repo_config with
+          | true -> (
+              fetch Keys.job
+              >>= fun job ->
+              match job.Tjc.Job.type_ with
+              | Tjc.Job.Type_.Apply _ | Tjc.Job.Type_.Autoapply -> fetch Keys.run_apply
+              | Tjc.Job.Type_.Autoplan | Tjc.Job.Type_.Plan _ ->
+                  fetch Keys.run_plan
+                  >>= fun () ->
+                  let s' =
+                    s
+                    |> Builder.State.orig_store
+                    |> Tasks_base.forward_std_keys s
+                    |> CCFun.flip Builder.State.set_orig_store s
+                  in
+                  Builder.eval s' Keys.complete_no_change_dirspaces
+              | Tjc.Job.Type_.Repo_config -> fetch Keys.publish_repo_config
+              | Tjc.Job.Type_.Unlock _ -> fetch Keys.publish_unlock
+              | Tjc.Job.Type_.Index -> fetch Keys.publish_index_complete
+              | Tjc.Job.Type_.Push -> fetch Keys.eval_push_event
+              | Tjc.Job.Type_.Gate_approval _ -> fetch Keys.store_gate_approval)
+          | false ->
+              Logs.info (fun m -> m "%s : DISABLED" (Builder.log_id s));
+              Abb.Future.return (Error `Noop))
 
     let eval_work_manifest_failure =
       run ~name:"eval_work_manifest_failure" (fun s { Bs.Fetcher.fetch } ->
@@ -3126,6 +3138,7 @@ struct
     |> Hmap.add (coerce Keys.check_account_tier) Tasks.check_account_tier
     |> Hmap.add (coerce Keys.check_valid_destination_branch) Tasks.check_valid_destination_branch
     |> Hmap.add (coerce Keys.client) Tasks.client
+    |> Hmap.add (coerce Keys.commit_checks) Tasks.commit_checks
     |> Hmap.add (coerce Keys.complete_no_change_dirspaces) Tasks.complete_no_change_dirspaces
     |> Hmap.add (coerce Keys.compute_node) Tasks.compute_node
     |> Hmap.add (coerce Keys.context) Tasks.context

code/src/terrat_vcs_event_evaluator2/terrat_vcs_event_evaluator2_tasks_pr.ml

@@ -150,13 +150,32 @@ struct
           Abb.Future.return
             (Ok
                (fun branch_ref checks ->
+                 (* When updating commit checks, mark the existing key as dirty. *)
+                 Builder.State.mark_dirty s Keys.commit_checks;
                  S.Api.create_commit_checks
                    ~request_id:(Builder.log_id s)
                    client
                    repo
                    branch_ref
                    checks)))
 
+    let commit_checks =
+      run ~name:"commit_checks" (fun s { Bs.Fetcher.fetch } ->
+          let open Irm in
+          fetch Keys.client
+          >>= fun client ->
+          fetch Keys.repo
+          >>= fun repo ->
+          fetch Keys.branch_ref
+          >>= fun branch_ref ->
+          Logs.info (fun m ->
+              m
+                "%s : FETCH_COMMIT_CHECKS : repo = %s : branch = %s"
+                (Builder.log_id s)
+                (S.Api.Repo.to_string repo)
+                (S.Api.Ref.to_string branch_ref));
+          S.Api.fetch_commit_checks ~request_id:(Builder.log_id s) client repo branch_ref)
+
     let branch_name =
       run ~name:"branch_name" (fun s { Bs.Fetcher.fetch } ->
           let open Irm in
@@ -555,24 +574,10 @@ struct
           match S.Api.Pull_request.state pull_request with
           | Pr.State.Closed ->
               Logs.info (fun m -> m "%s : NOOP : PR_CLOSED" (Builder.log_id s));
-              fetch Keys.client
-              >>= fun client ->
-              fetch Keys.repo
-              >>= fun repo ->
+              fetch Keys.commit_checks
+              >>= fun commit_checks ->
               fetch Keys.branch_ref
               >>= fun branch_ref ->
-              time_it
-                s
-                (fun m log_id time ->
-                  m
-                    "%s : FETCH_COMMIT_CHECKS : repo = %s : branch = %s : time=%f"
-                    log_id
-                    (S.Api.Repo.to_string repo)
-                    (S.Api.Ref.to_string branch_ref)
-                    time)
-                (fun () ->
-                  S.Api.fetch_commit_checks ~request_id:(Builder.log_id s) client repo branch_ref)
-              >>= fun commit_checks ->
               let module Ch = Terrat_commit_check in
               let unfinished_checks =
                 CCList.filter_map
@@ -1206,8 +1211,10 @@ struct
             >>= fun _ ->
             fetch Keys.store_stacks
             >>= fun () ->
-            Abbs_future_combinators.Infix_result_app.(
-              (fun () () () () () () () () () () -> ())
+            fetch Keys.check_dirspaces_to_plan
+            >>= fun () ->
+            Fc.Infix_result_app.(
+              (fun () () () () () () () () () -> ())
               <$> fetch Keys.check_access_control_ci_change
               <*> fetch Keys.check_access_control_files
               <*> fetch Keys.check_access_control_repo_config
@@ -1216,8 +1223,7 @@ struct
               <*> fetch Keys.check_account_status_expired
               <*> fetch Keys.check_account_tier
               <*> fetch Keys.check_merge_conflict
-              <*> fetch Keys.check_conflicting_plan_work_manifests
-              <*> fetch Keys.check_dirspaces_to_plan)
+              <*> fetch Keys.check_conflicting_plan_work_manifests)
           in
           let open Abb.Future.Infix_monad in
           run
@@ -1255,8 +1261,15 @@ struct
             let open Irm in
             fetch Keys.check_pull_request_state
             >>= fun () ->
-            Abbs_future_combinators.Infix_result_app.(
-              (fun () () () () () () () () () () () () _ _ _ -> ())
+            (* Building these two happens to build all sorts of useful
+               dependencies for us, so build those first so the rest can
+               efficiently be done concurrently. *)
+            Fc.Result.all2 (fetch Keys.branch_dirspaces) (fetch Keys.dest_branch_dirspaces)
+            >>= fun _ ->
+            fetch Keys.check_dirspaces_to_apply
+            >>= fun () ->
+            Fc.Infix_result_app.(
+              (fun () () () () () () () () () () () _ -> ())
               <$> fetch Keys.check_access_control_ci_change
               <*> fetch Keys.check_access_control_apply
               <*> fetch Keys.check_access_control_files
@@ -1266,13 +1279,9 @@ struct
               <*> fetch Keys.check_conflicting_apply_work_manifests
               <*> fetch Keys.check_dirspaces_missing_plans
               <*> fetch Keys.check_dirspaces_owned_by_other_pull_requests
-              <*> fetch Keys.check_dirspaces_to_apply
               <*> fetch Keys.check_gates
               <*> fetch Keys.check_merge_conflict
-              <*> fetch Keys.check_apply_requirements
-              (* Ensure that various information is built before trying to run the plan *)
-              <*> fetch Keys.branch_dirspaces
-              <*> fetch Keys.dest_branch_dirspaces)
+              <*> fetch Keys.check_apply_requirements)
           in
           let open Abb.Future.Infix_monad in
           run
@@ -1364,7 +1373,8 @@ struct
               let log_id = Builder.mk_log_id ~request_id:(Builder.log_id s) job.Tjc.Job.id in
               Logs.info (fun m ->
                   m
-                    "%s : target=%s : context_id=%a : log_id= %s : job_type=%a"
+                    "%s : EVENT : PULL_REQUEST : target=%s : context_id=%a : log_id= %s : \
+                     job_type=%a"
                     (Builder.log_id s)
                     (Hmap.Key.info Keys.iter_job)
                     Uuidm.pp
@@ -1442,6 +1452,7 @@ struct
     |> Hmap.add (coerce Keys.check_merge_conflict) Tasks.check_merge_conflict
     |> Hmap.add (coerce Keys.check_pull_request_state) Tasks.check_pull_request_state
     |> Hmap.add (coerce Keys.comment_id) Tasks.comment_id
+    |> Hmap.add (coerce Keys.commit_checks) Tasks.commit_checks
     |> Hmap.add (coerce Keys.create_commit_checks) Tasks.create_commit_checks
     |> Hmap.add (coerce Keys.dest_branch_name) Tasks.dest_branch_name
     |> Hmap.add (coerce Keys.dest_branch_ref) Tasks.dest_branch_ref