Fixing the issue of the CI not responding

With Mark Elvers we identify where the issue about the CI not
responding when there's a lot of activity, meaning when there's a new
push in opam-repo the analysis of all user repositroy is restarted.

An analysis makes a tmp copy of an user repository in order to extract
all the information needed for the solver-service. There's some IO access
involved and take time when there's a lot of analysis running at same
time in the CI.

This is an attempt to fix that, by cache the extraction without keep
doing it for each new opam repository commit.

gitlab/pipeline.ml

@@ -183,9 +183,10 @@ let gitlab_status_of_state head result =
 let local_test ~solver repo () =
   let platforms = Conf.fetch_platforms ~include_macos:false () in
   let src = Git.Local.head_commit repo in
+  let src_content = Repo_content.extract src in
   let repo = Current.return { Repo_id.owner = "local"; name = "test" }
   and analysis =
-    Analyse.examine ~solver ~platforms ~opam_repository_commit src
+    Analyse.examine ~solver ~platforms ~opam_repository_commit src src_content
   in
   Current.component "summarise"
   |> let> results = build_with_docker ~repo ~analysis ~platforms src in
@@ -223,8 +224,10 @@ let v ?ocluster ~app ~solver ~migrations () =
         refs
         |> Current.list_iter (module Gitlab.Api.Commit) @@ fun head ->
            let src = Git.fetch (Current.map Gitlab.Api.Commit.id head) in
+           let src_content = Repo_content.extract src in
            let analysis =
              Analyse.examine ~solver ~platforms ~opam_repository_commit src
+               src_content
            in
            let* on_cancel =
              match ocluster with

lib/analyse.ml

@@ -1,26 +1,11 @@
 open Lwt.Infix
 open Current.Syntax
 module Worker = Ocaml_ci_api.Worker
+module Content = Repo_content.Content
 
-let pool = Current.Pool.create ~label:"analyse" 20
-
-let is_empty_file x =
-  match Unix.lstat (Fpath.to_string x) with
-  | Unix.{ st_kind = S_REG; st_size = 0; _ } -> true
-  | _ -> false
-
+let pool = Current.Pool.create ~label:"analyse" 150
 let ( >>!= ) = Lwt_result.bind
 
-let read_file ~max_len path =
-  Lwt_io.with_file ~mode:Lwt_io.input path (fun ch ->
-      Lwt_io.length ch >>= fun len ->
-      let len =
-        if len <= Int64.of_int max_len then Int64.to_int len
-        else Fmt.failwith "File %S too big (%Ld bytes)" path len
-      in
-      let buf = Bytes.create len in
-      Lwt_io.read_into_exactly ch buf 0 len >|= fun () -> Bytes.to_string buf)
-
 (* A logging service that logs to [job]. *)
 let job_log job =
   let module X = Ocaml_ci_api.Raw.Solve.Service.Log in
@@ -58,81 +43,6 @@ module Analysis = struct
   let ocamlformat_selection t = t.ocamlformat_selection
   let ocamlformat_source t = t.ocamlformat_source
   let selections t = t.selections
