Merge pull request #888 from moyodiallo/extract-content

Fixing the issue of the CI not responding

gitlab/pipeline.ml

@@ -187,9 +187,10 @@ let local_test ~solver repo () =
     Conf.fetch_platforms ~include_macos:false ~include_freebsd: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
@@ -227,8 +228,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. *)