Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Use the same ocamlformat paramaters as in Irmin #3

Merged
merged 1 commit into from
Oct 15, 2021
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 5 additions & 2 deletions .ocamlformat
Original file line number Diff line number Diff line change
@@ -1,2 +1,5 @@
version=0.15.0
margin=100
version = 0.19.0
profile = conventional
break-infix = fit-or-vertical
parse-docstrings = true
module-item-spacing = compact
17 changes: 11 additions & 6 deletions src/api/solver.ml
Original file line number Diff line number Diff line change
Expand Up @@ -9,21 +9,24 @@ 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

let info t fmt =
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
Expand All @@ -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
9 changes: 6 additions & 3 deletions src/api/worker.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -28,15 +29,17 @@ 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]
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
13 changes: 9 additions & 4 deletions src/lib/config.ml
Original file line number Diff line number Diff line change
Expand Up @@ -8,22 +8,26 @@ 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 }

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 =
{
Expand All @@ -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
20 changes: 11 additions & 9 deletions src/lib/current_solver.ml
Original file line number Diff line number Diff line change
@@ -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 ()
Expand Down Expand Up @@ -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));
]
Expand All @@ -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
Expand All @@ -62,15 +61,18 @@ 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

let build No_context job { Key.repos; packages; system } =
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)) ->
Expand Down
5 changes: 2 additions & 3 deletions src/lib/current_solver.mli
Original file line number Diff line number Diff line change
@@ -1,11 +1,10 @@
type resolution = { name : string; version : string }

type t = { resolutions : resolution list; repos : Repository.t list }

val v :
system:Platform.system ->
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. *)
75 changes: 48 additions & 27 deletions src/lib/git_store.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 =
Expand All @@ -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
Expand All @@ -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

Expand Down Expand Up @@ -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"; "*:*" |])
Expand All @@ -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** () =
Expand All @@ -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
Expand All @@ -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
Expand Down
Loading