-  let is_test_dir = Astring.String.is_prefix ~affix:"test"
-
-  let check_opam_version =
-    let version_2 = OpamVersion.of_string "2" in
-    fun name opam ->
-      let opam_version = OpamFile.OPAM.opam_version opam in
-      if OpamVersion.compare opam_version version_2 < 0 then
-        Fmt.failwith "Package %S uses unsupported opam version %s (need >= 2)"
-          name
-          (OpamVersion.to_string opam_version)
-
-  (* For each package in [root_pkgs], parse the opam file and check whether it uses pin-depends.
-     Fetch and return all pinned opam files. Also, ensure we're using opam format version 2. *)
-  let handle_opam_files ~job ~root_pkgs ~pinned_pkgs =
-    pinned_pkgs
-    |> List.iter (fun (name, contents) ->
-           check_opam_version name (OpamFile.OPAM.read_from_string contents));
-    let pin_depends =
-      root_pkgs
-      |> List.map (fun (name, contents) ->
-             let opam =
-               try OpamFile.OPAM.read_from_string contents
-               with ex ->
-                 Fmt.failwith "Invalid opam file %S: %a" name Fmt.exn ex
-             in
-             check_opam_version name opam;
-             let pin_depends = OpamFile.OPAM.pin_depends opam in
-             pin_depends
-             |> List.map (fun (pkg, url) ->
-                    Current.Job.log job "%s: found pin-depends: %s -> %s" name
-                      (OpamPackage.to_string pkg)
-                      (OpamUrl.to_string url);
-                    (name, pkg, url)))
-      |> List.concat
-    in
-    pin_depends
-    |> Lwt_list.map_s (fun (root_pkg, pkg, url) ->
-           Lwt.catch
-             (fun () ->
-               Pin_depends.get_opam ~job ~pkg url >|= fun contents ->
-               (OpamPackage.to_string pkg, contents))
-             (function
-               | Failure msg ->
-                   Fmt.failwith "%s (processing pin-depends in %s)" msg root_pkg
-               | ex -> Lwt.fail ex))
-
-  let opam_selections ~solve ~job ~platforms ~opam_files dir =
-    let src = Fpath.to_string dir in
-    let ( / ) = Filename.concat in
-    opam_files
-    |> Lwt_list.fold_left_s
-         (fun (root_pkgs, pinned_pkgs) path ->
-           let name = Filename.basename path |> Filename.chop_extension in
-           let name =
-             if String.contains name '.' then name else name ^ ".dev"
-           in
-           read_file ~max_len:102400 (src / path) >|= fun file ->
-           let item = (name, file) in
-           if Filename.dirname path = "." then (item :: root_pkgs, pinned_pkgs)
-           else (root_pkgs, item :: pinned_pkgs))
-         ([], [])
-    >>= fun (root_pkgs, pinned_pkgs) ->
-    Lwt.try_bind
-      (fun () -> handle_opam_files ~job ~root_pkgs ~pinned_pkgs)
-      (fun pin_depends ->
-        let pinned_pkgs = pin_depends @ pinned_pkgs in
-        Lwt_result.map
-          (fun selections -> `Opam_build selections)
-          (solve ~root_pkgs ~pinned_pkgs ~platforms))
-      (function Failure msg -> Lwt_result.fail (`Msg msg) | ex -> Lwt.fail ex)
-
-  let type_of_dir dir =
-    match Opam_monorepo.detect ~dir with
-    | Some info -> `Opam_monorepo info
-    | None -> `Ocaml_repo
 
   (** Call the solver with a request containing these packages. When it returns
       a list, it is nonempty. *)
@@ -153,6 +63,8 @@ module Analysis = struct
         root_pkgs;
         pinned_pkgs;
         platforms;
+        (* TODO ocamlformat in the request (option)*)
+        (* TODO opam_monorepo in the request (option)*)
       }
     in
     Current.Job.log job "Solving with opam-repository commit: %a"
@@ -235,76 +147,32 @@ module Analysis = struct
            Ocaml_version.compare (Variant.ocaml_version v0)
              (Variant.ocaml_version v1))
 
-  let of_dir ~solver ~job ~platforms ~opam_repository_commit root =
-    let cancelled = Atomic.make None in
-    let fold_on_opam_files () =
-      let module M = struct
-        exception Exit of string
-      end in
-      let module S = Astring.String.Set in
-      let opam_files full_path =
-        let path = Option.get (Fpath.rem_prefix root full_path) in
-        let consider_opam_file =
-          match Fpath.segs path with
-          | [] | [ _ ] -> true
-          | segs ->
-              if List.exists is_test_dir segs then (
-                Current.Job.log job "Ignoring test directory %a" Fpath.pp path;
-                false)
-              else true
-        in
-        if is_empty_file full_path then (
-          Current.Job.log job "WARNING: ignoring empty opam file %a" Fpath.pp
-            path;
-          None)
-        else if consider_opam_file then Some path
-        else None
-      in
-      let is_opam_ext path = Ok (Fpath.has_ext "opam" path) in
-      let traverse path =
-        match Fpath.rem_prefix root path with
-        (* maxdepth=3 *)
-        | Some suffix -> Ok (List.compare_length_with (Fpath.segs suffix) 3 <= 0)
-        | None when Fpath.equal root path -> Ok true
-        | None ->
-            Fmt.error_msg "%a is not a prefix of %a" Fpath.pp root Fpath.pp path
-      in
-      let add_opam_files path acc =
-        Option.iter (fun s -> raise_notrace (M.Exit s)) (Atomic.get cancelled);
-        match opam_files path with
-        | Some path -> S.add (Fpath.to_string path) acc
-        | None -> acc
-      in
-      (try
-         Bos.OS.Path.fold ~elements:(`Sat is_opam_ext) ~traverse:(`Sat traverse)
-           add_opam_files S.empty [ root ]
-       with M.Exit reason ->
-         Fmt.error_msg "Cancelling opam file lookup (%s)" reason)
-      |> Result.map S.elements
-    in
-    Current.Job.on_cancel job (fun reason ->
-        Atomic.set cancelled (Some reason);
-        Lwt.return_unit)
-    >>= fun () ->
-    Lwt_preemptive.detach fold_on_opam_files () >>!= fun opam_files ->
+  let of_content ~solver ~job ~platforms ~opam_repository_commit src =
+    let opam_files = Content.opam_files src in
+    let version = Content.ocamlformat_version src in
     let solve = solve ~opam_repository_commit ~job ~solver in
     let find_opam_repo_commit =
       find_opam_repo_commit_for_ocamlformat ~solve
         ~platforms:(filter_linux_x86_64_platforms platforms)
     in
