diff --git a/.ocamlformat b/.ocamlformat index e9b4fef..4eae793 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,2 +1,5 @@ -version=0.15.0 -margin=100 \ No newline at end of file +version = 0.19.0 +profile = conventional +break-infix = fit-or-vertical +parse-docstrings = true +module-item-spacing = compact diff --git a/src/api/solver.ml b/src/api/solver.ml index 2871817..3a1b396 100644 --- a/src/api/solver.ml +++ b/src/api/solver.ml @@ -9,13 +9,15 @@ module Log = struct let pp_timestamp f x = let open Unix in let tm = gmtime x in - Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday - tm.tm_hour tm.tm_min tm.tm_sec + Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) + tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec let write t msg = let open X.Write in let message_size = 150 + String.length msg in - let request, params = Capability.Request.create ~message_size Params.init_pointer in + let request, params = + Capability.Request.create ~message_size Params.init_pointer + in Params.msg_set params msg; Capability.call_for_unit_exn t method_id request @@ -23,7 +25,8 @@ module Log = struct let now = Unix.gettimeofday () in let k msg = let thread = write t msg in - Lwt.on_failure thread (fun ex -> Format.eprintf "Log.info(%S) failed: %a@." msg Fmt.exn ex) + Lwt.on_failure thread (fun ex -> + Format.eprintf "Log.info(%S) failed: %a@." msg Fmt.exn ex) in Fmt.kstr k ("%a [INFO] @[" ^^ fmt ^^ "@]@.") pp_timestamp now end @@ -35,9 +38,11 @@ type t = X.t Capability.t let solve t ~log reqs = let open X.Solve in let request, params = Capability.Request.create Params.init_pointer in - Params.request_set params (Worker.Solve_request.to_yojson reqs |> Yojson.Safe.to_string); + Params.request_set params + (Worker.Solve_request.to_yojson reqs |> Yojson.Safe.to_string); Params.log_set params (Some log); - Capability.call_for_value_exn t method_id request >|= Results.response_get >|= fun json -> + Capability.call_for_value_exn t method_id request >|= Results.response_get + >|= fun json -> match Worker.Solve_response.of_yojson (Yojson.Safe.from_string json) with | Ok x -> x | Error ex -> failwith ex diff --git a/src/api/worker.ml b/src/api/worker.ml index 765cbb8..3c531a7 100644 --- a/src/api/worker.ml +++ b/src/api/worker.ml @@ -17,7 +17,8 @@ module Selection = struct type t = { id : string; (** The platform ID from the request. *) packages : string list; (** The selected packages ("name.version"). *) - commits : (string * string) list; (** Commits in opam-repositories to use. *) + commits : (string * string) list; + (** Commits in opam-repositories to use. *) } [@@deriving yojson, ord] end @@ -28,7 +29,8 @@ module Solve_request = struct opam_repos_folders : (string * string * string) list; (** Opam repositories to use: name, folder, commit *) pkgs : string list; (** Name of packages to solve. *) - constraints : (string * string) list; (** Version locks: package, version *) + constraints : (string * string) list; + (** Version locks: package, version *) platforms : (string * Vars.t) list; (** Possible build platforms, by ID. *) } [@@deriving yojson] @@ -36,7 +38,8 @@ end (** The response from the solver. *) module Solve_response = struct - type ('a, 'b) result = ('a, 'b) Stdlib.result = Ok of 'a | Error of 'b [@@deriving yojson] + type ('a, 'b) result = ('a, 'b) Stdlib.result = Ok of 'a | Error of 'b + [@@deriving yojson] type t = (Selection.t list, [ `Msg of string ]) result [@@deriving yojson] end diff --git a/src/lib/config.ml b/src/lib/config.ml index 7eaf204..4b1bfb6 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -8,7 +8,9 @@ let profile = let to_obuilder_job build_spec = let open Current.Syntax in let+ build_spec = build_spec in - let spec_str = Fmt.to_to_string Obuilder_spec.pp (build_spec |> Spec.finish) in + let spec_str = + Fmt.to_to_string Obuilder_spec.pp (build_spec |> Spec.finish) + in let open Cluster_api.Obuilder_job.Spec in { spec = `Contents spec_str } @@ -16,14 +18,16 @@ let to_docker_job build_spec = let open Current.Syntax in let spec_str = let+ build_spec = build_spec in - Obuilder_spec.Docker.dockerfile_of_spec ~buildkit:true (build_spec |> Spec.finish) + Obuilder_spec.Docker.dockerfile_of_spec ~buildkit:true + (build_spec |> Spec.finish) in `Contents spec_str let build ?label ?cache_hint t ~pool ~src spec = match profile with | `Production | `Dev -> - to_obuilder_job spec |> Current_ocluster.build_obuilder ?label ?cache_hint t ~pool ~src + to_obuilder_job spec + |> Current_ocluster.build_obuilder ?label ?cache_hint t ~pool ~src | `Docker -> let options = { @@ -33,4 +37,5 @@ let build ?label ?cache_hint t ~pool ~src spec = include_git = true; } in - to_docker_job spec |> Current_ocluster.build ~options ?label ?cache_hint t ~pool ~src + to_docker_job spec + |> Current_ocluster.build ~options ?label ?cache_hint t ~pool ~src diff --git a/src/lib/current_solver.ml b/src/lib/current_solver.ml index 0c6c633..8abba8a 100644 --- a/src/lib/current_solver.ml +++ b/src/lib/current_solver.ml @@ -1,5 +1,4 @@ type resolution = { name : string; version : string } [@@deriving yojson] - type t = { resolutions : resolution list; repos : Repository.t list } let solver = Solver_pool.spawn_local () @@ -33,8 +32,10 @@ module Op = struct `Assoc [ ( "repos", - `List (List.map (fun (_, commit) -> `String (Current_git.Commit.hash commit)) repos) - ); + `List + (List.map + (fun (_, commit) -> `String (Current_git.Commit.hash commit)) + repos) ); ("packages", `List (List.map (fun p -> `String p) packages)); ("system", `String (Fmt.str "%a" Platform.pp_system system)); ] @@ -43,17 +44,15 @@ module Op = struct end module Value = struct - type t = { resolutions : resolution list; repos : (string * string) list } [@@deriving yojson] + type t = { resolutions : resolution list; repos : (string * string) list } + [@@deriving yojson] let marshal t = t |> to_yojson |> Yojson.Safe.to_string - let unmarshal t = t |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok end let auto_cancel = true - let id = "mirage-ci-solver" - let pp f _ = Fmt.string f "Opam solver" open Lwt.Syntax @@ -62,7 +61,8 @@ module Op = struct let rec aux acc = function | [] -> fn (List.rev acc) | commit :: next -> - Current_git.with_checkout ~job commit (fun tmpdir -> aux (tmpdir :: acc) next) + Current_git.with_checkout ~job commit (fun tmpdir -> + aux (tmpdir :: acc) next) in aux [] commits @@ -70,7 +70,9 @@ module Op = struct let* () = Current.Job.start ~level:Harmless job in let repos_git = List.map snd repos in with_checkouts ~job repos_git @@ fun dirs -> - let constraints = [ ("ocaml", Fmt.to_to_string Platform.pp_exact_ocaml system.ocaml) ] in + let constraints = + [ ("ocaml", Fmt.to_to_string Platform.pp_exact_ocaml system.ocaml) ] + in let opam_repos_folders = List.combine dirs repos |> List.map (fun (dir, (name, repo)) -> diff --git a/src/lib/current_solver.mli b/src/lib/current_solver.mli index a7c65f3..513d768 100644 --- a/src/lib/current_solver.mli +++ b/src/lib/current_solver.mli @@ -1,5 +1,4 @@ type resolution = { name : string; version : string } - type t = { resolutions : resolution list; repos : Repository.t list } val v : @@ -7,5 +6,5 @@ val v : repos:Repository.fetched list Current.t -> packages:string list -> t Current.t -(** [v ~system ~repos ~packages] resolves the requested [packages] using the - given [repos] on the platform [system]. The arch is hardcoded to x86_64. *) +(** [v ~system ~repos ~packages] resolves the requested [packages] using the + given [repos] on the platform [system]. The arch is hardcoded to x86_64. *) diff --git a/src/lib/git_store.ml b/src/lib/git_store.ml index e71cc8f..88f35dc 100644 --- a/src/lib/git_store.ml +++ b/src/lib/git_store.ml @@ -13,7 +13,8 @@ open Cmdliner let git_ssh_host = Arg.required @@ Arg.opt Arg.(some string) None - @@ Arg.info ~doc:"The git SSH host to store the transient data" ~docv:"HOST" [ "git-ssh-host" ] + @@ Arg.info ~doc:"The git SSH host to store the transient data" ~docv:"HOST" + [ "git-ssh-host" ] let git_ssh_port = Arg.value @@ -23,23 +24,28 @@ let git_ssh_port = let git_ssh_repository = Arg.required @@ Arg.opt Arg.(some string) None - @@ Arg.info ~doc:"The git repository to store the transient data on the specified host" + @@ Arg.info + ~doc: + "The git repository to store the transient data on the specified host" ~docv:"REPO" [ "git-ssh-repo" ] let git_http_remote = Arg.required @@ Arg.opt Arg.(some string) None - @@ Arg.info ~doc:"The public http remote for the storage repository" ~docv:"HOST" [ "git-http-remote" ] - + @@ Arg.info ~doc:"The public http remote for the storage repository" + ~docv:"HOST" [ "git-http-remote" ] + let private_key_file = Arg.required @@ Arg.opt Arg.(some string) None - @@ Arg.info ~doc:"A private key to use to access the remote" ~docv:"FILE" [ "privkey" ] + @@ Arg.info ~doc:"A private key to use to access the remote" ~docv:"FILE" + [ "privkey" ] let public_key_file = Arg.required @@ Arg.opt Arg.(some string) None - @@ Arg.info ~doc:"A public key to use to access the remote" ~docv:"FILE" [ "pubkey" ] + @@ Arg.info ~doc:"A public key to use to access the remote" ~docv:"FILE" + [ "pubkey" ] let load_file path = try @@ -49,7 +55,8 @@ let load_file path = close_in ch; data with ex -> - if Sys.file_exists path then failwith @@ Fmt.str "Error loading %S: %a" path Fmt.exn ex + if Sys.file_exists path then + failwith @@ Fmt.str "Error loading %S: %a" path Fmt.exn ex else failwith @@ Fmt.str "File %S does not exist" path let v ssh_host ssh_port ssh_repo http_remote private_key_file public_key_file = @@ -65,20 +72,26 @@ let v ssh_host ssh_port ssh_repo http_remote private_key_file public_key_file = let cmdliner = Term.( - const v $ git_ssh_host $ git_ssh_port $ git_ssh_repository $ git_http_remote - $ private_key_file $ public_key_file) - -let v ~ssh_host ?ssh_port ~ssh_repo ~http_remote ~private_key_file ~public_key_file = + const v + $ git_ssh_host + $ git_ssh_port + $ git_ssh_repository + $ git_http_remote + $ private_key_file + $ public_key_file) + +let v ~ssh_host ?ssh_port ~ssh_repo ~http_remote ~private_key_file + ~public_key_file = v ssh_host ssh_port ssh_repo http_remote private_key_file public_key_file let remote t = Fmt.str "git@%s:%s" t.ssh_host t.ssh_repo - let http_remote t = t.http_remote let git_checkout_or_create b = Fmt.str - "(git remote set-branches --add origin %s && git fetch origin %s && git checkout --track \ - origin/%s) || (git checkout -b %s && git push --set-upstream origin %s)" + "(git remote set-branches --add origin %s && git fetch origin %s && git \ + checkout --track origin/%s) || (git checkout -b %s && git push \ + --set-upstream origin %s)" b b b b b module Cluster = struct @@ -104,27 +117,29 @@ module Cluster = struct let clone ~branch ~directory t = Obuilder_spec.run ~network:[ "host" ] ~secrets - "git clone --single-branch %s %s && cd %s && (%s)" (remote t) directory directory + "git clone --single-branch %s %s && cd %s && (%s)" (remote t) directory + directory (git_checkout_or_create branch) let push ?(force = false) _ = - Obuilder_spec.run ~network:[ "host" ] ~secrets (if force then "git push -f" else "git push") + Obuilder_spec.run ~network:[ "host" ] ~secrets + (if force then "git push -f" else "git push") let secrets t = - [ ("ssh_privkey", t.private_key); ("ssh_pubkey", t.public_key); ("ssh_config", config t) ] + [ + ("ssh_privkey", t.private_key); + ("ssh_pubkey", t.public_key); + ("ssh_config", config t); + ] end module type Reader = sig type t val pp : t Fmt.t - val id : string - val fn : Fpath.t -> t Lwt.t - val marshal : t -> string - val unmarshal : string -> t end @@ -152,10 +167,13 @@ let sync ~job t = let* () = Current.Job.use_pool ~switch job t.pool in let* result = match Bos.OS.Path.exists state_folder with - | Error _ -> Fmt.failwith "Failed to look for git folder %a" Fpath.pp state_folder + | Error _ -> + Fmt.failwith "Failed to look for git folder %a" Fpath.pp state_folder | Ok false -> Current.Process.exec ~cancellable:false ~job - ("", [| "git"; "clone"; "--bare"; repo; Fpath.to_string state_folder |]) + ( "", + [| "git"; "clone"; "--bare"; repo; Fpath.to_string state_folder |] + ) | Ok true -> Current.Process.exec ~cwd:state_folder ~cancellable:false ~job ("", [| "git"; "fetch"; "-f"; "origin"; "*:*" |]) @@ -172,7 +190,11 @@ let with_clone ~job ~branch store fn = Current.Process.exec ~cancellable:false ~job ( "", [| - "git"; "clone"; "--single-branch"; Fpath.to_string state_folder; Fpath.to_string tmpdir; + "git"; + "clone"; + "--single-branch"; + Fpath.to_string state_folder; + Fpath.to_string tmpdir; |] ) in let** () = @@ -187,11 +209,9 @@ let with_clone ~job ~branch store fn = module ReadOp (R : Reader) = struct type store = t - type t = No_context let pp f _ = Fmt.pf f "git store" - let id = "git-store-" ^ R.id module Key = struct @@ -217,7 +237,8 @@ module ReadOp (R : Reader) = struct Lwt.return_ok result end -let read (type a) ~branch (module R : Reader with type t = a) store key : a Current.t = +let read (type a) ~branch (module R : Reader with type t = a) store key : + a Current.t = let module Read = ReadOp (R) in let module Cache = Current_cache.Make (Read) in let open Current.Syntax in diff --git a/src/lib/git_store.mli b/src/lib/git_store.mli index a87bbc8..567c31a 100644 --- a/src/lib/git_store.mli +++ b/src/lib/git_store.mli @@ -13,16 +13,12 @@ val v : module Cluster : sig val clone : branch:string -> directory:string -> t -> Obuilder_spec.op - val push : ?force:bool -> t -> Obuilder_spec.op - val secrets : t -> (string * string) list end val remote : t -> string - val http_remote : t -> string - val sync : job:Current.Job.t -> t -> unit Current.or_error Lwt.t val with_clone : @@ -36,15 +32,15 @@ module type Reader = sig type t val pp : t Fmt.t - val id : string - val fn : Fpath.t -> t Lwt.t - val marshal : t -> string - val unmarshal : string -> t end val read : - branch:string -> (module Reader with type t = 'a) -> t -> string Current.t -> 'a Current.t + branch:string -> + (module Reader with type t = 'a) -> + t -> + string Current.t -> + 'a Current.t diff --git a/src/lib/mirage.ml b/src/lib/mirage.ml index 0378f92..227db93 100644 --- a/src/lib/mirage.ml +++ b/src/lib/mirage.ml @@ -1,6 +1,7 @@ open Current.Syntax -let build ~ocluster ~(platform : Platform.t) ~base ~project ~unikernel ~target () = +let build ~ocluster ~(platform : Platform.t) ~base ~project ~unikernel ~target + () = let spec = let+ base = base in let open Obuilder_spec in @@ -8,11 +9,14 @@ let build ~ocluster ~(platform : Platform.t) ~base ~project ~unikernel ~target ( |> Spec.add (Setup.install_tools [ "dune"; "mirage"; "opam-monorepo" ]) |> Spec.add [ - copy [ "./" ^ unikernel ^ "/config.ml" ] ~dst:("/src/" ^ unikernel ^ "/"); + copy + [ "./" ^ unikernel ^ "/config.ml" ] + ~dst:("/src/" ^ unikernel ^ "/"); workdir ("/src/" ^ unikernel); run "sudo chown -R opam:opam ."; env "DUNE_CACHE" "enabled"; - run ~cache:[ Setup.dune_build_cache ] "opam exec -- mirage configure -t %s" target; + run ~cache:[ Setup.dune_build_cache ] + "opam exec -- mirage configure -t %s" target; run ~cache:[ Setup.opam_download_cache; Setup.dune_build_cache ] ~network:Setup.network "opam exec -- make depends"; @@ -22,5 +26,9 @@ let build ~ocluster ~(platform : Platform.t) ~base ~project ~unikernel ~target ( in let label = unikernel ^ "@" ^ target in let src = [ project ] |> Current.list_seq in - let cache_hint = Fmt.str "mirage-ci-skeleton-%a" Platform.pp_system platform.system in - Config.build ~label ~cache_hint ocluster ~pool:(Platform.ocluster_pool platform) ~src spec + let cache_hint = + Fmt.str "mirage-ci-skeleton-%a" Platform.pp_system platform.system + in + Config.build ~label ~cache_hint ocluster + ~pool:(Platform.ocluster_pool platform) + ~src spec diff --git a/src/lib/mirage.mli b/src/lib/mirage.mli index 0c6ec67..7b7477c 100644 --- a/src/lib/mirage.mli +++ b/src/lib/mirage.mli @@ -7,5 +7,5 @@ val build : target:string -> unit -> unit Current.t -(** Run the full mirage build process using ocluster. It includes the installation of mirage, the -configuration step and the build step. *) +(** Run the full mirage build process using ocluster. It includes the + installation of mirage, the configuration step and the build step. *) diff --git a/src/lib/monorepo.ml b/src/lib/monorepo.ml index d61ca85..f30ab97 100644 --- a/src/lib/monorepo.ml +++ b/src/lib/monorepo.ml @@ -27,13 +27,14 @@ let lock_spec ~system ~repos ~opam = workdir "/src"; run "sudo chown opam:opam /src"; run "echo '%s' >> monorepo.opam" (Opamfile.marshal opam); - copy ~from:(`Build "monorepo") [ "/opam-monorepo" ] ~dst:"/usr/local/bin/opam-monorepo"; + copy ~from:(`Build "monorepo") [ "/opam-monorepo" ] + ~dst:"/usr/local/bin/opam-monorepo"; run "opam-monorepo lock -l monorepo.opam.locked"; run "cp monorepo.opam.locked monorepo.opam"; run "opam pin add monorepo -ny -k path /src/ --ignore-pin-depends"; run - "opam list --columns name:,dev-repo: --required-by monorepo -s --separator ';' >> \ - monorepo.dev-repo"; + "opam list --columns name:,dev-repo: --required-by monorepo -s \ + --separator ';' >> monorepo.dev-repo"; ] let upload_spec ~store ~branch = @@ -46,8 +47,8 @@ let upload_spec ~store ~branch = workdir "store"; run "git add monorepo.opam.locked monorepo.dev-repo"; run - "git diff-index --quiet HEAD || git commit -m 'Update monorepo.opam.locked and \ - monorepo.dev-repo'"; + "git diff-index --quiet HEAD || git commit -m 'Update \ + monorepo.opam.locked and monorepo.dev-repo'"; Cluster.push store; ] @@ -57,23 +58,29 @@ module Reader : Git_store.Reader with type t = string * string = struct let id = "monorepo.opam.locked-dev-repo" let fn dir = - let lockfile = Bos.OS.File.read Fpath.(dir / "monorepo.opam.locked") |> Result.get_ok in - let dev_repo = Bos.OS.File.read Fpath.(dir / "monorepo.dev-repo") |> Result.get_ok in + let lockfile = + Bos.OS.File.read Fpath.(dir / "monorepo.opam.locked") |> Result.get_ok + in + let dev_repo = + Bos.OS.File.read Fpath.(dir / "monorepo.dev-repo") |> Result.get_ok + in Lwt.return (lockfile, dev_repo) let marshal t = to_yojson t |> Yojson.Safe.to_string - let unmarshal t = Yojson.Safe.from_string t |> of_yojson |> Result.get_ok - let pp f (lockfile, dev_repo) = Fmt.pf f "Lockfile:\n%s\n\nDev-repo:\n%s\n" lockfile dev_repo + let pp f (lockfile, dev_repo) = + Fmt.pf f "Lockfile:\n%s\n\nDev-repo:\n%s\n" lockfile dev_repo end -let lock ~key ~cluster ~store ~repos ~opam ~system = +let lock ~key ~cluster ~store ~repos ~opam ~system = let spec = let+ opam = opam and+ repos = repos in lock_spec ~system ~repos ~opam |> upload_spec ~store ~branch:key in - let job = Config.build cluster ~pool:"linux-x86_64" ~src:(Current.return []) spec in + let job = + Config.build cluster ~pool:"linux-x86_64" ~src:(Current.return []) spec + in let k = let+ spec = spec and+ _ = job (* fake dependency on job *) in Fmt.to_to_string Obuilder_spec.pp (spec |> Spec.finish) @@ -82,7 +89,9 @@ let lock ~key ~cluster ~store ~repos ~opam ~system = let lock ~key ~value ~cluster ~store ~repos ~opam ~system _ = let lock = - let+ lockfile, dev_repos_str = lock ~key ~cluster ~store ~repos ~opam ~system in + let+ lockfile, dev_repos_str = + lock ~key ~cluster ~store ~repos ~opam ~system + in let lockfile = Opamfile.unmarshal lockfile in Monorepo_lock.make ~opam_file:lockfile ~dev_repo_output:(String.split_on_char '\n' dev_repos_str) @@ -110,7 +119,8 @@ let spec ~base ~lock () = run "opam pin -n remove monorepo"; (* setup lockfile *) run "cp monorepo.opam monorepo.opam.locked"; - run ~network:Setup.network "opam exec -- opam monorepo pull -y -l monorepo.opam.locked"; + run ~network:Setup.network + "opam exec -- opam monorepo pull -y -l monorepo.opam.locked"; ] (********************************************) diff --git a/src/lib/monorepo.mli b/src/lib/monorepo.mli index bc89fff..376f83c 100644 --- a/src/lib/monorepo.mli +++ b/src/lib/monorepo.mli @@ -1,7 +1,10 @@ type t (** The opam monorepo tool*) -val v : system:Platform.system -> repos:Repository.fetched list Current.t -> t Current.t +val v : + system:Platform.system -> + repos:Repository.fetched list Current.t -> + t Current.t (** Build the opam monorepo tool on [system] using [repos]. *) val lock : @@ -14,9 +17,13 @@ val lock : system:Platform.system -> t Current.t -> Monorepo_lock.t Current.t -(** Perform `opam monorepo lock` on the given [opam] definition using [repos]. *) +(** Perform `opam monorepo lock` on the given [opam] definition using [repos]. *) -val spec : base:Spec.t Current.t -> lock:Monorepo_lock.t Current.t -> unit -> Spec.t Current.t +val spec : + base:Spec.t Current.t -> + lock:Monorepo_lock.t Current.t -> + unit -> + Spec.t Current.t (** Use opam-monorepo to fetch the lockfile in /src/duniverse *) val opam_file : ocaml_version:string -> Universe.Project.t list -> Opamfile.t diff --git a/src/lib/monorepo_git_push.ml b/src/lib/monorepo_git_push.ml index 915a20d..247c8b2 100644 --- a/src/lib/monorepo_git_push.ml +++ b/src/lib/monorepo_git_push.ml @@ -13,16 +13,20 @@ module GitPush = struct type t = Current_git.Commit.t list let digest t = - let json = `List (List.map (fun x -> `String (Current_git.Commit.hash x)) t) in + let json = + `List (List.map (fun x -> `String (Current_git.Commit.hash x)) t) + in Yojson.to_string json end module Outcome = struct type t = Current_git.Commit_id.t - type info = { repo : string; hash : string; gref : string } [@@deriving yojson] + type info = { repo : string; hash : string; gref : string } + [@@deriving yojson] - let t_of_info { repo; gref; hash } = Current_git.Commit_id.v ~repo ~gref ~hash + let t_of_info { repo; gref; hash } = + Current_git.Commit_id.v ~repo ~gref ~hash let info_of_t t = let open Current_git.Commit_id in @@ -30,13 +34,16 @@ module GitPush = struct let marshal t = t |> info_of_t |> info_to_yojson |> Yojson.Safe.to_string - let unmarshal t = t |> Yojson.Safe.from_string |> info_of_yojson |> Result.get_ok |> t_of_info + let unmarshal t = + t + |> Yojson.Safe.from_string + |> info_of_yojson + |> Result.get_ok + |> t_of_info end let auto_cancel = true - let pp f _ = Fmt.string f "Monorepo git push" - let id = "mirage-ci-monorepo-git-push" let publish No_context job { Key.store; branch } commits = @@ -45,8 +52,12 @@ module GitPush = struct let* () = Current.Job.start ~level:Average job in let** () = Git_store.sync ~job store in Git_store.with_clone ~job ~branch store @@ fun tmpdir -> - let cmd cmd = Current.Process.exec ~cwd:tmpdir ~cancellable:true ~job ("", cmd) in - let read cmd = Current.Process.check_output ~cwd:tmpdir ~cancellable:true ~job ("", cmd) in + let cmd cmd = + Current.Process.exec ~cwd:tmpdir ~cancellable:true ~job ("", cmd) + in + let read cmd = + Current.Process.check_output ~cwd:tmpdir ~cancellable:true ~job ("", cmd) + in let** () = cmd [| "git"; "rm"; "*"; "--ignore-unmatch" |] in let** () = cmd [| "touch"; ".gitmodules" |] in let** _ = @@ -55,16 +66,37 @@ module GitPush = struct match status with | Ok () -> Current_git.with_checkout ~pool ~job commit @@ fun commit_dir -> - let repo = commit |> Current_git.Commit.id |> Current_git.Commit_id.repo in - let branch = commit |> Current_git.Commit.id |> Current_git.Commit_id.gref in - let repo_name = repo |> Filename.basename |> Filename.remove_extension in + let repo = + commit |> Current_git.Commit.id |> Current_git.Commit_id.repo + in + let branch = + commit |> Current_git.Commit.id |> Current_git.Commit_id.gref + in + let repo_name = + repo |> Filename.basename |> Filename.remove_extension + in + let** () = + cmd + [| + "cp"; + "-R"; + Fpath.to_string commit_dir; + Fpath.(to_string (tmpdir / repo_name)); + |] + in let** () = cmd [| - "cp"; "-R"; Fpath.to_string commit_dir; Fpath.(to_string (tmpdir / repo_name)); + "git"; + "submodule"; + "add"; + "-f"; + "-b"; + branch; + repo; + repo_name; |] in - let** () = cmd [| "git"; "submodule"; "add"; "-f"; "-b"; branch; repo; repo_name |] in Lwt.return_ok () | err -> Lwt.return err) (Ok ()) commits @@ -88,7 +120,10 @@ module GitPush = struct Lwt.return_ok () in let** hash = read [| "git"; "rev-parse"; "HEAD" |] in - Lwt.return_ok (Current_git.Commit_id.v ~repo:(Git_store.http_remote store) ~gref:branch ~hash) + Lwt.return_ok + (Current_git.Commit_id.v + ~repo:(Git_store.http_remote store) + ~gref:branch ~hash) end module GitPushCache = Current_cache.Output (GitPush) diff --git a/src/lib/monorepo_git_push.mli b/src/lib/monorepo_git_push.mli index 7e34a34..08b72bb 100644 --- a/src/lib/monorepo_git_push.mli +++ b/src/lib/monorepo_git_push.mli @@ -3,5 +3,6 @@ val v : branch:string -> Current_git.Commit.t list Current.term -> Current_git.Commit_id.t Current.term -(** Assemble a submodules monorepo from the given list of commits and push it on [remote_push]. -Returns a Current_git.Commit.t from which the pushed repo can be retrieved. *) +(** Assemble a submodules monorepo from the given list of commits and push it on + [remote_push]. Returns a Current_git.Commit.t from which the pushed repo can + be retrieved. *) diff --git a/src/lib/monorepo_lock.ml b/src/lib/monorepo_lock.ml index 73333fc..4c8f30f 100644 --- a/src/lib/monorepo_lock.ml +++ b/src/lib/monorepo_lock.ml @@ -1,17 +1,27 @@ -type t = { lockfile : Opamfile.t; dev_repos_output : string list } [@@deriving yojson] +type t = { lockfile : Opamfile.t; dev_repos_output : string list } +[@@deriving yojson] -let make ~opam_file ~dev_repo_output = { lockfile = opam_file; dev_repos_output = dev_repo_output } +let make ~opam_file ~dev_repo_output = + { lockfile = opam_file; dev_repos_output = dev_repo_output } let marshal t = to_yojson t |> Yojson.Safe.to_string let unmarshal s = - match Yojson.Safe.from_string s |> of_yojson with Ok x -> x | Error e -> failwith e + match Yojson.Safe.from_string s |> of_yojson with + | Ok x -> x + | Error e -> failwith e -type project = { name : string; dev_repo : string; repo : string; packages : string list } +type project = { + name : string; + dev_repo : string; + repo : string; + packages : string list; +} let lockfile t = t.lockfile -let clean = Astring.String.trim ~drop:(function ' ' | '\t' | '"' -> true | _ -> false) +let clean = + Astring.String.trim ~drop:(function ' ' | '\t' | '"' -> true | _ -> false) let build_project_list (packages : Opamfile.pkg list) dev_repos_output = let module StringMap = Map.Make (String) in @@ -28,25 +38,35 @@ let build_project_list (packages : Opamfile.pkg list) dev_repos_output = (fun (line : string) -> match String.split_on_char ';' line with | [ name; dev_repo ] -> - dev_repo_map := StringMap.add (clean name) (clean dev_repo) !dev_repo_map + dev_repo_map := + StringMap.add (clean name) (clean dev_repo) !dev_repo_map | _ -> ()) dev_repos_output in StringMap.fold (fun repo (pkgs : Opamfile.pkg list) aux -> - let packages = List.map (fun (pkg : Opamfile.pkg) -> clean pkg.name) pkgs in + let packages = + List.map (fun (pkg : Opamfile.pkg) -> clean pkg.name) pkgs + in let name = List.fold_left (fun cur_name name -> match cur_name with | Some cur_name - when String.(length cur_name < length name) || StringMap.mem name !dev_repo_map -> + when String.(length cur_name < length name) + || StringMap.mem name !dev_repo_map -> Some cur_name | _ -> Some name) None packages |> Option.get in - { name; dev_repo = StringMap.find name !dev_repo_map; repo = clean repo; packages } :: aux) + { + name; + dev_repo = StringMap.find name !dev_repo_map; + repo = clean repo; + packages; + } + :: aux) !repo_map [] let projects t = @@ -63,7 +83,10 @@ let parse_opam_dev_repo dev_repo = | [ repo; branch ] -> (repo, Some branch) | _ -> failwith "String.cuts dev_repo" in - let repo = if String.is_prefix ~affix:"git+" repo then String.drop ~max:4 repo else repo in + let repo = + if String.is_prefix ~affix:"git+" repo then String.drop ~max:4 repo + else repo + in Printf.printf "repo: %s\n" repo; (repo, branch) @@ -75,7 +98,8 @@ let commits ?(filter = fun _ -> true) lock = try let projects = projects lockv in Printf.printf "got %d projects to track.\n" (List.length projects); - projects |> List.filter filter + projects + |> List.filter filter |> List.map (fun (x : project) -> let repo_url, repo_branch = parse_opam_dev_repo x.dev_repo in Current_git.clone ~schedule:daily ?gref:repo_branch repo_url) diff --git a/src/lib/monorepo_lock.mli b/src/lib/monorepo_lock.mli index 446c947..bc6371b 100644 --- a/src/lib/monorepo_lock.mli +++ b/src/lib/monorepo_lock.mli @@ -1,21 +1,30 @@ type t -(** Represents the output of opam monorepo lock, with additional metadata on the dev repositories. *) +(** Represents the output of opam monorepo lock, with additional metadata on the + dev repositories. *) val make : opam_file:Opamfile.t -> dev_repo_output:string list -> t -(** [make ~opam_file ~dev_repo_output] parses the lockfile and the dev repo output. *) +(** [make ~opam_file ~dev_repo_output] parses the lockfile and the dev repo + output. *) val marshal : t -> string - val unmarshal : string -> t val lockfile : t -> Opamfile.t (** Get the lockfile back *) -type project = { name : string; dev_repo : string; repo : string; packages : string list } +type project = { + name : string; + dev_repo : string; + repo : string; + packages : string list; +} val projects : t -> project list (** Get the list of projects (=repositories) of this lockfile *) -val commits : ?filter:(project -> bool) -> t Current.t -> Current_git.Commit.t list Current.t -(** Resolve the dev repositories to find the commits of each main branch. [filter] can be used to -select specific repositories.*) +val commits : + ?filter:(project -> bool) -> + t Current.t -> + Current_git.Commit.t list Current.t +(** Resolve the dev repositories to find the commits of each main branch. + [filter] can be used to select specific repositories.*) diff --git a/src/lib/opamfile.ml b/src/lib/opamfile.ml index 9050002..c4aaff0 100644 --- a/src/lib/opamfile.ml +++ b/src/lib/opamfile.ml @@ -1,12 +1,13 @@ type t = OpamParserTypes.opamfile - type pkg = { name : string; version : string; repo : string } let get_packages (opam_file : t) = let open OpamParserTypes in let pin_depends = List.find_map - (function Variable (_, name, value) when name = "pin-depends" -> Some value | _ -> None) + (function + | Variable (_, name, value) when name = "pin-depends" -> Some value + | _ -> None) opam_file.file_contents |> Option.get (* what if no package ? *) @@ -21,14 +22,13 @@ let get_packages (opam_file : t) = in Some { name; version; repo } | _ -> None) - (match pin_depends with List (_, v) -> v | _ -> failwith "failed to parse opam") + (match pin_depends with + | List (_, v) -> v + | _ -> failwith "failed to parse opam") let marshal = OpamPrinter.opamfile - let unmarshal t = OpamParser.string t "monorepo.opam" - let digest x = marshal x |> Digest.string |> Digest.to_hex - let to_yojson f = `String (OpamPrinter.opamfile f) let of_yojson = function diff --git a/src/lib/opamfile.mli b/src/lib/opamfile.mli index 62b6820..d2ca8e8 100644 --- a/src/lib/opamfile.mli +++ b/src/lib/opamfile.mli @@ -1,15 +1,9 @@ type t = OpamParserTypes.opamfile - type pkg = { name : string; version : string; repo : string } val get_packages : t -> pkg list - val marshal : t -> string - val unmarshal : string -> t - val digest : t -> string - val to_yojson : t -> Yojson.Safe.t - val of_yojson : Yojson.Safe.t -> (t, string) result diff --git a/src/lib/platform.ml b/src/lib/platform.ml index 1376fa0..e68e07c 100644 --- a/src/lib/platform.ml +++ b/src/lib/platform.ml @@ -16,7 +16,10 @@ type os = Debian | Ubuntu | Fedora let os_version = function Ubuntu -> "20.04" | Fedora -> "33" | Debian -> "10" -let os_family = function Ubuntu -> "ubuntu" | Fedora -> "fedora" | Debian -> "debian" +let os_family = function + | Ubuntu -> "ubuntu" + | Fedora -> "fedora" + | Debian -> "debian" let pp_os f t = Fmt.pf f "%s-%s" (os_family t) (os_version t) @@ -27,7 +30,6 @@ let arch_to_string = function Arm64 -> "arm64" | Amd64 -> "x86_64" type system = { ocaml : ocaml_version; os : os } let pp_system f { ocaml; os } = Fmt.pf f "%a-ocaml-%a" pp_os os pp_ocaml ocaml - let spec t = Spec.make @@ Fmt.str "ocaml/opam:%a" pp_system t type t = { system : system; arch : arch } @@ -38,23 +40,32 @@ let platform_id t = | Amd64 -> "x86_64-" ^ Fmt.str "%a" pp_system t.system let pp_platform f t = - Fmt.pf f "%s / %a / %a" (arch_to_string t.arch) pp_os t.system.os pp_ocaml t.system.ocaml + Fmt.pf f "%s / %a / %a" (arch_to_string t.arch) pp_os t.system.os pp_ocaml + t.system.ocaml -let ocluster_pool { arch; _ } = match arch with Arm64 -> "linux-arm64" | Amd64 -> "linux-x86_64" +let ocluster_pool { arch; _ } = + match arch with Arm64 -> "linux-arm64" | Amd64 -> "linux-x86_64" (* Base configuration.. *) +let platform_v412_amd64 = + { system = { ocaml = V4_12; os = Debian }; arch = Amd64 } -let platform_v412_amd64 = { system = { ocaml = V4_12; os = Debian }; arch = Amd64 } - -let platform_v412_arm64 = { system = { ocaml = V4_12; os = Debian }; arch = Arm64 } +let platform_v412_arm64 = + { system = { ocaml = V4_12; os = Debian }; arch = Arm64 } -let platform_v413_amd64 = { system = { ocaml = V4_13; os = Debian }; arch = Amd64 } +let platform_v413_amd64 = + { system = { ocaml = V4_13; os = Debian }; arch = Amd64 } -let platform_v413_arm64 = { system = { ocaml = V4_13; os = Debian }; arch = Arm64 } +let platform_v413_arm64 = + { system = { ocaml = V4_13; os = Debian }; arch = Arm64 } let platform_host = Bos.Cmd.(v "uname" % "-m") - |> Bos.OS.Cmd.run_out |> Bos.OS.Cmd.out_string |> Result.to_option - |> Option.map (function ("aarch64" | "arm64"), _ -> platform_v413_arm64 | _ -> platform_v413_amd64) + |> Bos.OS.Cmd.run_out + |> Bos.OS.Cmd.out_string + |> Result.to_option + |> Option.map (function + | ("aarch64" | "arm64"), _ -> platform_v413_arm64 + | _ -> platform_v413_amd64) |> Option.value ~default:platform_v413_amd64 diff --git a/src/lib/repository.ml b/src/lib/repository.ml index 78292f7..096beab 100644 --- a/src/lib/repository.ml +++ b/src/lib/repository.ml @@ -6,7 +6,9 @@ type fetched = string * Current_git.Commit.t let pp f (v1, v2) = Fmt.pf f "%s:%a%a" v1 Fmt.cut () Current_git.Commit_id.pp v2 let compare (a1, b1) (a2, b2) = - match String.compare a1 a2 with 0 -> Current_git.Commit_id.compare b1 b2 | v -> v + match String.compare a1 a2 with + | 0 -> Current_git.Commit_id.compare b1 b2 + | v -> v let fetch c = let open Current.Syntax in diff --git a/src/lib/repository.mli b/src/lib/repository.mli index aae37c3..1938a9e 100644 --- a/src/lib/repository.mli +++ b/src/lib/repository.mli @@ -5,11 +5,7 @@ type fetched = string * Current_git.Commit.t (** A fetched opam repo *) val pp : t Fmt.t - val compare : t -> t -> int - val fetch : t Current.t -> fetched Current.t - val unfetch : fetched -> t - val current_list_unfetch : fetched list Current.t -> t list Current.t diff --git a/src/lib/setup.ml b/src/lib/setup.ml index eab9495..8bb74dd 100644 --- a/src/lib/setup.ml +++ b/src/lib/setup.ml @@ -1,7 +1,8 @@ let opam_download_cache = - Obuilder_spec.Cache.v "download-cache" ~target:"/home/opam/.opam/download-cache" + Obuilder_spec.Cache.v "download-cache" + ~target:"/home/opam/.opam/download-cache" -let dune_build_cache = +let dune_build_cache = Obuilder_spec.Cache.v "dune-build-cache" ~target:"/home/opam/.cache/dune" let network = [ "host" ] @@ -17,4 +18,7 @@ let add_repositories = let install_tools tools = let tools_s = String.concat " " tools in - [ Obuilder_spec.run ~network ~cache:[ opam_download_cache ] "opam install -y %s" tools_s ] + [ + Obuilder_spec.run ~network ~cache:[ opam_download_cache ] + "opam install -y %s" tools_s; + ] diff --git a/src/lib/skeleton.ml b/src/lib/skeleton.ml index 25421d2..ca7d9ad 100644 --- a/src/lib/skeleton.ml +++ b/src/lib/skeleton.ml @@ -1,7 +1,6 @@ module Git = Current_git type stage = string * string * string list [@@deriving yojson] - type stages = stage list [@@deriving yojson] let pool = Current.Pool.create ~label:"skeleton-stages" 8 @@ -10,7 +9,9 @@ let stages_spec = Fpath. [ ("1: test-target", v "tutorial", Some [ "noop" ]); - ("2: tutorial", v "tutorial", Some [ "noop-functor"; "hello"; "hello-key"; "app_info" ]); + ( "2: tutorial", + v "tutorial", + Some [ "noop-functor"; "hello"; "hello-key"; "app_info" ] ); ("3: tutorial-lwt", v "tutorial" / "lwt", None); ("4: devices", v "device-usage", None); ("5: applications", v "applications", None); @@ -22,7 +23,8 @@ let test_unikernel path = let unikernel_name = Fpath.basename path in if (not (List.mem unikernel_name blacklist)) - && Bos.OS.Path.exists Fpath.(path / "config.ml") |> Result.value ~default:false + && Bos.OS.Path.exists Fpath.(path / "config.ml") + |> Result.value ~default:false then Some unikernel_name else None @@ -47,14 +49,11 @@ module SkeletonStages = struct type t = stages [@@deriving yojson] let marshal t = t |> to_yojson |> Yojson.Safe.to_string - let unmarshal t = t |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok end let pp f _ = Fmt.pf f "Skeleton stages" - let id = "skeleton-stages" - let auto_cancel = true let build No_context job commit = @@ -64,7 +63,9 @@ module SkeletonStages = struct let spec = List.map (do_stage ~path) stages_spec in List.iter (fun (name, root, unikernels) -> - Current.Job.log job "%s: %s -> %a" name root Fmt.(list ~sep:(any ", ") string) unikernels) + Current.Job.log job "%s: %s -> %a" name root + Fmt.(list ~sep:(any ", ") string) + unikernels) spec; Lwt.return_ok spec end diff --git a/src/lib/skeleton.mli b/src/lib/skeleton.mli index 8c5a513..6ac014d 100644 --- a/src/lib/skeleton.mli +++ b/src/lib/skeleton.mli @@ -1,4 +1,5 @@ -type stage = string * string * string list (* name, root folder, unikernel folder *) +type stage = string * string * string list +(* name, root folder, unikernel folder *) type stages = stage list diff --git a/src/lib/solver_pool.ml b/src/lib/solver_pool.ml index 4cee708..2c2a2d9 100644 --- a/src/lib/solver_pool.ml +++ b/src/lib/solver_pool.ml @@ -2,10 +2,14 @@ let spawn_local ?solver_dir () : Solver_api.Solver.t = let p, c = Unix.(socketpair PF_UNIX SOCK_STREAM 0 ~cloexec:true) in Unix.clear_close_on_exec c; let solver_dir = - match solver_dir with None -> Fpath.to_string (Current.state_dir "solver") | Some x -> x + match solver_dir with + | None -> Fpath.to_string (Current.state_dir "solver") + | Some x -> x in let cmd = ("", [| "mirage-ci-solver" |]) in - let _child = Lwt_process.open_process_none ~cwd:solver_dir ~stdin:(`FD_move c) cmd in + let _child = + Lwt_process.open_process_none ~cwd:solver_dir ~stdin:(`FD_move c) cmd + in let switch = Lwt_switch.create () in let p = Lwt_unix.of_unix_file_descr p @@ -14,8 +18,13 @@ let spawn_local ?solver_dir () : Solver_api.Solver.t = (module Capnp_rpc_unix.Unix_flow) ~peer_id:Capnp_rpc_net.Auth.Digest.insecure ~switch in - let conn = Capnp_rpc_unix.CapTP.connect ~restore:Capnp_rpc_net.Restorer.none p in - let solver = Capnp_rpc_unix.CapTP.bootstrap conn (Capnp_rpc_net.Restorer.Id.public "solver") in + let conn = + Capnp_rpc_unix.CapTP.connect ~restore:Capnp_rpc_net.Restorer.none p + in + let solver = + Capnp_rpc_unix.CapTP.bootstrap conn + (Capnp_rpc_net.Restorer.Id.public "solver") + in solver |> Capnp_rpc_lwt.Capability.when_broken (fun ex -> Fmt.failwith "Solver process failed: %a" Capnp_rpc.Exception.pp ex); diff --git a/src/lib/spec.ml b/src/lib/spec.ml index fbead97..22f28d7 100644 --- a/src/lib/spec.ml +++ b/src/lib/spec.ml @@ -1,10 +1,17 @@ -type t = { base : string; ops : Obuilder_spec.op list; children : (string * Obuilder_spec.t) list } +type t = { + base : string; + ops : Obuilder_spec.op list; + children : (string * Obuilder_spec.t) list; +} -let add next_ops { base; ops; children } = { base; ops = ops @ next_ops; children } +let add next_ops { base; ops; children } = + { base; ops = ops @ next_ops; children } -let children ~name spec { base; ops; children } = { base; ops; children = (name, spec) :: children } +let children ~name spec { base; ops; children } = + { base; ops; children = (name, spec) :: children } -let finish { base; ops; children } = Obuilder_spec.stage ~child_builds:children ~from:base ops +let finish { base; ops; children } = + Obuilder_spec.stage ~child_builds:children ~from:base ops let make base = let open Obuilder_spec in @@ -15,8 +22,7 @@ let make base = user ~uid:1000 ~gid:1000; workdir "/home/opam"; run "sudo chown opam:opam /home/opam"; - run - "sudo ln -f /usr/bin/opam-2.1 /usr/bin/opam && opam update"; + run "sudo ln -f /usr/bin/opam-2.1 /usr/bin/opam && opam update"; ]; children = []; } diff --git a/src/lib/universe.ml b/src/lib/universe.ml index 08f03a6..3969548 100644 --- a/src/lib/universe.ml +++ b/src/lib/universe.ml @@ -1,5 +1,4 @@ type target = Unix | Mirage - type package = { name : string; mirage : bool; sublibs : string list } let opam ?(mirage = true) ?(sublibs = []) name = { name; mirage; sublibs } @@ -48,437 +47,438 @@ module Project = struct opam ~mirage:false "cstruct-async"; ] "Map OCaml arrays onto C-like structs, suitable for parsing wire protocols.";*) - v "ocaml-uri" [ opam "uri"; opam "uri-sexp" ] "RFC3986 URI parsing library"; + v "ocaml-uri" + [ opam "uri"; opam "uri-sexp" ] + "RFC3986 URI parsing library"; v "digestif" [ opam "digestif" ] "Hashing functions in pure OCaml or C."; ] let repo { repo; _ } = repo end -(* -- org: mirage - repo: ocaml-hvsock - type: driver/win - opam: [hvsock] - descr: These bindings allow Host to VM communication on Hyper-V systems on both Linux and Windows. -- org: mirage - repo: mirage-skeleton - type: example - descr: Examples of different types of Mirage applications. -- org: mirage - repo: ocaml-tuntap - type: driver/unix - opam: [tuntap] - descr: Bindings to the [tuntap](https://en.wikipedia.org/wiki/TUN/TAP) virtual network kernel devices, for userspace networking on Linux and macos. -- org: mirage - repo: ocaml-cstruct - type: parsing - opam: [cstruct] - descr: Map OCaml arrays onto C-like structs, suitable for parsing wire protocols. -- org: mirage - repo: shared-block-ring - type: storage - opam: [shared-block-ring] - descr: A simple persistent on-disk fixed length queue. -- org: mirage - repo: prometheus - type: logging - opam: [prometheus,prometheus-app] - descr: Report metrics to a Prometheus server. -- org: mirage - repo: ocaml-uri - type: web - opam: [uri] - descr: RFC3986 URI parsing library -- org: mirage - repo: irmin - type: vcs - opam: [irmin,irmin-unix,mirage-irmin] - descr: a library for persistent stores with built-in snapshot, branching and reverting mechanisms. -- org: mirage - repo: ocaml-qcow - type: storage - opam: [qcow] - descr: pure OCaml code for parsing, printing, modifying `.qcow` format data -- org: mirage - repo: ocaml-dns - type: network - opam: [dns,mirage-dns] - descr: a pure OCaml implementation of the DNS protocol, intended to be a reasonably high-performance implementation. -- org: mirage - repo: ocaml-conduit - type: network - opam: [conduit,mirage-conduit] - descr: a library to establish and listen for TCP and SSL/TLS connections. -- org: mirage - repo: ocaml-tar - type: storage - opam: [tar] - descr: read and write tar files, with an emphasis on streaming. -- org: mirage - repo: ocaml-pcap - type: network - opam: [pcap-format] - descr: an interface to encode and decode pcap files, dealing with both endianess, including endianess detection. -- org: mirage - repo: mirage-tcpip - type: network - opam: [tcpip] - descr: a pure OCaml implementation of the TCP/IP protocol suite. -- org: mirage - repo: charrua-core - type: network - opam: [charrua-core] - descr: a DHCPv4 server and wire frame encoder and decoder. -- org: mirage - repo: alcotest - type: testing - opam: [alcotest] - descr: a lightweight and colourful test framework that exposes simple interface to perform unit tests. -- org: mirage - repo: ocaml-ipaddr - type: network - opam: [ipaddr] - descr: a library for manipulation of IP (and MAC) address representations. -- org: mirage - repo: mirage-block-ramdisk - type: storage - opam: [mirage-block-ramdisk] - descr: a simple in-memory block device. -- org: mirage - repo: mirage-block - type: core - opam: [mirage-block,mirage-block-lwt] - descr: generic operations over Mirage block devices. -- org: mirage - repo: mirage-block-unix - type: driver/unix - opam: [mirage-block-unix] - descr: Unix implementation of the Mirage block interface. -- org: mirage - repo: mirage-block-xen - type: driver/xen - opam: [mirage-block-xen] - descr: Client and server implementations of the Xen paravirtualised block driver protocol -- org: mirage - repo: mirage-net-xen - type: driver/xen - opam: [mirage-net-xen] - descr: Client and server implementations of the Xen paravirtualised network driver protocol -- org: mirage - repo: ocaml-vchan - type: driver/xen - opam: [vchan] - descr: implementation of the "vchan" shared-memory communication protocol. -- org: mirage - repo: mirage-platform - type: driver - opam: [mirage-unix,mirage-xen-ocaml,mirage-xen] - descr: Platform libraries for Mirage for Unix and Xen that handle timers, device setup and the main loop, as well as the runtime for the Xen unikernel. -- org: mirage - repo: mirage-protocols - type: core - opam: [mirage-protocols,mirage-protocols-lwt] - descr: a set of module types that libraries intended to be used as Mirage network implementations should implement. -- org: mirage - repo: ocaml-cohttp - type: web - opam: [cohttp] - descr: a library for creating HTTP daemons, with a portable HTTP parser and implementations using various asynchronous programming libraries. -- org: mirage - repo: ocaml-crunch - type: storage - opam: [crunch] - descr: take a directory of files and compile them into a standalone OCaml module that serves the contents directly from memory. -- org: mirage - repo: ocaml-fat - type: storage - opam: [fat-filesystem] - descr: implementation of the FAT filesystem to allow the easy preparation of bootable disk images containing kernels, and to provide a simple filesystem layer for Mirage applications. -- org: mirage - repo: mirage-http - type: web - opam: [mirage-http] - descr: a Cohttp-based webserver implementation of the Mirage HTTP interfaces. -- org: mirage - repo: mirage-fs-unix - type: driver/unix - opam: [mirage-fs-unix] - descr: a pass-through Mirage filesystem to an underlying Unix directory. -- org: mirage - repo: mirage-bootvar-xen - type: driver/xen - opam: [mirage-bootvar-xen] - descr: library for reading Mirage unikernel boot parameters from Xen. -- org: mirage - repo: mirage-net-unix - type: driver/unix - opam: [mirage-net-unix] - descr: Unix implementation of the Mirage NETWORK interface that exposes Ethernet frames via tuntap. -- org: mirage - repo: mirage-net-macosx - type: driver/osx - opam: [mirage-net-macosx] - descr: MacOSX implementation of the Mirage NETWORK interface that exposes raw Ethernet frames using the Vmnet framework available in MacOS X Yosemite onwards. -- org: mirage - repo: mirage-entropy - type: core - opam: [mirage-entropy] - descr: Reliable entropy sources for Mirage unikernels. -- org: mirage - repo: mirage-time - type: core - opam: [mirage-time,mirage-time-lwt] - descr: Module types for time-related operations in Mirage. -- org: mirage - repo: mirage-random - type: core - opam: [mirage-random] - descr: Randomness signatures for Mirage, and an implementation using the OCaml stdlib. -- org: mirage - repo: mirage-net - type: core - opam: [mirage-net,mirage-net-lwt] - descr: Network (Ethernet) signatures for Mirage. -- org: mirage - repo: mirage-logs - type: core - opam: [mirage-logs] - descr: a reporter for the [Logs](http://erratique.ch/software/logs) library that writes log messages to stderr, using a Mirage `CLOCK` to add timestamps. -- org: mirage - repo: mirage-kv - type: core - opam: [mirage-kv,mirage-kv-lwt] - descr: provides key/value store signatures that Mirage storage libraries can implement. -- org: mirage - repo: mirage-fs - type: core - opam: [mirage-fs,mirage-fs-lwt] - descr: provides filesystem module signatures that Mirage storage libraries can implement. -- org: mirage - repo: mirage-flow - type: core - opam: [mirage-flow,mirage-flow-lwt] - descr: Network flow implementations and combinators to manipulate and compose them. -- org: mirage - repo: mirage-console - type: core - opam: [mirage-console-lwt,mirage-console,mirage-console-unix,mirage-console-xen-backend,mirage-console-xen-cli,mirage-console-xen-proto,mirage-console-xen] - descr: Pure OCaml module types and implementations of Mirage consoles, for Unix and Xen. -- org: mirage - repo: mirage-clock - type: core - opam: [mirage-clock,mirage-clock-freestanding,mirage-clock-lwt,mirage-clock-unix] - descr: portable support for an operating system timesources. -- org: mirage - repo: mirage-channel - type: core - opam: [mirage-channel,mirage-channel-lwt] - descr: Channels are buffered reader/writers built on top of an unbuffered mirage-flow implementation. -- org: mirage - repo: mirage-stack - type: core - opam: [mirage-stack,mirage-stack-lwt] - descr: provides a set of module types which libraries intended to be used as Mirage network stacks should implement. -- org: mirage - repo: mirage-device - type: core - opam: [mirage-device] - descr: the signature for basic abstract devices for Mirage and a pretty-printing function for device errors -- org: mirage - repo: ocaml-vhd - type: storage - opam: [vhd-format] - descr: a pure OCaml library to read and write vhd format data, plus a simple command-line tool which allows vhd files to be interrogated, manipulated, format-converted and streamed to and from files and remote servers. -- org: mirage - repo: ocaml-freestanding - type: driver - opam: [ocaml-freestanding] - descr: a freestanding OCaml runtime suitable for linking with a unikernel base layer such as Solo5. -- org: mirage - repo: mirage-solo5 - type: driver/solo5 - opam: [mirage-solo5] - descr: the Mirage `OS` library for Solo5 targets, which handles the main loop and timers. -- org: mirage - repo: mirage-block-solo5 - type: driver/solo5 - opam: [mirage-block-solo5] - descr: Solo5 implementation of the Mirage block interface. -- org: mirage - repo: mirage-net-solo5 - type: driver/solo5 - opam: [mirage-net-solo5] - descr: Solo5 implementation of the Mirage network interface. -- org: mirage - repo: mirage-bootvar-solo5 - type: driver/solo5 - opam: [mirage-bootvar-solo5] - descr: library for passing boot-time variables to Solo5 targets. -- org: mirage - repo: mirage-console-solo5 - type: driver/solo5 - opam: [mirage-console-solo5] - descr: implementation of the Mirage Console interface for Solo5 targets. -- org: mirage - repo: ocaml-github - type: vcs - opam: [github] - descr: an OCaml interface to the GitHub APIv3 (JSON) that is compatible with Mirage and also compiles to pure JavaScript. -- org: mirage - repo: ocaml-git - type: vcs - opam: [git,git-mirage,git-unix] - descr: Git format and protocol in pure OCaml, with support for on-disk and in-memory Git stores. -- org: mirage - repo: ocaml-9p - type: storage - opam: [9p-format] - descr: an implementation of the 9P protocol from outer space. -- org: mirage - repo: shared-memory-ring - type: driver/xen - opam: [shared-memory-ring] - descr: a set of libraries for creating shared memory producer/consumer rings that follow the Xen hypervisor ABI for virtual devices. -- org: mirage - repo: io-page - type: driver - opam: [io-page] - descr: support for efficient handling of I/O memory pages on Unix and Xen. -- org: mirage - repo: ocaml-evtchn - type: driver/xen - opam: [evtchn] - descr: Xen event channel interface for Mirage. Event channels are the Xen equivalent of interrupts, used to signal when data is available for processing. -- org: mirage - repo: ocaml-gnt - type: driver/xen - opam: [gnt] - descr: Xen grant table bindings for OCaml that are used to create Xen device driver "backends" (servers) and "frontends" (clients). -- org: mirage - repo: cowabloga - type: web - opam: [cowabloga] - descr: a deprecated library to setup a simple blog and wiki using the Zurb Foundation CSS/HTML templates. -- org: mirage - repo: ocaml-cow - type: web - opam: [cow] - descr: OCaml combinators for HTML, XML, JSON and Markdown format handling. -- org: mirage - repo: mirage-xen-minios - type: driver/xen - opam: [mirage-xen-minios] - descr: installs the C libraries for the Xen MiniOS and OpenLibM. -- org: mirage - repo: ocaml-named-pipe - type: driver/win - opam: [named-pipe] - descr: OCaml bindings for named pipes, which are used on Windows for local (and remote) IPC. -- org: mirage - repo: parse-argv - type: driver - opam: [parse-argv] - descr: Common code for parsing argv strings that is used by the various bootvar libraries to pass configuration information to a unikernel. -- org: mirage - repo: mirage-profile - type: logging - opam: [mirage-profile] - descr: library to trace execution of OCaml/Lwt programs at the level of Lwt threads, and associated viewers to process the trace results. -- org: mirage - repo: ocaml-xenstore - type: driver/xen - opam: [xenstore] - descr: implementation of the Xenstore communication protocol, including client and server libraries. -- org: mirage - repo: ocaml-base64 - type: parsing - opam: [base64] - descr: Base64 is a group of similar binary-to-text encoding schemes that represent binary data in an ASCII string format by translating it into a radix-64 representation. -- org: mirage - repo: ocaml-asl - type: logging - opam: [asl] - descr: library to log via the Apple System Log on macosx. -- org: mirage - repo: mirage-tc - type: core - opam: [mirage-tc] - descr: a set of functors and combinators to convert to and from and JSON values and Cstruct buffers. -- org: mirage - repo: ocaml-mstruct - type: parsing - opam: [mstruct] - descr: a mutability layer for Cstruct buffers. -- org: mirage - repo: ocaml-hex - type: parsing - opam: [hex] - descr: library providing hexadecimal converters for OCaml values. -- org: mirage - repo: ezjsonm - type: web - opam: [ezjsonm] - descr: a simple but slower parsing library for JSON values, based on jsonm. -- org: mirage - repo: ocaml-rpc - type: network - opam: [rpc] - descr: library and syntax extension to generate functions to convert values of a given type to and from theirs RPC representations. -- org: mirage - repo: ocaml-vmnet - type: driver/osx - opam: [vmnet] - descr: MacOS X bridged networking via the vmnet.framework. -- org: mirage - repo: ocaml-launchd - type: driver/osx - opam: [launchd] - descr: make services that are automatically started by the macosx launchd service. -- org: mirage - repo: ocaml-mbr - type: storage - opam: [mbr] - descr: library for manipulating Master Boot Records, to create bootable disk images and for Mirage kernels to read the partition tables on attached disks. -- org: mirage - repo: ocaml-magic-mime - type: web - opam: [magic-mime] - descr: a database of MIME types that maps filename extensions into MIME types suitable for use in many Internet protocols such as HTTP or e-mail. -- org: samoht - repo: depyt - type: core - opam: [depyt] - descr: type combinators to define runtime representation for OCaml types and generic operations to manipulate values with a runtime type representation. -- org: samoht - repo: irmin-watcher - type: vcs - opam: [irmin-watcher] - descr: Portable filesystem watch backends using FSevents or Inotify -- org: mirage - repo: mirage-qubes - type: driver - opam: [mirage-qubes] - descr: implementations of various [QubesOS](https://www.qubes-os.org) protocols. -- org: mirleft - repo: ocaml-tls - type: security - opam: [tls] - descr: a pure OCaml implementation of Transport Layer Security. -- org: mirleft - repo: ocaml-nocrypto - type: security - opam: [nocrypto] - descr: a small cryptographic library that puts emphasis on the applicative style and ease of use. It includes basic ciphers (AES, 3DES, RC4), hashes (MD5, SHA1, SHA2), public-key primitives (RSA, DSA, DH) and a strong RNG (Fortuna). -- org: mirleft - repo: ocaml-x509 - type: security - opam: [x509] - descr: X.509 is a public key infrastructure used mostly on the Internet, and this library implements most parts of RFC5280 and RFC6125. -- org: mirleft - repo: ocaml-asn1-combinators - type: security - opam: [asn1-combinators] - descr: a library for expressing ASN.1 in OCaml by embedding the abstract syntax directly in the language. - +(* + - org: mirage + repo: ocaml-hvsock + type: driver/win + opam: [hvsock] + descr: These bindings allow Host to VM communication on Hyper-V systems on both Linux and Windows. + - org: mirage + repo: mirage-skeleton + type: example + descr: Examples of different types of Mirage applications. + - org: mirage + repo: ocaml-tuntap + type: driver/unix + opam: [tuntap] + descr: Bindings to the [tuntap](https://en.wikipedia.org/wiki/TUN/TAP) virtual network kernel devices, for userspace networking on Linux and macos. + - org: mirage + repo: ocaml-cstruct + type: parsing + opam: [cstruct] + descr: Map OCaml arrays onto C-like structs, suitable for parsing wire protocols. + - org: mirage + repo: shared-block-ring + type: storage + opam: [shared-block-ring] + descr: A simple persistent on-disk fixed length queue. + - org: mirage + repo: prometheus + type: logging + opam: [prometheus,prometheus-app] + descr: Report metrics to a Prometheus server. + - org: mirage + repo: ocaml-uri + type: web + opam: [uri] + descr: RFC3986 URI parsing library + - org: mirage + repo: irmin + type: vcs + opam: [irmin,irmin-unix,mirage-irmin] + descr: a library for persistent stores with built-in snapshot, branching and reverting mechanisms. + - org: mirage + repo: ocaml-qcow + type: storage + opam: [qcow] + descr: pure OCaml code for parsing, printing, modifying `.qcow` format data + - org: mirage + repo: ocaml-dns + type: network + opam: [dns,mirage-dns] + descr: a pure OCaml implementation of the DNS protocol, intended to be a reasonably high-performance implementation. + - org: mirage + repo: ocaml-conduit + type: network + opam: [conduit,mirage-conduit] + descr: a library to establish and listen for TCP and SSL/TLS connections. + - org: mirage + repo: ocaml-tar + type: storage + opam: [tar] + descr: read and write tar files, with an emphasis on streaming. + - org: mirage + repo: ocaml-pcap + type: network + opam: [pcap-format] + descr: an interface to encode and decode pcap files, dealing with both endianess, including endianess detection. + - org: mirage + repo: mirage-tcpip + type: network + opam: [tcpip] + descr: a pure OCaml implementation of the TCP/IP protocol suite. + - org: mirage + repo: charrua-core + type: network + opam: [charrua-core] + descr: a DHCPv4 server and wire frame encoder and decoder. + - org: mirage + repo: alcotest + type: testing + opam: [alcotest] + descr: a lightweight and colourful test framework that exposes simple interface to perform unit tests. + - org: mirage + repo: ocaml-ipaddr + type: network + opam: [ipaddr] + descr: a library for manipulation of IP (and MAC) address representations. + - org: mirage + repo: mirage-block-ramdisk + type: storage + opam: [mirage-block-ramdisk] + descr: a simple in-memory block device. + - org: mirage + repo: mirage-block + type: core + opam: [mirage-block,mirage-block-lwt] + descr: generic operations over Mirage block devices. + - org: mirage + repo: mirage-block-unix + type: driver/unix + opam: [mirage-block-unix] + descr: Unix implementation of the Mirage block interface. + - org: mirage + repo: mirage-block-xen + type: driver/xen + opam: [mirage-block-xen] + descr: Client and server implementations of the Xen paravirtualised block driver protocol + - org: mirage + repo: mirage-net-xen + type: driver/xen + opam: [mirage-net-xen] + descr: Client and server implementations of the Xen paravirtualised network driver protocol + - org: mirage + repo: ocaml-vchan + type: driver/xen + opam: [vchan] + descr: implementation of the "vchan" shared-memory communication protocol. + - org: mirage + repo: mirage-platform + type: driver + opam: [mirage-unix,mirage-xen-ocaml,mirage-xen] + descr: Platform libraries for Mirage for Unix and Xen that handle timers, device setup and the main loop, as well as the runtime for the Xen unikernel. + - org: mirage + repo: mirage-protocols + type: core + opam: [mirage-protocols,mirage-protocols-lwt] + descr: a set of module types that libraries intended to be used as Mirage network implementations should implement. + - org: mirage + repo: ocaml-cohttp + type: web + opam: [cohttp] + descr: a library for creating HTTP daemons, with a portable HTTP parser and implementations using various asynchronous programming libraries. + - org: mirage + repo: ocaml-crunch + type: storage + opam: [crunch] + descr: take a directory of files and compile them into a standalone OCaml module that serves the contents directly from memory. + - org: mirage + repo: ocaml-fat + type: storage + opam: [fat-filesystem] + descr: implementation of the FAT filesystem to allow the easy preparation of bootable disk images containing kernels, and to provide a simple filesystem layer for Mirage applications. + - org: mirage + repo: mirage-http + type: web + opam: [mirage-http] + descr: a Cohttp-based webserver implementation of the Mirage HTTP interfaces. + - org: mirage + repo: mirage-fs-unix + type: driver/unix + opam: [mirage-fs-unix] + descr: a pass-through Mirage filesystem to an underlying Unix directory. + - org: mirage + repo: mirage-bootvar-xen + type: driver/xen + opam: [mirage-bootvar-xen] + descr: library for reading Mirage unikernel boot parameters from Xen. + - org: mirage + repo: mirage-net-unix + type: driver/unix + opam: [mirage-net-unix] + descr: Unix implementation of the Mirage NETWORK interface that exposes Ethernet frames via tuntap. + - org: mirage + repo: mirage-net-macosx + type: driver/osx + opam: [mirage-net-macosx] + descr: MacOSX implementation of the Mirage NETWORK interface that exposes raw Ethernet frames using the Vmnet framework available in MacOS X Yosemite onwards. + - org: mirage + repo: mirage-entropy + type: core + opam: [mirage-entropy] + descr: Reliable entropy sources for Mirage unikernels. + - org: mirage + repo: mirage-time + type: core + opam: [mirage-time,mirage-time-lwt] + descr: Module types for time-related operations in Mirage. + - org: mirage + repo: mirage-random + type: core + opam: [mirage-random] + descr: Randomness signatures for Mirage, and an implementation using the OCaml stdlib. + - org: mirage + repo: mirage-net + type: core + opam: [mirage-net,mirage-net-lwt] + descr: Network (Ethernet) signatures for Mirage. + - org: mirage + repo: mirage-logs + type: core + opam: [mirage-logs] + descr: a reporter for the [Logs](http://erratique.ch/software/logs) library that writes log messages to stderr, using a Mirage `CLOCK` to add timestamps. + - org: mirage + repo: mirage-kv + type: core + opam: [mirage-kv,mirage-kv-lwt] + descr: provides key/value store signatures that Mirage storage libraries can implement. + - org: mirage + repo: mirage-fs + type: core + opam: [mirage-fs,mirage-fs-lwt] + descr: provides filesystem module signatures that Mirage storage libraries can implement. + - org: mirage + repo: mirage-flow + type: core + opam: [mirage-flow,mirage-flow-lwt] + descr: Network flow implementations and combinators to manipulate and compose them. + - org: mirage + repo: mirage-console + type: core + opam: [mirage-console-lwt,mirage-console,mirage-console-unix,mirage-console-xen-backend,mirage-console-xen-cli,mirage-console-xen-proto,mirage-console-xen] + descr: Pure OCaml module types and implementations of Mirage consoles, for Unix and Xen. + - org: mirage + repo: mirage-clock + type: core + opam: [mirage-clock,mirage-clock-freestanding,mirage-clock-lwt,mirage-clock-unix] + descr: portable support for an operating system timesources. + - org: mirage + repo: mirage-channel + type: core + opam: [mirage-channel,mirage-channel-lwt] + descr: Channels are buffered reader/writers built on top of an unbuffered mirage-flow implementation. + - org: mirage + repo: mirage-stack + type: core + opam: [mirage-stack,mirage-stack-lwt] + descr: provides a set of module types which libraries intended to be used as Mirage network stacks should implement. + - org: mirage + repo: mirage-device + type: core + opam: [mirage-device] + descr: the signature for basic abstract devices for Mirage and a pretty-printing function for device errors + - org: mirage + repo: ocaml-vhd + type: storage + opam: [vhd-format] + descr: a pure OCaml library to read and write vhd format data, plus a simple command-line tool which allows vhd files to be interrogated, manipulated, format-converted and streamed to and from files and remote servers. + - org: mirage + repo: ocaml-freestanding + type: driver + opam: [ocaml-freestanding] + descr: a freestanding OCaml runtime suitable for linking with a unikernel base layer such as Solo5. + - org: mirage + repo: mirage-solo5 + type: driver/solo5 + opam: [mirage-solo5] + descr: the Mirage `OS` library for Solo5 targets, which handles the main loop and timers. + - org: mirage + repo: mirage-block-solo5 + type: driver/solo5 + opam: [mirage-block-solo5] + descr: Solo5 implementation of the Mirage block interface. + - org: mirage + repo: mirage-net-solo5 + type: driver/solo5 + opam: [mirage-net-solo5] + descr: Solo5 implementation of the Mirage network interface. + - org: mirage + repo: mirage-bootvar-solo5 + type: driver/solo5 + opam: [mirage-bootvar-solo5] + descr: library for passing boot-time variables to Solo5 targets. + - org: mirage + repo: mirage-console-solo5 + type: driver/solo5 + opam: [mirage-console-solo5] + descr: implementation of the Mirage Console interface for Solo5 targets. + - org: mirage + repo: ocaml-github + type: vcs + opam: [github] + descr: an OCaml interface to the GitHub APIv3 (JSON) that is compatible with Mirage and also compiles to pure JavaScript. + - org: mirage + repo: ocaml-git + type: vcs + opam: [git,git-mirage,git-unix] + descr: Git format and protocol in pure OCaml, with support for on-disk and in-memory Git stores. + - org: mirage + repo: ocaml-9p + type: storage + opam: [9p-format] + descr: an implementation of the 9P protocol from outer space. + - org: mirage + repo: shared-memory-ring + type: driver/xen + opam: [shared-memory-ring] + descr: a set of libraries for creating shared memory producer/consumer rings that follow the Xen hypervisor ABI for virtual devices. + - org: mirage + repo: io-page + type: driver + opam: [io-page] + descr: support for efficient handling of I/O memory pages on Unix and Xen. + - org: mirage + repo: ocaml-evtchn + type: driver/xen + opam: [evtchn] + descr: Xen event channel interface for Mirage. Event channels are the Xen equivalent of interrupts, used to signal when data is available for processing. + - org: mirage + repo: ocaml-gnt + type: driver/xen + opam: [gnt] + descr: Xen grant table bindings for OCaml that are used to create Xen device driver "backends" (servers) and "frontends" (clients). + - org: mirage + repo: cowabloga + type: web + opam: [cowabloga] + descr: a deprecated library to setup a simple blog and wiki using the Zurb Foundation CSS/HTML templates. + - org: mirage + repo: ocaml-cow + type: web + opam: [cow] + descr: OCaml combinators for HTML, XML, JSON and Markdown format handling. + - org: mirage + repo: mirage-xen-minios + type: driver/xen + opam: [mirage-xen-minios] + descr: installs the C libraries for the Xen MiniOS and OpenLibM. + - org: mirage + repo: ocaml-named-pipe + type: driver/win + opam: [named-pipe] + descr: OCaml bindings for named pipes, which are used on Windows for local (and remote) IPC. + - org: mirage + repo: parse-argv + type: driver + opam: [parse-argv] + descr: Common code for parsing argv strings that is used by the various bootvar libraries to pass configuration information to a unikernel. + - org: mirage + repo: mirage-profile + type: logging + opam: [mirage-profile] + descr: library to trace execution of OCaml/Lwt programs at the level of Lwt threads, and associated viewers to process the trace results. + - org: mirage + repo: ocaml-xenstore + type: driver/xen + opam: [xenstore] + descr: implementation of the Xenstore communication protocol, including client and server libraries. + - org: mirage + repo: ocaml-base64 + type: parsing + opam: [base64] + descr: Base64 is a group of similar binary-to-text encoding schemes that represent binary data in an ASCII string format by translating it into a radix-64 representation. + - org: mirage + repo: ocaml-asl + type: logging + opam: [asl] + descr: library to log via the Apple System Log on macosx. + - org: mirage + repo: mirage-tc + type: core + opam: [mirage-tc] + descr: a set of functors and combinators to convert to and from and JSON values and Cstruct buffers. + - org: mirage + repo: ocaml-mstruct + type: parsing + opam: [mstruct] + descr: a mutability layer for Cstruct buffers. + - org: mirage + repo: ocaml-hex + type: parsing + opam: [hex] + descr: library providing hexadecimal converters for OCaml values. + - org: mirage + repo: ezjsonm + type: web + opam: [ezjsonm] + descr: a simple but slower parsing library for JSON values, based on jsonm. + - org: mirage + repo: ocaml-rpc + type: network + opam: [rpc] + descr: library and syntax extension to generate functions to convert values of a given type to and from theirs RPC representations. + - org: mirage + repo: ocaml-vmnet + type: driver/osx + opam: [vmnet] + descr: MacOS X bridged networking via the vmnet.framework. + - org: mirage + repo: ocaml-launchd + type: driver/osx + opam: [launchd] + descr: make services that are automatically started by the macosx launchd service. + - org: mirage + repo: ocaml-mbr + type: storage + opam: [mbr] + descr: library for manipulating Master Boot Records, to create bootable disk images and for Mirage kernels to read the partition tables on attached disks. + - org: mirage + repo: ocaml-magic-mime + type: web + opam: [magic-mime] + descr: a database of MIME types that maps filename extensions into MIME types suitable for use in many Internet protocols such as HTTP or e-mail. + - org: samoht + repo: depyt + type: core + opam: [depyt] + descr: type combinators to define runtime representation for OCaml types and generic operations to manipulate values with a runtime type representation. + - org: samoht + repo: irmin-watcher + type: vcs + opam: [irmin-watcher] + descr: Portable filesystem watch backends using FSevents or Inotify + - org: mirage + repo: mirage-qubes + type: driver + opam: [mirage-qubes] + descr: implementations of various [QubesOS](https://www.qubes-os.org) protocols. + - org: mirleft + repo: ocaml-tls + type: security + opam: [tls] + descr: a pure OCaml implementation of Transport Layer Security. + - org: mirleft + repo: ocaml-nocrypto + type: security + opam: [nocrypto] + descr: a small cryptographic library that puts emphasis on the applicative style and ease of use. It includes basic ciphers (AES, 3DES, RC4), hashes (MD5, SHA1, SHA2), public-key primitives (RSA, DSA, DH) and a strong RNG (Fortuna). + - org: mirleft + repo: ocaml-x509 + type: security + opam: [x509] + descr: X.509 is a public key infrastructure used mostly on the Internet, and this library implements most parts of RFC5280 and RFC6125. + - org: mirleft + repo: ocaml-asn1-combinators + type: security + opam: [asn1-combinators] + descr: a library for expressing ASN.1 in OCaml by embedding the abstract syntax directly in the language. *) diff --git a/src/logging.ml b/src/logging.ml index 3297656..e37a318 100644 --- a/src/logging.ml +++ b/src/logging.ml @@ -9,7 +9,8 @@ let reporter = Fmt.kpf k Fmt.stdout ("%a %a @[" ^^ fmt ^^ "@]@.") Fmt.(styled `Magenta string) - (Printf.sprintf "%14s" src) Logs_fmt.pp_header (level, header) + (Printf.sprintf "%14s" src) + Logs_fmt.pp_header (level, header) in { Logs.report } diff --git a/src/mirage_ci.ml b/src/mirage_ci.ml index d7415e5..3dd646e 100644 --- a/src/mirage_ci.ml +++ b/src/mirage_ci.ml @@ -3,43 +3,53 @@ module Github = Current_github module Git = Current_git let () = Logging.init () - let daily = Current_cache.Schedule.v ~valid_for:(Duration.of_day 1) () (* Access control policy. *) let has_role user role = match user with - | None -> role = `Viewer || role = `Monitor (* Unauthenticated users can only look at things. *) + | None -> + role = `Viewer || role = `Monitor + (* Unauthenticated users can only look at things. *) | Some user -> ( match (Current_web.User.id user, role) with | "github:TheLortex", _ -> true (* These users have all roles *) - | _ -> role = `Viewer ) + | _ -> role = `Viewer) let program_name = "mirage-ci" - let gh_mirage_dev = { Github.Repo_id.owner = "mirage"; name = "mirage-dev" } let gh_head_of github name ref = match github with | None -> Github.Api.Anonymous.head_of name ref - | Some github -> Github.Api.head_of github name ref |> Current.map Current_github.Api.Commit.id + | Some github -> + Github.Api.head_of github name ref + |> Current.map Current_github.Api.Commit.id -let main config github mode auth store (`Ocluster_cap cap) (`Test_monorepos monorepos) - (`Pipelines_options mirage_pipelines_options) = +let main config github mode auth store (`Ocluster_cap cap) + (`Test_monorepos monorepos) (`Pipelines_options mirage_pipelines_options) = let vat = Capnp_rpc_unix.client_only_vat () in let submission_cap = Capnp_rpc_unix.Vat.import_exn vat cap in - let connection = Current_ocluster.Connection.create ~max_pipeline:20 submission_cap in + let connection = + Current_ocluster.Connection.create ~max_pipeline:20 submission_cap + in let ocluster = - Current_ocluster.v ~secrets:(Git_store.Cluster.secrets store) ~urgent:`Never connection + Current_ocluster.v + ~secrets:(Git_store.Cluster.secrets store) + ~urgent:`Never connection in - let repo_mirage_dev = gh_head_of github gh_mirage_dev (`Ref "refs/heads/master") in + let repo_mirage_dev = + gh_head_of github gh_mirage_dev (`Ref "refs/heads/master") + in let repo_mirage_dev = Git.fetch repo_mirage_dev in let repo_opam = - Current_git.clone ~schedule:daily "https://github.com/ocaml/opam-repository.git" + Current_git.clone ~schedule:daily + "https://github.com/ocaml/opam-repository.git" in let repo_overlays = - Current_git.clone ~schedule:daily "https://github.com/mirage/opam-overlays.git" + Current_git.clone ~schedule:daily + "https://github.com/mirage/opam-overlays.git" in let monorepos = if monorepos then @@ -60,21 +70,22 @@ let main config github mode auth store (`Ocluster_cap cap) (`Test_monorepos mono in let monorepo = Monorepo.v ~system:platform.system ~repos in let monorepo_lock = - Mirage_ci_pipelines.Monorepo.lock ~ocluster ~store ~system:platform.system ~value:"universe" - ~monorepo ~repos:repos_unfetched roots + Mirage_ci_pipelines.Monorepo.lock ~ocluster ~store + ~system:platform.system ~value:"universe" ~monorepo + ~repos:repos_unfetched roots in Current.with_context repos @@ fun () -> let mirage_released = - Mirage_ci_pipelines.Monorepo.released ~platform ~roots ~repos:repos_unfetched - ~lock:monorepo_lock + Mirage_ci_pipelines.Monorepo.released ~platform ~roots + ~repos:repos_unfetched ~lock:monorepo_lock in let mirage_edge = - Mirage_ci_pipelines.Monorepo.mirage_edge ~platform ~git_store:store ~roots - ~repos:repos_unfetched ~lock:monorepo_lock + Mirage_ci_pipelines.Monorepo.mirage_edge ~platform ~git_store:store + ~roots ~repos:repos_unfetched ~lock:monorepo_lock in let universe_edge = - Mirage_ci_pipelines.Monorepo.universe_edge ~platform ~git_store:store ~roots - ~repos:repos_unfetched ~lock:monorepo_lock + Mirage_ci_pipelines.Monorepo.universe_edge ~platform ~git_store:store + ~roots ~repos:repos_unfetched ~lock:monorepo_lock in Current.all_labelled [ @@ -87,7 +98,10 @@ let main config github mode auth store (`Ocluster_cap cap) (`Test_monorepos mono let prs = match github with | None when Mirage_ci_pipelines.PR.is_enabled mirage_pipelines_options -> - Logs.err (fun f -> f "No github API key was provided using the github-token-file option !"); + Logs.err (fun f -> + f + "No github API key was provided using the github-token-file \ + option !"); None | None -> None | Some github -> @@ -99,7 +113,8 @@ let main config github mode auth store (`Ocluster_cap cap) (`Test_monorepos mono |> Current.list_seq in Some - (Mirage_ci_pipelines.PR.make ~ocluster ~options:mirage_pipelines_options github + (Mirage_ci_pipelines.PR.make ~ocluster + ~options:mirage_pipelines_options github (Repository.current_list_unfetch repos_mirage_main)) in let main_ci, main_routes = @@ -142,14 +157,19 @@ let named f = Cmdliner.Term.(app (const f)) let ocluster_cap = Arg.required @@ Arg.opt Arg.(some Capnp_rpc_unix.sturdy_uri) None - @@ Arg.info ~doc:"The ocluster submission capability file" ~docv:"FILE" [ "ocluster-cap" ] + @@ Arg.info ~doc:"The ocluster submission capability file" ~docv:"FILE" + [ "ocluster-cap" ] |> named (fun x -> `Ocluster_cap x) let test_monorepos = - Arg.value @@ Arg.flag @@ Arg.info ~doc:"Test mirage universe monorepos" [ "test-monorepos" ] + Arg.value + @@ Arg.flag + @@ Arg.info ~doc:"Test mirage universe monorepos" [ "test-monorepos" ] |> named (fun x -> `Test_monorepos x) -let main_ci = Mirage_ci_pipelines.PR.test_options_cmdliner |> named (fun x -> `Pipelines_options x) +let main_ci = + Mirage_ci_pipelines.PR.test_options_cmdliner + |> named (fun x -> `Pipelines_options x) let github_config = let read_file path = @@ -162,14 +182,24 @@ let github_config = in Arg.value @@ Arg.opt Arg.(some file) None - @@ Arg.info ~doc:"A file containing the GitHub OAuth token." ~docv:"PATH" [ "github-token-file" ] - |> named (Option.map (fun x -> Current_github.Api.of_oauth @@ String.trim (read_file x))) + @@ Arg.info ~doc:"A file containing the GitHub OAuth token." ~docv:"PATH" + [ "github-token-file" ] + |> named + (Option.map (fun x -> + Current_github.Api.of_oauth @@ String.trim (read_file x))) let cmd = let doc = "an OCurrent pipeline" in ( Term.( - const main $ Current.Config.cmdliner $ github_config $ Current_web.cmdliner - $ Current_github.Auth.cmdliner $ Git_store.cmdliner $ ocluster_cap $ test_monorepos $ main_ci), + const main + $ Current.Config.cmdliner + $ github_config + $ Current_web.cmdliner + $ Current_github.Auth.cmdliner + $ Git_store.cmdliner + $ ocluster_cap + $ test_monorepos + $ main_ci), Term.info program_name ~doc ) let () = Term.(exit @@ eval cmd) diff --git a/src/pipelines/PR.ml b/src/pipelines/PR.ml index 2ca6900..2c52917 100644 --- a/src/pipelines/PR.ml +++ b/src/pipelines/PR.ml @@ -2,9 +2,7 @@ module Github = Current_github module Git = Current_git type pr_info = { id : string; label : string; pipeline : unit Current.t } - type spec = { name : string; content : pr_info list ref } - type t = { specs : spec list; pipeline : unit Current.t } type gh_repo = { @@ -17,15 +15,21 @@ type gh_repo = { let repo_refs ~github repo = let refs = Github.Api.refs github repo in - Current.primitive ~info:(Current.component "repository refs") (fun () -> refs) (Current.return ()) + Current.primitive + ~info:(Current.component "repository refs") + (fun () -> refs) + (Current.return ()) let pull_request_regex = - Str.regexp "https://github.com/\\([A-Za-z0-9\\-]+\\)/\\([A-Za-z0-9\\-]+\\)/pull/\\([0-9]+\\)" + Str.regexp + "https://github.com/\\([A-Za-z0-9\\-]+\\)/\\([A-Za-z0-9\\-]+\\)/pull/\\([0-9]+\\)" let find_friend_prs html = let open Soup in let html = parse html in - html $$ "a" |> to_list + html + $$ "a" + |> to_list |> List.filter_map (fun link -> let content = attribute "href" link |> Option.value ~default:"" in if Str.string_match pull_request_regex content 0 then @@ -54,9 +58,12 @@ let github_setup ~branch ~github owner name = let map = Github.Api.all_refs refs in List.filter_map (fun commit -> - Api.Ref_map.filter (fun _ commit' -> Api.Commit.(hash commit' = hash commit)) map + Api.Ref_map.filter + (fun _ commit' -> Api.Commit.(hash commit' = hash commit)) + map |> Api.Ref_map.bindings - |> List.find_map (fun (ref, _) -> if ref_filter ref then Some (ref, commit) else None)) + |> List.find_map (fun (ref, _) -> + if ref_filter ref then Some (ref, commit) else None)) ci_refs in let all = @@ -66,7 +73,8 @@ let github_setup ~branch ~github owner name = let branch = Github.Api.head_of github gh (`Ref ("refs/heads/" ^ branch)) in { owner; name; ci; branch; all } -let url kind id = Uri.of_string (Fmt.str "https://ci.mirage.io/github/%s/prs/%s" kind id) +let url kind id = + Uri.of_string (Fmt.str "https://ci.mirage.io/github/%s/prs/%s" kind id) let github_status_of_state kind id status = let url = url kind id in @@ -75,8 +83,8 @@ let github_status_of_state kind id status = | Error (`Active _) -> Github.Api.Status.v ~url `Pending | Error (`Msg m) -> Github.Api.Status.v ~url `Failure ~description:m -let perform_test ?mirage_dev ~ocluster ~commit_status ~platform ~mirage_skeleton ~mirage ~repos kind - gh_commit = +let perform_test ?mirage_dev ~ocluster ~commit_status ~platform ~mirage_skeleton + ~mirage ~repos kind gh_commit = let open Current.Syntax in let repos = match mirage_dev with @@ -91,18 +99,23 @@ let perform_test ?mirage_dev ~ocluster ~commit_status ~platform ~mirage_skeleton (Github.Api.Commit.id gh_commit' |> Git.Commit_id.hash) (Mirage_ci_lib.Platform.platform_id platform) in - let pipeline = Skeleton.v_main ~ocluster ~platform ~mirage ~repos mirage_skeleton in + let pipeline = + Skeleton.v_main ~ocluster ~platform ~mirage ~repos mirage_skeleton + in let result = - Current.return { pipeline; label = Fmt.str "%a" Github.Api.Commit.pp gh_commit'; id } + Current.return + { pipeline; label = Fmt.str "%a" Github.Api.Commit.pp gh_commit'; id } in let+ _ = match commit_status with | false -> pipeline | true -> - pipeline |> Current.state ~hidden:true + pipeline + |> Current.state ~hidden:true |> Current.map (github_status_of_state kind id) |> Github.Api.Commit.set_status gh_commit - (Fmt.str "Mirage CI - %a" Mirage_ci_lib.Platform.pp_platform platform) + (Fmt.str "Mirage CI - %a" Mirage_ci_lib.Platform.pp_platform + platform) and+ result = result in result @@ -115,16 +128,16 @@ module CommitUrl = struct type t = (Github.Api.Commit.t * Github.Api.Ref.t) * (string * string) let pp f (_, (text, _)) = Fmt.pf f "%s" text - let url f (_, (_, url)) = Fmt.pf f "%s" url - let compare ((a, _), _) ((b, _), _) = Github.Api.Commit.compare a b end let pp_url ~(repo : Github.Repo_id.t) f (ref : Github.Api.Ref.t) = match ref with - | `Ref ref -> Fmt.pf f "https://github.com/%s/%s/tree/%s" repo.owner repo.name ref - | `PR { id; _ } -> Fmt.pf f "https://github.com/%s/%s/pull/%d" repo.owner repo.name id + | `Ref ref -> + Fmt.pf f "https://github.com/%s/%s/tree/%s" repo.owner repo.name ref + | `PR { id; _ } -> + Fmt.pf f "https://github.com/%s/%s/pull/%d" repo.owner repo.name id let url_of_commit (commit : Github.Api.Commit.t) (ref : Github.Api.Ref.t) = let open Github in @@ -153,14 +166,19 @@ let resolve friends repo = Printf.printf "%s %s > %d!!\n" owner name id; Some value | _ -> None) - refs ) + refs) else None) friends with | Some ref -> ref |> Github.Api.Commit.id | None -> branch |> Github.Api.Commit.id -type test = { name : string; kind : kind; input : gh_repo; commit_status : bool } +type test = { + name : string; + kind : kind; + input : gh_repo; + commit_status : bool; +} let perform_ci ~ocluster ~name ~commit_status ~repos ~kind ci_refs = let perform_test ~ref = @@ -171,24 +189,28 @@ let perform_ci ~ocluster ~name ~commit_status ~repos ~kind ci_refs = let mirage_skeleton = resolve friends mirage_skeleton in fun ~platform commit_mirage -> let mirage = id_of commit_mirage in - perform_test ~platform ?mirage_dev ~mirage_skeleton ~mirage ~repos name commit_mirage + perform_test ~platform ?mirage_dev ~mirage_skeleton ~mirage ~repos + name commit_mirage | Mirage_dev { mirage; mirage_skeleton } -> let mirage = resolve friends mirage in let mirage_skeleton = resolve friends mirage_skeleton in fun ~platform commit_mirage_dev -> let mirage_dev = id_of commit_mirage_dev in - perform_test ~platform ~mirage_dev ~mirage_skeleton ~mirage ~repos name commit_mirage_dev + perform_test ~platform ~mirage_dev ~mirage_skeleton ~mirage ~repos + name commit_mirage_dev | Mirage_skeleton { mirage_dev; mirage } -> let mirage_dev = Option.map (resolve friends) mirage_dev in let mirage = resolve friends mirage in fun ~platform commit_mirage_skeleton -> let mirage_skeleton = id_of commit_mirage_skeleton in - perform_test ~platform ?mirage_dev ~mirage_skeleton ~mirage ~repos name - commit_mirage_skeleton + perform_test ~platform ?mirage_dev ~mirage_skeleton ~mirage ~repos + name commit_mirage_skeleton in ci_refs |> Current.map (fun commits -> - List.map (fun (ref, commit) -> ((commit, ref), url_of_commit commit ref)) commits) + List.map + (fun (ref, commit) -> ((commit, ref), url_of_commit commit ref)) + commits) |> Current.list_map_url (module CommitUrl) (fun commit -> @@ -198,7 +220,8 @@ let perform_ci ~ocluster ~name ~commit_status ~repos ~kind ci_refs = |> List.map (fun platform -> perform_test ~ocluster ~commit_status ~ref ~platform commit |> Current.collapse - ~key:(Fmt.str "%a" Mirage_ci_lib.Platform.pp_platform platform) + ~key: + (Fmt.str "%a" Mirage_ci_lib.Platform.pp_platform platform) ~value:"mirage-skeleton" ~input:commit) |> Current.list_seq) @@ -216,16 +239,25 @@ let test_options_cmdliner = let conv_commit_status = Arg.( opt ~vopt:(Some []) - (some (list (enum [ ("mirage", `Mirage); ("skeleton", `Skeleton); ("dev", `Dev) ]))) + (some + (list + (enum + [ ("mirage", `Mirage); ("skeleton", `Skeleton); ("dev", `Dev) ]))) None) in - let mirage_4 = Arg.value (conv_commit_status (Arg.info [ "test-mirage-4" ])) in - let mirage_3 = Arg.value (conv_commit_status (Arg.info [ "test-mirage-3" ])) in + let mirage_4 = + Arg.value (conv_commit_status (Arg.info [ "test-mirage-4" ])) + in + let mirage_3 = + Arg.value (conv_commit_status (Arg.info [ "test-mirage-3" ])) + in let make mirage_3 mirage_4 = let make_commit_status list = List.fold_left - (fun acc -> function `Mirage -> { acc with mirage = true } - | `Skeleton -> { acc with skeleton = true } | `Dev -> { acc with dev = true }) + (fun acc -> function + | `Mirage -> { acc with mirage = true } + | `Skeleton -> { acc with skeleton = true } + | `Dev -> { acc with dev = true }) { mirage = false; skeleton = false; dev = false } list in @@ -242,7 +274,8 @@ type context = { repos : Mirage_ci_lib.Repository.t list Current.t; } -let pipeline ~mirage ~mirage_skeleton ~extra_repository { ocluster; enable_commit_status; repos } = +let pipeline ~mirage ~mirage_skeleton ~extra_repository + { ocluster; enable_commit_status; repos } = let tasks = [ { @@ -258,7 +291,7 @@ let pipeline ~mirage ~mirage_skeleton ~extra_repository { ocluster; enable_commi commit_status = enable_commit_status.skeleton; }; ] - @ ( extra_repository + @ (extra_repository |> Option.map (fun extra_repository -> [ { @@ -268,21 +301,26 @@ let pipeline ~mirage ~mirage_skeleton ~extra_repository { ocluster; enable_commi commit_status = enable_commit_status.dev; }; ]) - |> Option.value ~default:[] ) + |> Option.value ~default:[]) in let pipeline = tasks |> List.map (fun { name; kind; input; commit_status } -> let prs = ref [] in - (name, prs, perform_ci ~ocluster ~name ~commit_status ~repos ~kind input.ci |> update prs)) + ( name, + prs, + perform_ci ~ocluster ~name ~commit_status ~repos ~kind input.ci + |> update prs )) in let specs = List.map (fun (name, content, _) -> { name; content }) pipeline in - let pipeline = (List.map (fun (a, _, b) -> (a, b))) pipeline |> Current.all_labelled in + let pipeline = + (List.map (fun (a, _, b) -> (a, b))) pipeline |> Current.all_labelled + in (specs, pipeline) (* WE PERFORM TWO SETS OF TESTS -- mirage skeleton 'master' / mirage '3' / mirage-dev '3' -- mirage skeleton 'mirage-dev' / mirage 'main' / mirage-dev 'master' *) + - mirage skeleton 'master' / mirage '3' / mirage-dev '3' + - mirage skeleton 'mirage-dev' / mirage 'main' / mirage-dev 'master' *) let make ~ocluster ~options github repos = let specs_mirage_main, pipeline_mirage_main = match options.mirage_4 with @@ -291,9 +329,14 @@ let make ~ocluster ~options github repos = let gh_mirage_skeleton_dev = github_setup ~branch:"mirage-dev" ~github "mirage" "mirage-skeleton" in - let gh_mirage_master = github_setup ~branch:"main" ~github "mirage" "mirage" in - let gh_mirage_dev = github_setup ~branch:"master" ~github "mirage" "mirage-dev" in - pipeline ~mirage:gh_mirage_master ~mirage_skeleton:gh_mirage_skeleton_dev + let gh_mirage_master = + github_setup ~branch:"main" ~github "mirage" "mirage" + in + let gh_mirage_dev = + github_setup ~branch:"master" ~github "mirage" "mirage-dev" + in + pipeline ~mirage:gh_mirage_master + ~mirage_skeleton:gh_mirage_skeleton_dev ~extra_repository:(Some gh_mirage_dev) ctx | None -> ([], Current.return ~label:"mirage 4: not tested" ()) in @@ -305,7 +348,9 @@ let make ~ocluster ~options github repos = github_setup ~branch:"master" ~github "mirage" "mirage-skeleton" in let gh_mirage_3 = github_setup ~branch:"3" ~github "mirage" "mirage" in - let gh_mirage_dev_3 = github_setup ~branch:"3" ~github "mirage" "mirage-dev" in + let gh_mirage_dev_3 = + github_setup ~branch:"3" ~github "mirage" "mirage-dev" + in pipeline ~mirage:gh_mirage_3 ~mirage_skeleton:gh_mirage_skeleton_master ~extra_repository:(Some gh_mirage_dev_3) ctx @@ -314,7 +359,8 @@ let make ~ocluster ~options github repos = let specs = specs_mirage_main @ specs_mirage_3 in let pipeline = - Current.all_labelled [ ("mirage-4", pipeline_mirage_main); ("mirage-3", pipeline_mirage_3) ] + Current.all_labelled + [ ("mirage-4", pipeline_mirage_main); ("mirage-3", pipeline_mirage_3) ] in { pipeline; specs } @@ -326,7 +372,6 @@ open Tyxml.Html let r (pr : pr_info) = object inherit Current_web.Resource.t - val! can_get = `Viewer method! private get ctx = @@ -358,9 +403,11 @@ let r (pr : pr_info) = |}; ]; - div ~a:[ a_id "pipeline_container" ] + div + ~a:[ a_id "pipeline_container" ] [ - div ~a:[ a_id "pipeline" ] [ html ]; Unsafe.data ""; + div ~a:[ a_id "pipeline" ] [ html ]; + Unsafe.data ""; ]; script (Unsafe.data diff --git a/src/pipelines/PR.mli b/src/pipelines/PR.mli index 65f97dd..96c185b 100644 --- a/src/pipelines/PR.mli +++ b/src/pipelines/PR.mli @@ -8,7 +8,6 @@ type test_options (** Test options (enabling commit status, disabling tasks) *) val test_options_cmdliner : test_options Cmdliner.Term.t - val is_enabled : test_options -> bool val make : @@ -19,5 +18,4 @@ val make : t val to_current : t -> unit Current.t - val routes : t -> Current_web.Resource.t Routes.route list diff --git a/src/pipelines/monorepo.ml b/src/pipelines/monorepo.ml index 154fc80..cfe84c9 100644 --- a/src/pipelines/monorepo.ml +++ b/src/pipelines/monorepo.ml @@ -4,7 +4,6 @@ open Current.Syntax open Mirage_ci_lib type mode = UniverseEdge | MirageEdge | Released - type toolchain = Host | Freestanding let pp_toolchain () = function Host -> "" | Freestanding -> "-x freestanding" @@ -21,7 +20,9 @@ let get_monorepo_library ~mirage_only = else () in let pp_project f (project : Universe.Project.t) = - Fmt.pf f "@[%a @,@]" Fmt.(list ~sep:(const string " ") pp_libraries) project.opam + Fmt.pf f "@[%a @,@]" + Fmt.(list ~sep:(const string " ") pp_libraries) + project.opam in Fmt.str {| @@ -43,7 +44,8 @@ let spec ~mode ~repos ~system ~toolchain ~lock = let+ base = base in match toolchain with | Host -> base - | Freestanding -> Spec.add (Setup.install_tools [ "ocaml-freestanding" ]) base + | Freestanding -> + Spec.add (Setup.install_tools [ "ocaml-freestanding" ]) base in let spec = match mode with @@ -79,8 +81,8 @@ let spec ~mode ~repos ~system ~toolchain ~lock = ] spec -let v ~ocluster ~(platform : Platform.t) ~roots ~mode ?(src = Current.return []) ?(toolchain = Host) - ~repos ~lock () = +let v ~ocluster ~(platform : Platform.t) ~roots ~mode ?(src = Current.return []) + ?(toolchain = Host) ~repos ~lock () = let spec = spec ~system:platform.system ~mode ~repos ~toolchain ~lock in let mirage_only = match toolchain with Host -> false | _ -> true in let dune_build = @@ -91,24 +93,33 @@ let v ~ocluster ~(platform : Platform.t) ~roots ~mode ?(src = Current.return []) run "echo '%s' >> dune" (get_monorepo_library ~mirage_only roots); run "touch monorepo.opam; touch monorepo.ml"; (* Dune issue with strict_package_deps *) - run "find . -type f -name 'dune-project' -exec sed 's/(strict_package_deps)//g' -i {} \\;"; - run "opam exec -- dune build --profile release --debug-dependency-path %a" pp_toolchain - toolchain; + run + "find . -type f -name 'dune-project' -exec sed \ + 's/(strict_package_deps)//g' -i {} \\;"; + run + "opam exec -- dune build --profile release --debug-dependency-path %a" + pp_toolchain toolchain; run "du -sh _build/"; ] spec in - let name_of_toolchain = match toolchain with Host -> "host" | Freestanding -> "freestanding" in + let name_of_toolchain = + match toolchain with Host -> "host" | Freestanding -> "freestanding" + in let name_of_mode = match mode with | UniverseEdge -> "universe-edge" | MirageEdge -> "mirage-edge" | Released -> "released" in - let cache_hint = "mirage-ci-monorepo-" ^ Fmt.str "%a" Platform.pp_system platform.system in + let cache_hint = + "mirage-ci-monorepo-" ^ Fmt.str "%a" Platform.pp_system platform.system + in Config.build ~label:(name_of_toolchain ^ "-" ^ name_of_mode) - ~cache_hint ocluster ~pool:(Platform.ocluster_pool platform) ~src dune_build + ~cache_hint ocluster + ~pool:(Platform.ocluster_pool platform) + ~src dune_build let lock ~(system : Platform.system) ~value ~ocluster ~store ~monorepo ~repos (projects : Universe.Project.t list) = @@ -119,24 +130,28 @@ let lock ~(system : Platform.system) ~value ~ocluster ~store ~monorepo ~repos projects in let key = - Fmt.str "monorepo-%a-%s" Platform.pp_system system (Opamfile.digest configuration) + Fmt.str "monorepo-%a-%s" Platform.pp_system system + (Opamfile.digest configuration) in - Monorepo.lock ~key ~value ~cluster:ocluster ~store ~repos ~system ~opam:(Current.return configuration) + Monorepo.lock ~key ~value ~cluster:ocluster ~store ~repos ~system + ~opam:(Current.return configuration) monorepo) let universe_edge ~ocluster ~platform ~git_store ~roots ~repos ~lock = let src = let+ src = - Mirage_ci_lib.Monorepo_git_push.v git_store ~branch:"universe-edge-monorepo" + Mirage_ci_lib.Monorepo_git_push.v git_store + ~branch:"universe-edge-monorepo" (Monorepo_lock.commits lock) in [ src ] in [ ( "universe-edge-freestanding", - v ~ocluster ~platform ~src ~roots ~mode:UniverseEdge ~toolchain:Freestanding ~repos ~lock () - ); - ("universe-edge-host", v ~ocluster ~platform ~src ~roots ~mode:UniverseEdge ~repos ~lock ()); + v ~ocluster ~platform ~src ~roots ~mode:UniverseEdge + ~toolchain:Freestanding ~repos ~lock () ); + ( "universe-edge-host", + v ~ocluster ~platform ~src ~roots ~mode:UniverseEdge ~repos ~lock () ); ] |> Current.all_labelled @@ -156,16 +171,20 @@ let mirage_edge ~ocluster ~platform ~git_store ~roots ~repos ~lock = in [ ( "mirage-edge-freestanding", - v ~ocluster ~platform ~src ~roots ~mode:MirageEdge ~toolchain:Freestanding ~repos ~lock () ); - ("mirage-edge-host", v ~ocluster ~platform ~src ~roots ~mode:MirageEdge ~repos ~lock ()); + v ~ocluster ~platform ~src ~roots ~mode:MirageEdge ~toolchain:Freestanding + ~repos ~lock () ); + ( "mirage-edge-host", + v ~ocluster ~platform ~src ~roots ~mode:MirageEdge ~repos ~lock () ); ] |> Current.all_labelled let released ~ocluster ~platform ~roots ~repos ~lock = [ ( "released-freestanding", - v ~ocluster ~platform ~roots ~mode:Released ~toolchain:Freestanding ~repos ~lock () ); - ("released-host", v ~ocluster ~platform ~roots ~mode:Released ~repos ~lock ()); + v ~ocluster ~platform ~roots ~mode:Released ~toolchain:Freestanding ~repos + ~lock () ); + ( "released-host", + v ~ocluster ~platform ~roots ~mode:Released ~repos ~lock () ); ] |> Current.all_labelled @@ -179,13 +198,15 @@ let docs ~(system : Platform.system) ~repos ~lock = run "opam pin add odoc --dev -y"; run "rm duniverse/dune"; (* disable vendoring *) - run "find . -type f -name 'dune-project' -exec sed 's/(strict_package_deps)//g' -i {} \\;"; + run + "find . -type f -name 'dune-project' -exec sed \ + 's/(strict_package_deps)//g' -i {} \\;"; (* Dune issue with strict_package_deps *) run "opam exec -- dune upgrade"; (* Upgrade jbuild files *) run - "opam exec -- dune build @doc --profile release --debug-dependency-path || echo \"Build \ - failed. It's ok.\""; + "opam exec -- dune build @doc --profile release \ + --debug-dependency-path || echo \"Build failed. It's ok.\""; run "du -sh _build/"; ] spec @@ -195,7 +216,9 @@ let docs ~(system : Platform.system) ~repos ~lock = let open Obuilder_spec in let+ dune_build_doc = dune_build_doc in let docker = - Obuilder_spec.stage ~child_builds:[ ("monorepo", dune_build_doc) ] ~from:"alpine" + Obuilder_spec.stage + ~child_builds:[ ("monorepo", dune_build_doc) ] + ~from:"alpine" [ run "apk update && apk add lighttpd && rm -rf /var/cache/apk/*"; copy ~from:(`Build "monorepo") @@ -211,9 +234,13 @@ let docs ~(system : Platform.system) ~repos ~lock = let open Current.Syntax in Current.component "docker image build" |> let> dockerfile = web_ui_docker in - Current_docker.Raw.build ~dockerfile:(`Contents_str dockerfile) ~docker_context:None - ~pull:false `No_context + Current_docker.Raw.build ~dockerfile:(`Contents_str dockerfile) + ~docker_context:None ~pull:false `No_context in image_raw |> Current_docker.Raw.Image.hash |> Docker.Image.of_hash in - Current.all [ Docker.tag ~tag:"mirage-docs" image; Docker.service ~name:"mirage-docs" ~image () ] + Current.all + [ + Docker.tag ~tag:"mirage-docs" image; + Docker.service ~name:"mirage-docs" ~image (); + ] diff --git a/src/pipelines/monorepo.mli b/src/pipelines/monorepo.mli index 9c23c48..44ce9ca 100644 --- a/src/pipelines/monorepo.mli +++ b/src/pipelines/monorepo.mli @@ -1,5 +1,5 @@ -(* -## MONOREPO PIPELINES +(* + ## MONOREPO PIPELINES *) open Mirage_ci_lib @@ -12,8 +12,8 @@ val lock : repos:Repository.t list Current.t -> Universe.Project.t list -> Monorepo_lock.t Current.t -(** [lock ~system ~value ~monorepo ~repos projects] Obtain the lockfile of [projects] using the -[monorepo] tool with the repositories [repos]. *) +(** [lock ~system ~value ~monorepo ~repos projects] Obtain the lockfile of + [projects] using the [monorepo] tool with the repositories [repos]. *) val docs : system:Platform.system -> @@ -38,8 +38,8 @@ val mirage_edge : repos:Repository.t list Current.t -> lock:Monorepo_lock.t Current.t -> unit Current.t -(** Test the main branches of [roots] projects, and released versions for everything else in -the transitive dependency cone. *) +(** Test the main branches of [roots] projects, and released versions for + everything else in the transitive dependency cone. *) val universe_edge : ocluster:Current_ocluster.t -> diff --git a/src/pipelines/skeleton.ml b/src/pipelines/skeleton.ml index b245f3e..6dfe18b 100644 --- a/src/pipelines/skeleton.ml +++ b/src/pipelines/skeleton.ml @@ -50,7 +50,8 @@ type configuration_main = { skeleton : Current_git.Commit_id.t Current.t; } -let run_test_mirage_main ~ocluster { unikernel; platform; target } configuration = +let run_test_mirage_main ~ocluster { unikernel; platform; target } configuration + = let c = configuration in let base = let+ repos = c.repos in @@ -61,9 +62,13 @@ let run_test_mirage_main ~ocluster { unikernel; platform; target } configuration (* pre-install ocaml-freestanding *) Spec.add (Setup.install_tools [ "ocaml-freestanding" ]) base |> Spec.add - [ Obuilder_spec.run ~network:Setup.network "opam pin -n -y %s" (Setup.remote_uri mirage) ] + [ + Obuilder_spec.run ~network:Setup.network "opam pin -n -y %s" + (Setup.remote_uri mirage); + ] in - Mirage.build ~ocluster ~platform ~base ~project:c.skeleton ~unikernel ~target () + Mirage.build ~ocluster ~platform ~base ~project:c.skeleton ~unikernel ~target + () |> Current.collapse ~key:("Unikernel " ^ unikernel ^ "@" ^ target) ~value:("main-" ^ Platform.platform_id platform) @@ -77,7 +82,9 @@ let test_stage ~stage ~unikernels ~target ~platform ~run_test configuration = |> Option.map (List.mem target) |> Option.value ~default:true) |> List.map (fun name -> - run_test { unikernel = stage ^ "/" ^ name; target; platform } configuration) + run_test + { unikernel = stage ^ "/" ^ name; target; platform } + configuration) |> Current.all let multi_stage_test ~platform ~targets ~configure ~run_test mirage_skeleton = @@ -87,8 +94,10 @@ let multi_stage_test ~platform ~targets ~configure ~run_test mirage_skeleton = | (name, stage, unikernels) :: q -> let configuration = configure skeleton in let test_stage = - test_stage ~run_test ~stage ~unikernels ~target ~platform configuration - |> Current.collapse ~key:("Test stage " ^ name) ~value:target ~input:skeleton + test_stage ~run_test ~stage ~unikernels ~target ~platform + configuration + |> Current.collapse ~key:("Test stage " ^ name) ~value:target + ~input:skeleton in let mirage_skeleton = let+ _ = test_stage and+ skeleton = skeleton in @@ -104,7 +113,8 @@ let multi_stage_test ~platform ~targets ~configure ~run_test mirage_skeleton = (* MIRAGE 4 TEST *) let v_4 ~ocluster ~repos ~(platform : Platform.t) ~targets mirage_skeleton = - multi_stage_test ~platform ~targets ~run_test:(run_test_mirage_4 ~ocluster) + multi_stage_test ~platform ~targets + ~run_test:(run_test_mirage_4 ~ocluster) ~configure:(fun skeleton -> { repos; skeleton }) mirage_skeleton @@ -112,7 +122,8 @@ let v_4 ~ocluster ~repos ~(platform : Platform.t) ~targets mirage_skeleton = let v_main ~ocluster ~platform ~mirage ~repos mirage_skeleton = let mirage_skeleton = Current_git.fetch mirage_skeleton in - multi_stage_test ~platform ~targets ~run_test:(run_test_mirage_main ~ocluster) + multi_stage_test ~platform ~targets + ~run_test:(run_test_mirage_main ~ocluster) ~configure:(fun skeleton -> let skeleton = Current.map Current_git.Commit.id skeleton in { mirage; repos; skeleton }) diff --git a/src/pipelines/skeleton.mli b/src/pipelines/skeleton.mli index e61c7b6..8b3c91e 100644 --- a/src/pipelines/skeleton.mli +++ b/src/pipelines/skeleton.mli @@ -16,5 +16,5 @@ val v_4 : targets:string list -> Current_git.Commit.t Current.t -> unit Current.t -(** Pipeline optimized for mirage 4, using opam-monorepo to track if -resolutions changes. *) +(** Pipeline optimized for mirage 4, using opam-monorepo to track if resolutions + changes. *) diff --git a/src/solver/epoch_lock.ml b/src/solver/epoch_lock.ml index ba4032b..312ab09 100644 --- a/src/solver/epoch_lock.ml +++ b/src/solver/epoch_lock.ml @@ -28,10 +28,11 @@ let rec with_epoch t epoch fn = (fun () -> fn v) (fun () -> t.users <- t.users - 1; - ( match t.current with + (match t.current with | `Active _ -> () - | `Draining (_, cond) -> if t.users = 0 then Lwt_condition.broadcast cond () - | `Idle | `Activating _ -> assert false ); + | `Draining (_, cond) -> + if t.users = 0 then Lwt_condition.broadcast cond () + | `Idle | `Activating _ -> assert false); Lwt.return_unit) | `Active (_, old_v) -> let cond = Lwt_condition.create () in @@ -39,12 +40,14 @@ let rec with_epoch t epoch fn = t.current <- `Draining (ready, cond); (* After this point, no new users can start. *) let rec drain () = - if t.users = 0 then Lwt.return_unit else Lwt_condition.wait cond >>= drain + if t.users = 0 then Lwt.return_unit + else Lwt_condition.wait cond >>= drain in drain () >>= fun () -> t.dispose old_v >>= fun () -> activate t epoch ~ready ~set_ready >>= fun () -> with_epoch t epoch fn - | `Draining (ready, _) | `Activating ready -> ready >>= fun () -> with_epoch t epoch fn + | `Draining (ready, _) | `Activating ready -> + ready >>= fun () -> with_epoch t epoch fn | `Idle -> let ready, set_ready = Lwt.wait () in activate t epoch ~ready ~set_ready >>= fun () -> with_epoch t epoch fn diff --git a/src/solver/epoch_lock.mli b/src/solver/epoch_lock.mli index 19db5b7..3246933 100644 --- a/src/solver/epoch_lock.mli +++ b/src/solver/epoch_lock.mli @@ -1,18 +1,19 @@ (** Divide jobs up into distinct epochs. Any number of jobs can run at the same time within an epoch, but changing epoch requires first draining the - existing jobs, finishing the epoch, and then creating the new one. - The solver uses this to handle updates to opam-repository (each commit is a + existing jobs, finishing the epoch, and then creating the new one. The + solver uses this to handle updates to opam-repository (each commit is a separate epoch). *) type 'a t -val v : create:(string -> 'a Lwt.t) -> dispose:('a -> unit Lwt.t) -> unit -> 'a t -(** [v ~create ~dispose ()] is an epoch lock that calls [create] to start a new epoch - and [dispose] to finish one. A new epoch doesn't start until the old one has been - disposed. *) +val v : + create:(string -> 'a Lwt.t) -> dispose:('a -> unit Lwt.t) -> unit -> 'a t +(** [v ~create ~dispose ()] is an epoch lock that calls [create] to start a new + epoch and [dispose] to finish one. A new epoch doesn't start until the old + one has been disposed. *) val with_epoch : 'a t -> string -> ('a -> 'b Lwt.t) -> 'b Lwt.t -(** [with_epoch t epoch fn] runs [fn v] with the [v] for [epoch]. - If we are already in [epoch], [fn] runs immediately. - If we are already in another epoch then we wait for all users in the - previous epoch to finish, then create a new one, then run [fn]. *) +(** [with_epoch t epoch fn] runs [fn v] with the [v] for [epoch]. If we are + already in [epoch], [fn] runs immediately. If we are already in another + epoch then we wait for all users in the previous epoch to finish, then + create a new one, then run [fn]. *) diff --git a/src/solver/git_context.ml b/src/solver/git_context.ml index 0e1efeb..5d26bb1 100644 --- a/src/solver/git_context.ml +++ b/src/solver/git_context.ml @@ -14,7 +14,6 @@ type t = { } let user_restrictions t name = OpamPackage.Name.Map.find_opt name t.constraints - let dev = OpamPackage.Version.of_string "dev" let env t pkg v = @@ -29,7 +28,8 @@ let filter_deps t pkg f = let test = OpamPackage.Name.Set.mem (OpamPackage.name pkg) t.test in f |> OpamFilter.partial_filter_formula (env t pkg) - |> OpamFilter.filter_deps ~build:true ~post:true ~test ~doc:false ~dev ~default:false + |> OpamFilter.filter_deps ~build:true ~post:true ~test ~doc:false ~dev + ~default:false let candidates t name = match OpamPackage.Name.Map.find_opt name t.pins with @@ -37,30 +37,37 @@ let candidates t name = | None -> ( match OpamPackage.Name.Map.find_opt name t.packages with | None -> - OpamConsole.log "opam-0install" "Package %S not found!" (OpamPackage.Name.to_string name); + OpamConsole.log "opam-0install" "Package %S not found!" + (OpamPackage.Name.to_string name); [] | Some versions -> let user_constraints = user_restrictions t name in OpamPackage.Version.Map.bindings versions |> List.rev_map (fun (v, opam) -> match user_constraints with - | Some test when not (OpamFormula.check_version_formula (OpamFormula.Atom test) v) - -> + | Some test + when not + (OpamFormula.check_version_formula + (OpamFormula.Atom test) v) -> (v, Error (UserConstraint (name, Some test))) | _ -> ( let pkg = OpamPackage.create name v in let available = OpamFile.OPAM.available opam in - match OpamFilter.eval ~default:(B false) (env t pkg) available with + match + OpamFilter.eval ~default:(B false) (env t pkg) available + with | B true -> (v, Ok opam) | B false -> (v, Error Unavailable) | _ -> - OpamConsole.error "Available expression not a boolean: %s" + OpamConsole.error + "Available expression not a boolean: %s" (OpamFilter.to_string available); - (v, Error Unavailable) )) ) + (v, Error Unavailable)))) let pp_rejection f = function | UserConstraint x -> - Fmt.pf f "Rejected by user-specified constraint %s" (OpamFormula.string_of_atom x) + Fmt.pf f "Rejected by user-specified constraint %s" + (OpamFormula.string_of_atom x) | Unavailable -> Fmt.string f "Availability condition not satisfied" let read_dir store hash = @@ -71,11 +78,15 @@ let read_dir store hash = let read_package store pkg hash = Search.find store hash (`Path [ "opam" ]) >>= function - | None -> Fmt.failwith "opam file not found for %s" (OpamPackage.to_string pkg) + | None -> + Fmt.failwith "opam file not found for %s" (OpamPackage.to_string pkg) | Some hash -> ( Store.read store hash >|= function - | Ok (Git.Value.Blob blob) -> OpamFile.OPAM.read_from_string (Store.Value.Blob.to_string blob) - | _ -> Fmt.failwith "Bad Git object type for %s!" (OpamPackage.to_string pkg) ) + | Ok (Git.Value.Blob blob) -> + OpamFile.OPAM.read_from_string (Store.Value.Blob.to_string blob) + | _ -> + Fmt.failwith "Bad Git object type for %s!" (OpamPackage.to_string pkg) + ) (* Get a map of the versions inside [entry] (an entry under "packages") *) let read_versions store (entry : Store.Value.Tree.entry) = @@ -90,7 +101,8 @@ let read_versions store (entry : Store.Value.Tree.entry) = read_package store pkg entry.node >|= fun opam -> OpamPackage.Version.Map.add pkg.version opam acc | None -> - OpamConsole.log "opam-0install" "Invalid package name %S" entry.name; + OpamConsole.log "opam-0install" "Invalid package name %S" + entry.name; Lwt.return acc) OpamPackage.Version.Map.empty >|= fun versions -> Some versions @@ -107,15 +119,17 @@ let read_packages store commit = (fun acc (entry : Store.Value.Tree.entry) -> match OpamPackage.Name.of_string entry.name with | exception ex -> - OpamConsole.log "opam-0install" "Invalid package name %S: %s" entry.name + OpamConsole.log "opam-0install" + "Invalid package name %S: %s" entry.name (Printexc.to_string ex); Lwt.return acc | name -> ( read_versions store entry >|= function | None -> acc - | Some versions -> OpamPackage.Name.Map.add name versions acc )) - OpamPackage.Name.Map.empty ) + | Some versions -> + OpamPackage.Name.Map.add name versions acc)) + OpamPackage.Name.Map.empty) -let create ?(test = OpamPackage.Name.Set.empty) ?(pins = OpamPackage.Name.Map.empty) ~constraints - ~env ~packages () = +let create ?(test = OpamPackage.Name.Set.empty) + ?(pins = OpamPackage.Name.Map.empty) ~constraints ~env ~packages () = { env; packages; pins; constraints; test } diff --git a/src/solver/git_context.mli b/src/solver/git_context.mli index d41946f..530b0a7 100644 --- a/src/solver/git_context.mli +++ b/src/solver/git_context.mli @@ -4,7 +4,8 @@ val read_packages : Git_unix.Store.t -> Git_unix.Store.Hash.t -> OpamFile.OPAM.t OpamPackage.Version.Map.t OpamPackage.Name.Map.t Lwt.t -(** [read_packages store commit] is an index of the opam files in [store] at [commit]. *) +(** [read_packages store commit] is an index of the opam files in [store] at + [commit]. *) val create : ?test:OpamPackage.Name.Set.t -> diff --git a/src/solver/main.ml b/src/solver/main.ml index 8cf55de..a22e12b 100644 --- a/src/solver/main.ml +++ b/src/solver/main.ml @@ -5,8 +5,8 @@ let n_workers = 20 let pp_timestamp f x = let open Unix in let tm = localtime x in - Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour - tm.tm_min tm.tm_sec + Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) + tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec let reporter = let report src level ~over k msgf = @@ -20,7 +20,8 @@ let reporter = ("%a %a %a @[" ^^ fmt ^^ "@]@.") pp_timestamp (Unix.gettimeofday ()) Fmt.(styled `Magenta string) - (Printf.sprintf "%14s" src) Logs_fmt.pp_header (level, header) + (Printf.sprintf "%14s" src) + Logs_fmt.pp_header (level, header) in { Logs.report } @@ -29,7 +30,11 @@ let () = Logs.set_reporter reporter let export service ~on:socket = - let restore = Capnp_rpc_net.Restorer.single (Capnp_rpc_net.Restorer.Id.public "solver") service in + let restore = + Capnp_rpc_net.Restorer.single + (Capnp_rpc_net.Restorer.Id.public "solver") + service + in let switch = Lwt_switch.create () in let stdin = Capnp_rpc_unix.Unix_flow.connect socket @@ -37,7 +42,9 @@ let export service ~on:socket = (module Capnp_rpc_unix.Unix_flow) ~peer_id:Capnp_rpc_net.Auth.Digest.insecure ~switch in - let (_ : Capnp_rpc_unix.CapTP.t) = Capnp_rpc_unix.CapTP.connect ~restore stdin in + let (_ : Capnp_rpc_unix.CapTP.t) = + Capnp_rpc_unix.CapTP.connect ~restore stdin + in let crashed, set_crashed = Lwt.wait () in Lwt_switch.add_hook_or_exec (Some switch) (fun () -> Lwt.wakeup_exn set_crashed (Failure "Capnp switch turned off"); @@ -64,4 +71,7 @@ let () = let service = Service.v ~n_workers ~create_worker in export service ~on:Lwt_unix.stdin) | [| _prog; "--worker" |] -> Solver.main () - | args -> Fmt.failwith "Usage: ocaml-ci-solver (got %a)" Fmt.(array (quote string)) args + | args -> + Fmt.failwith "Usage: ocaml-ci-solver (got %a)" + Fmt.(array (quote string)) + args diff --git a/src/solver/opam_repository.ml b/src/solver/opam_repository.ml index 4707001..5785ce8 100644 --- a/src/solver/opam_repository.ml +++ b/src/solver/opam_repository.ml @@ -5,7 +5,8 @@ module Store = Git_unix.Store let open_store path = Git_unix.Store.v path >|= function | Ok x -> x - | Error e -> Fmt.failwith "Failed to open opam-repository: %a" Store.pp_error e + | Error e -> + Fmt.failwith "Failed to open opam-repository: %a" Store.pp_error e let oldest_commit_with ~from clone_path pkgs = let from = Store.Hash.to_hex from in @@ -17,8 +18,16 @@ let oldest_commit_with ~from clone_path pkgs = Printf.sprintf "packages/%s/%s.%s" name name version) in let cmd = - "git" :: "-C" :: Fpath.to_string clone_path :: "log" :: "-n" :: "1" :: "--format=format:%H" - :: from :: "--" :: paths + "git" + :: "-C" + :: Fpath.to_string clone_path + :: "log" + :: "-n" + :: "1" + :: "--format=format:%H" + :: from + :: "--" + :: paths in let cmd = ("", Array.of_list cmd) in Process.pread cmd >|= String.trim diff --git a/src/solver/opam_repository.mli b/src/solver/opam_repository.mli index 88560f4..25fa47b 100644 --- a/src/solver/opam_repository.mli +++ b/src/solver/opam_repository.mli @@ -1,6 +1,9 @@ val open_store : Fpath.t -> Git_unix.Store.t Lwt.t -val oldest_commit_with : from:Git_unix.Store.Hash.t -> Fpath.t -> OpamPackage.t list -> string Lwt.t -(** Use "git-log" to find the oldest commit with these package versions. - This avoids invalidating the Docker build cache on every update to opam-repository. +val oldest_commit_with : + from:Git_unix.Store.Hash.t -> Fpath.t -> OpamPackage.t list -> string Lwt.t +(** Use "git-log" to find the oldest commit with these package versions. This + avoids invalidating the Docker build cache on every update to + opam-repository. + @param from The commit at which to begin the search. *) diff --git a/src/solver/service.ml b/src/solver/service.ml index 81717fe..dede321 100644 --- a/src/solver/service.ml +++ b/src/solver/service.ml @@ -10,9 +10,17 @@ module Epoch : sig (* An Epoch handles all requests for a single opam-repository HEAD commit. *) - val create : n_workers:int -> create_worker:(unit -> Lwt_process.process) -> unit -> t Lwt.t + val create : + n_workers:int -> + create_worker:(unit -> Lwt_process.process) -> + unit -> + t Lwt.t - val handle : log:Solver_api.Solver.Log.t -> Worker.Solve_request.t -> t -> Selection.t list Lwt.t + val handle : + log:Solver_api.Solver.Log.t -> + Worker.Solve_request.t -> + t -> + Selection.t list Lwt.t val dispose : t -> unit Lwt.t end = struct @@ -23,8 +31,8 @@ end = struct | Lwt.Sleep -> Lwt.return true | Lwt.Fail ex -> Lwt.fail ex | Lwt.Return status -> - Format.eprintf "Worker %d is dead (%a) - removing from pool@." worker#pid Process.pp_status - status; + Format.eprintf "Worker %d is dead (%a) - removing from pool@." + worker#pid Process.pp_status status; Lwt.return false let dispose (worker : Lwt_process.process) = @@ -34,15 +42,20 @@ end = struct worker#status >|= fun _ -> Fmt.epr "Worker %d finished@." pid let create ~n_workers ~create_worker () = - Lwt_pool.create n_workers ~validate ~dispose (fun () -> Lwt.return (create_worker ())) + Lwt_pool.create n_workers ~validate ~dispose (fun () -> + Lwt.return (create_worker ())) |> Lwt.return let dispose = Lwt_pool.clear (* Send [request] to [worker] and read the reply. *) let process ~log ~id request worker = - let request_str = Worker.Solve_request.to_yojson request |> Yojson.Safe.to_string in - let request_str = Printf.sprintf "%d\n%s" (String.length request_str) request_str in + let request_str = + Worker.Solve_request.to_yojson request |> Yojson.Safe.to_string + in + let request_str = + Printf.sprintf "%d\n%s" (String.length request_str) request_str + in Lwt_io.write worker#stdin request_str >>= fun () -> Lwt_io.read_line worker#stdout >>= fun time -> Lwt_io.read_line worker#stdout >>= fun len -> @@ -56,7 +69,8 @@ end = struct | '+' -> Log.info log "%s: found solution in %s s" id time; Astring.String.with_range ~first:1 results - |> Yojson.Safe.from_string |> Solver.solve_result_of_yojson + |> Yojson.Safe.from_string + |> Solver.solve_result_of_yojson | '-' -> Log.info log "%s: eliminated all possibilities in %s s" id time; let msg = results |> Astring.String.with_range ~first:1 in @@ -64,7 +78,7 @@ end = struct | '!' -> let msg = results |> Astring.String.with_range ~first:1 in Fmt.failwith "BUG: solver worker failed: %s" msg - | _ -> Fmt.failwith "BUG: bad output: %s" results ) + | _ -> Fmt.failwith "BUG: bad output: %s" results) let handle ~log request t = let { Worker.Solve_request.platforms; pkgs; _ } = request in @@ -81,7 +95,9 @@ end = struct Log.info log "= %s =" id; match result with | Ok result -> - Log.info log "-> @[%a@]" Fmt.(list ~sep:sp string) result.Selection.packages; + Log.info log "-> @[%a@]" + Fmt.(list ~sep:sp string) + result.Selection.packages; Log.info log "(valid since opam-repository commits %a)" Fmt.(list (pair ~sep:(any ": ") string string)) result.Selection.commits; @@ -94,7 +110,8 @@ end (* Handle a request by distributing it among the worker processes and then aggregating their responses. *) let handle t ~log (request : Worker.Solve_request.t) = Epoch_lock.with_epoch t - (List.map (fun (_, _, x) -> x) request.opam_repos_folders |> String.concat "-") + (List.map (fun (_, _, x) -> x) request.opam_repos_folders + |> String.concat "-") (Epoch.handle ~log request) let v ~n_workers ~create_worker = @@ -115,9 +132,12 @@ let v ~n_workers ~create_worker = | Some log -> ( Capnp_rpc_lwt.Service.return_lwt @@ fun () -> Capability.with_ref log @@ fun log -> - match Worker.Solve_request.of_yojson (Yojson.Safe.from_string request) with + match + Worker.Solve_request.of_yojson (Yojson.Safe.from_string request) + with | Error msg -> - Lwt_result.fail (`Capnp (Capnp_rpc.Error.exn "Bad JSON in request: %s" msg)) + Lwt_result.fail + (`Capnp (Capnp_rpc.Error.exn "Bad JSON in request: %s" msg)) | Ok request -> Lwt.catch (fun () -> handle t ~log request >|= Result.ok) @@ -125,10 +145,13 @@ let v ~n_workers ~create_worker = | Failure msg -> Lwt_result.fail (`Msg msg) | ex -> Lwt.return (Fmt.error_msg "%a" Fmt.exn ex)) >|= fun selections -> - let json = Yojson.Safe.to_string (Worker.Solve_response.to_yojson selections) in + let json = + Yojson.Safe.to_string + (Worker.Solve_response.to_yojson selections) + in let response, results = Capnp_rpc_lwt.Service.Response.create Results.init_pointer in Results.response_set results json; - Ok response ) + Ok response) end diff --git a/src/solver/service.mli b/src/solver/service.mli index d00edfe..1ddfc49 100644 --- a/src/solver/service.mli +++ b/src/solver/service.mli @@ -1,3 +1,7 @@ -val v : n_workers:int -> create_worker:(unit -> Lwt_process.process) -> Solver_api.Solver.t -(** [v ~n_workers ~create_worker] is a solver service that distributes work to up to - [n_workers] subprocesses, using [create_worker hash] to spawn new workers. *) +val v : + n_workers:int -> + create_worker:(unit -> Lwt_process.process) -> + Solver_api.Solver.t +(** [v ~n_workers ~create_worker] is a solver service that distributes work to + up to [n_workers] subprocesses, using [create_worker hash] to spawn new + workers. *) diff --git a/src/solver/solver.ml b/src/solver/solver.ml index 08ca842..b2d7b73 100644 --- a/src/solver/solver.ml +++ b/src/solver/solver.ml @@ -6,7 +6,8 @@ open Lwt.Syntax let env (vars : Worker.Vars.t) = Opam_0install.Dir_context.std_env ~arch:vars.arch ~os:vars.os - ~os_distribution:vars.os_distribution ~os_version:vars.os_version ~os_family:vars.os_family () + ~os_distribution:vars.os_distribution ~os_version:vars.os_version + ~os_family:vars.os_family () let solve ~packages ~constraints ~root_pkgs (vars : Worker.Vars.t) = let context = Git_context.create () ~packages ~env:(env vars) ~constraints in @@ -18,7 +19,8 @@ let solve ~packages ~constraints ~root_pkgs (vars : Worker.Vars.t) = | Ok sels -> Ok (Solver.packages_of_result sels) | Error diagnostics -> Error (Solver.diagnostics diagnostics) -type solve_result = { packages : string list; commits : (string * string) list } [@@deriving yojson] +type solve_result = { packages : string list; commits : (string * string) list } +[@@deriving yojson] let find_oldest_commits ~all (packages : OpamPackage.t list) = let module StringMap = Map.Make (String) in @@ -27,16 +29,23 @@ let find_oldest_commits ~all (packages : OpamPackage.t list) = (fun package -> let open OpamPackage in let (name, folder, commit), _ = - all |> Name.Map.find (name package) |> Version.Map.find (version package) + all + |> Name.Map.find (name package) + |> Version.Map.find (version package) in match StringMap.find_opt folder !store_map with - | None -> store_map := StringMap.add folder (name, commit, [ package ]) !store_map - | Some (_, _, v) -> store_map := StringMap.add folder (name, commit, package :: v) !store_map) + | None -> + store_map := + StringMap.add folder (name, commit, [ package ]) !store_map + | Some (_, _, v) -> + store_map := + StringMap.add folder (name, commit, package :: v) !store_map) packages; - !store_map |> StringMap.bindings + !store_map + |> StringMap.bindings |> Lwt_list.map_p (fun (folder, (name, commit, packages)) -> - Opam_repository.oldest_commit_with ~from:(Store.Hash.of_hex commit) (Fpath.v folder) - packages + Opam_repository.oldest_commit_with ~from:(Store.Hash.of_hex commit) + (Fpath.v folder) packages >|= fun commit -> (name, commit)) let main () = @@ -47,14 +56,22 @@ let main () = let len = int_of_string len in let data = really_input_string stdin len in let request = - Worker.Solve_request.of_yojson (Yojson.Safe.from_string data) |> Result.get_ok + Worker.Solve_request.of_yojson (Yojson.Safe.from_string data) + |> Result.get_ok + in + let { + Worker.Solve_request.opam_repos_folders; + pkgs; + constraints; + platforms; + } = + request in - let { Worker.Solve_request.opam_repos_folders; pkgs; constraints; platforms } = request in Lwt_list.map_p (fun (name, folder, commit) -> Opam_repository.open_store (Fpath.v folder) >>= fun store -> - Git_context.read_packages store (Store.Hash.of_hex commit) >|= fun res -> - ((name, folder, commit), res)) + Git_context.read_packages store (Store.Hash.of_hex commit) + >|= fun res -> ((name, folder, commit), res)) opam_repos_folders >>= fun packages -> let all_packages = @@ -62,15 +79,19 @@ let main () = List.fold_left (fun acc (repo_name, packages) -> packages - |> OpamPackage.Name.Map.map (OpamPackage.Version.Map.map (fun x -> (repo_name, x))) - |> OpamPackage.Name.Map.union (OpamPackage.Version.Map.union (fun a _ -> a)) acc) + |> OpamPackage.Name.Map.map + (OpamPackage.Version.Map.map (fun x -> (repo_name, x))) + |> OpamPackage.Name.Map.union + (OpamPackage.Version.Map.union (fun a _ -> a)) + acc) OpamPackage.Name.Map.empty packages in let root_pkgs = pkgs |> List.map OpamPackage.Name.of_string in let constraints = constraints |> List.map (fun (name, version) -> - (OpamPackage.Name.of_string name, (`Eq, OpamPackage.Version.of_string version))) + ( OpamPackage.Name.of_string name, + (`Eq, OpamPackage.Version.of_string version) )) |> OpamPackage.Name.Map.of_list in let* () = @@ -79,13 +100,19 @@ let main () = let+ msg = match solve - ~packages:(OpamPackage.(Name.Map.map (Version.Map.map snd)) all_packages) + ~packages: + (OpamPackage.(Name.Map.map (Version.Map.map snd)) + all_packages) ~constraints ~root_pkgs platform with | Ok packages -> - let+ commits = find_oldest_commits ~all:all_packages packages in + let+ commits = + find_oldest_commits ~all:all_packages packages + in let packages = List.map OpamPackage.to_string packages in - "+" ^ (solve_result_to_yojson { packages; commits } |> Yojson.Safe.to_string) + "+" + ^ (solve_result_to_yojson { packages; commits } + |> Yojson.Safe.to_string) | Error msg -> Lwt.return ("-" ^ msg) in Printf.printf "%d\n%s%!" (String.length msg) msg) @@ -98,7 +125,9 @@ let main () = try main () with ex -> Fmt.epr "solver bug: %a@." Fmt.exn ex; - let msg = match ex with Failure msg -> msg | ex -> Printexc.to_string ex in + let msg = + match ex with Failure msg -> msg | ex -> Printexc.to_string ex + in let msg = "!" ^ msg in Printf.printf "0.0\n%d\n%s%!" (String.length msg) msg; raise ex diff --git a/src/solver/solver.mli b/src/solver/solver.mli index d672dff..6526a6f 100644 --- a/src/solver/solver.mli +++ b/src/solver/solver.mli @@ -1,5 +1,6 @@ -type solve_result = { packages : string list; commits : (string * string) list } [@@deriving yojson] +type solve_result = { packages : string list; commits : (string * string) list } +[@@deriving yojson] val main : unit -> unit -(** [main hash] runs a worker process that reads requests from stdin and writes results to stdout, - using commit [hash] in opam-repository. *) +(** [main hash] runs a worker process that reads requests from stdin and writes + results to stdout, using commit [hash] in opam-repository. *)