-    Analyse_ocamlformat.get_ocamlformat_source job ~opam_files ~root
+    Analyse_ocamlformat.get_ocamlformat_source job ~opam_files ~version
       ~find_opam_repo_commit
     >>!= fun (ocamlformat_source, ocamlformat_selection) ->
     if opam_files = [] then Lwt_result.fail (`Msg "No opam files found!")
     else if List.filter Fpath.is_seg opam_files = [] then
       Lwt_result.fail (`Msg "No top-level opam files found!")
     else
-      (match type_of_dir root with
+      (match Content.dir_type src with
       | `Opam_monorepo builds ->
           lwt_result_list_mapm builds ~f:(fun info ->
               Opam_monorepo.selection ~info ~solve ~platforms)
           |> Lwt_result.map (fun l -> `Opam_monorepo l)
-      | `Ocaml_repo -> opam_selections ~solve ~job ~platforms ~opam_files root)
+      | `Ocaml_repo ->
+          let root_pkgs = Content.root_pkgs src in
+          let pinned_pkgs = Content.pinned_pkgs src in
+          Lwt_result.map
+            (fun selections -> `Opam_build selections)
+            (solve ~root_pkgs ~pinned_pkgs ~platforms))
       >>!= fun selections ->
       let r =
         { opam_files; ocamlformat_selection; ocamlformat_source; selections }
@@ -330,6 +198,7 @@ module Examine = struct
     type t = {
       opam_repository_commit : Current_git.Commit_id.t;
       platforms : (Variant.t * Worker.Vars.t) list;
+      src_content : Repo_content.Content.t;
     }
 
     let platform_to_yojson (variant, vars) =
@@ -339,13 +208,14 @@ module Examine = struct
           ("vars", Worker.Vars.to_yojson vars);
         ]
 
-    let digest { opam_repository_commit; platforms } =
+    let digest { opam_repository_commit; platforms; src_content } =
       let json =
         `Assoc
           [
             ( "opam-repository",
               `String (Current_git.Commit_id.hash opam_repository_commit) );
             ("platforms", `List (List.map platform_to_yojson platforms));
+            ("src_content", `String (Repo_content.Content.marshal src_content));
           ]
       in
       Yojson.Safe.to_string json
@@ -355,10 +225,11 @@ module Examine = struct
 
   let id = "ci-analyse"
 
-  let run solver job src { Value.opam_repository_commit; platforms } =
-    Current.Job.start job ~level:Current.Level.Harmless >>= fun () ->
-    Current_git.with_checkout ~job ~pool src @@ fun src ->
-    Analysis.of_dir ~solver ~platforms ~opam_repository_commit ~job src
+  let run solver job _ { Value.opam_repository_commit; platforms; src_content }
+      =
+    Current.Job.start job ~pool ~level:Current.Level.Harmless >>= fun () ->
+    Analysis.of_content ~solver ~platforms ~opam_repository_commit ~job
+      src_content
 
   let pp f _ = Fmt.string f "Analyse"
   let auto_cancel = true
@@ -367,12 +238,12 @@ end
 
 module Examine_cache = Current_cache.Generic (Examine)
 
-let examine ~solver ~platforms ~opam_repository_commit src =
+let examine ~solver ~platforms ~opam_repository_commit src src_content =
   Current.component "Analyse"
-  |> let> src and> opam_repository_commit and> platforms in
+  |> let> src and> opam_repository_commit and> platforms and> src_content in
      let platforms =
        platforms
        |> List.map (fun { Platform.variant; vars; _ } -> (variant, vars))
      in
      Examine_cache.run solver src
-       { Examine.Value.opam_repository_commit; platforms }
+       { Examine.Value.opam_repository_commit; platforms; src_content }

lib/analyse.mli

@@ -12,12 +12,12 @@ module Analysis : sig
     [ `Opam_build of Selection.t list
     | `Opam_monorepo of Opam_monorepo.config list ]
 
-  val of_dir :
+  val of_content :
     solver:Backend_solver.t ->
     job:Current.Job.t ->
     platforms:(Variant.t * Ocaml_ci_api.Worker.Vars.t) list ->
     opam_repository_commit:Current_git.Commit_id.t ->
-    Fpath.t ->
+    Repo_content.Content.t ->
     (t, [ `Msg of string ]) result Lwt.t
 end
 
@@ -26,6 +26,7 @@ val examine :
   platforms:Platform.t list Current.t ->
   opam_repository_commit:Current_git.Commit_id.t Current.t ->
   Current_git.Commit.t Current.t ->
+  Repo_content.Content.t Current.t ->
   Analysis.t Current.t
 (** [examine ~solver ~platforms ~opam_repository_commit src] analyses the source
     code [src] and selects package versions to test using

lib/analyse_ocamlformat.ml

@@ -73,9 +73,8 @@ let ocamlformat_version_from_file ~root job path =
     | _ :: _ :: _ ->
         Lwt.return (Error (`Msg "Multiple 'version=' lines in .ocamlformat"))
 
-let get_ocamlformat_source job ~opam_files ~root ~find_opam_repo_commit =
+let get_ocamlformat_source job ~opam_files ~version ~find_opam_repo_commit =
   let open Lwt.Infix in
-  let ( let* ) = Lwt_result.Infix.( >>= ) in
   let proj_is_ocamlformat p =
     String.equal (Filename.basename p) "ocamlformat.opam"
   in
@@ -84,11 +83,7 @@ let get_ocamlformat_source job ~opam_files ~root ~find_opam_repo_commit =
       let path = Filename.dirname opam_file in
       Lwt_result.return (Some (Vendored { path }), None)
   | None -> (
-      let* version_in_dot_ocamlformat =
-        ocamlformat_version_from_file ~root job
-          Fpath.(to_string (root / ".ocamlformat"))
-      in
-      match version_in_dot_ocamlformat with
+      match version with
       | None -> Lwt_result.return (None, None)
       | Some version -> (
           find_opam_repo_commit version >>= function

lib/analyse_ocamlformat.mli

@@ -10,10 +10,17 @@ type source =
 val pp_source : source Fmt.t
 (** Pretty print [source]. *)
 
+val ocamlformat_version_from_file :
+  root:Fpath.t ->
+  Current.Job.t ->
+  string ->
+  (string option, [ `Msg of string ]) Lwt_result.t
+(** Extract the version in .ocamlformat file if the file exists in the project *)
+
 val get_ocamlformat_source :
   Current.Job.t ->
   opam_files:string list ->
-  root:Fpath.t ->
+  version:string option ->
   find_opam_repo_commit:
     (string -> (string * Selection.t, [ `Msg of string ]) Lwt_result.t) ->
   (source option * Selection.t option, [ `Msg of string ]) Lwt_result.t

lib/opam_monorepo.ml

@@ -1,4 +1,4 @@
-type info = string * OpamFile.OPAM.t
+type info = string * string [@@deriving yojson]
 type lock_file_version = V0_2 | V0_3 [@@deriving yojson, ord]
 
 (** The kind of switch the package will be built in. *)
@@ -58,7 +58,7 @@ let detect ~dir =
         OpamFile.OPAM.read (OpamFile.make (OpamFilename.of_string full_path))
       in
       let* _ = x_opam_monorepo_version lock_file_contents in
-      Some (lock_file_path, lock_file_contents))
+      Some (lock_file_path, OpamFile.OPAM.write_to_string lock_file_contents))
 
 let packages_in_depends f =
   let get_atom = function OpamFormula.Atom a -> a | _ -> assert false in
@@ -124,6 +124,7 @@ let adjust_ocaml_version platform ~version =
 
 let selection ~info:(lock_file_path, lock_file) ~platforms ~solve =
   let open Lwt_result.Infix in
+  let lock_file = OpamFile.OPAM.read_from_string lock_file in
   let ocaml_version = opam_monorepo_dep_version ~lock_file ~package:"ocaml" in
   let dune_version = opam_monorepo_dep_version ~lock_file ~package:"dune" in
   let lock_file_version =

lib/opam_monorepo.mli

@@ -1,6 +1,6 @@
 (** Generate obuilder specs for building opam packages with opam-monorepo. *)
 
-type info
+type info [@@deriving yojson]
 
 val detect : dir:Fpath.t -> info list option
 (** Detect whether a project uses opam-monorepo or something else. *)