Merged with main/master

bin/builder_db_app.ml

@@ -480,87 +480,111 @@ let setup_log =
   in
   Cmdliner.Term.(const setup_log $ Logs_cli.level ())
 
+open Cmdliner
+
 let migrate_cmd =
   let doc = "create database and add tables" in
-  Cmdliner.Term.(pure migrate $ setup_log $ dbpath_new),
-  Cmdliner.Term.info ~doc "migrate"
+  let term = Term.(const migrate $ setup_log $ dbpath_new) in
+  let info = Cmd.info ~doc "migrate" in
+  Cmd.v info term
 
 let user_add_cmd =
   let doc = "add a user" in
-  (Cmdliner.Term.(pure user_add $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username $ unrestricted),
-   Cmdliner.Term.info ~doc "user-add")
+  let term = Term.(
+      const user_add $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p
+      $ username $ unrestricted) in
+  let info = Cmd.info ~doc "user-add" in
+  Cmd.v info term
 
 let user_update_cmd =
   let doc = "update a user password" in
-  (Cmdliner.Term.(pure user_update $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username $ unrestricted),
-   Cmdliner.Term.info ~doc "user-update")
+  let term = Term.(
+      const user_update $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p
+      $ username $ unrestricted) in
+  let info = Cmd.info ~doc "user-update" in
+  Cmd.v info term
 
 let user_remove_cmd =
   let doc = "remove a user" in
-  (Cmdliner.Term.(pure user_remove $ setup_log $ dbpath $ username),
-   Cmdliner.Term.info ~doc "user-remove")
+  let term = Term.(const user_remove $ setup_log $ dbpath $ username) in
+  let info = Cmd.info ~doc "user-remove" in
+  Cmd.v info term
 
 let user_disable_cmd =
   let doc = "disable a user" in
-  (Cmdliner.Term.(pure user_disable $ setup_log $ dbpath $ username),
-   Cmdliner.Term.info ~doc "user-disable")
+  let term = Term.(const user_disable $ setup_log $ dbpath $ username) in
+  let info = Cmd.info ~doc "user-disable" in
+  Cmd.v info term
 
 let user_list_cmd =
   let doc = "list all users" in
-  (Cmdliner.Term.(pure user_list $ setup_log $ dbpath),
-   Cmdliner.Term.info ~doc "user-list")
+  let term = Term.(const user_list $ setup_log $ dbpath) in
+  let info = Cmd.info ~doc "user-list" in
+  Cmd.v info term
 
 let access_add_cmd =
   let doc = "grant access to user and job" in
-  (Cmdliner.Term.(pure access_add $ setup_log $ dbpath $ username $ job),
-   Cmdliner.Term.info ~doc "access-add")
+  let term = Term.(const access_add $ setup_log $ dbpath $ username $ job) in
+  let info = Cmd.info ~doc "access-add" in
+  Cmd.v info term
 
 let access_remove_cmd =
   let doc = "remove access to user and job" in
-  (Cmdliner.Term.(pure access_remove $ setup_log $ dbpath $ username $ job),
-   Cmdliner.Term.info ~doc "access-remove")
+  let term = Term.(const access_remove $ setup_log $ dbpath $ username $ job) in
+  let info = Cmd.info ~doc "access-remove" in
+  Cmd.v info term
 
 let job_remove_cmd =
   let doc = "remove job and its associated builds and artifacts" in
-  (Cmdliner.Term.(pure job_remove $ setup_log $ datadir $ jobname),
-   Cmdliner.Term.info ~doc "job-remove")
+  let term = Term.(const job_remove $ setup_log $ datadir $ jobname) in
+  let info = Cmd.info ~doc "job-remove" in
+  Cmd.v info term
 
 let extract_full_cmd =
   let doc = "extract a build from the database" in
-  (Cmdliner.Term.(pure extract_full $ setup_log $ datadir $ full_dest $ build),
-   Cmdliner.Term.info ~doc "extract-build")
+  let term = Term.(
+      const extract_full $ setup_log $ datadir $ full_dest $ build) in
+  let info = Cmd.info ~doc "extract-build" in
+  Cmd.v info term
 
 let verify_input_id_cmd =
-  let doc = "verify that the main binary hash of all builds with the same input are equal" in
-  (Cmdliner.Term.(pure verify_input_id $ setup_log $ dbpath),
-   Cmdliner.Term.info ~doc "verify-input-id")
+  let doc = "verify that the main binary hash of all builds with the same \
+             input are equal" in
+  let term = Term.(const verify_input_id $ setup_log $ dbpath) in
+  let info = Cmd.info ~doc "verify-input-id" in
+  Cmd.v info term
 
 let verify_data_dir_cmd =
-  let doc = "verify that the data directory is consistent with the build_artifact table" in
-  (Cmdliner.Term.(pure verify_data_dir $ setup_log $ datadir),
-   Cmdliner.Term.info ~doc "verify-data-dir")
+  let doc = "verify that the data directory is consistent with the \
+             build_artifact table" in
+  let term = Term.(const verify_data_dir $ setup_log $ datadir) in
+  let info = Cmd.info ~doc "verify-data-dir" in
+  Cmd.v info term
 
 let help_cmd =
   let topic =
     let doc = "Command to get help on" in
-    Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"COMMAND" [])
+    Arg.(value & pos 0 (some string) None & info ~doc ~docv:"COMMAND" [])
   in
   let doc = "Builder database help" in
-  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ topic)),
-  Cmdliner.Term.info ~doc "help"
+  let term = Term.(ret (const help $ Arg.man_format $ choice_names $ topic)) in
+  let info = Cmd.info ~doc "help" in
+  Cmd.v info term
 
-let default_cmd =
+let default_cmd, default_info =
   let doc = "Builder database command" in
-  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ const None)),
-  Cmdliner.Term.info ~doc "builder-db"
+  Term.(ret (const help $ Arg.man_format $ choice_names $ const None)),
+  Cmd.info ~doc "builder-db"
 
 let () =
   Mirage_crypto_rng_unix.initialize ();
-  Cmdliner.Term.eval_choice
-    default_cmd
-    [help_cmd; migrate_cmd;
-     user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd; user_disable_cmd;
-     access_add_cmd; access_remove_cmd; job_remove_cmd;
-     verify_input_id_cmd; verify_data_dir_cmd;
-     extract_full_cmd ]
-  |> Cmdliner.Term.exit
+  Cmdliner.Cmd.group
+    ~default:default_cmd default_info
+    [ help_cmd; migrate_cmd;
+      user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd;
+      user_disable_cmd;
+      access_add_cmd; access_remove_cmd; job_remove_cmd;
+      verify_input_id_cmd; verify_data_dir_cmd;
+      extract_full_cmd ]
+  |> Cmdliner.Cmd.eval
+  |> exit

bin/builder_web_app.ml

@@ -102,7 +102,7 @@ let setup_app level influx port host datadir configdir =
 
 open Cmdliner
 
-let ip_port : (Ipaddr.V4.t * int) Arg.converter =
+let ip_port : (Ipaddr.V4.t * int) Arg.conv =
   let default_port = 8094 in
   let parse s =
     match
@@ -114,12 +114,14 @@ let ip_port : (Ipaddr.V4.t * int) Arg.converter =
       end
         | _ -> Error "multiple : found"
     with
-    | Error msg -> `Error msg
+    | Error msg -> Error (`Msg msg)
     | Ok (ip, port) -> match Ipaddr.V4.of_string ip with
-      | Ok ip -> `Ok (ip, port)
-      | Error `Msg msg -> `Error msg
+      | Ok ip -> Ok (ip, port)
+      | Error `Msg msg -> Error (`Msg msg)
   in
-  parse, fun ppf (ip, port) -> Format.fprintf ppf "%a:%d" Ipaddr.V4.pp ip port
+  let printer ppf (ip, port) =
+    Format.fprintf ppf "%a:%d" Ipaddr.V4.pp ip port in
+  Arg.conv (parse, printer)
 
 let datadir =
   let doc = "data directory" in
@@ -142,9 +144,8 @@ let influx =
   Arg.(value & opt (some ip_port) None & info [ "influx" ] ~doc ~docv:"INFLUXHOST[:PORT]")
 
 let () =
-  let term = Term.(pure setup_app $ Logs_cli.level () $ influx $ port $ host $ datadir $ configdir) in
-  let info = Term.info "Builder web" ~doc:"Builder web" ~man:[] in
-  match Term.eval (term, info) with
-  | `Ok () -> exit 0
-  | `Error _ -> exit 1
-  | _ -> exit 0
+  let term = Term.(const setup_app $ Logs_cli.level () $ influx $ port $ host $ datadir $ configdir) in
+  let info = Cmd.info "Builder web" ~doc:"Builder web" ~man:[] in
+  Cmd.v info term
+  |> Cmd.eval
+  |> exit

bin/migrations/builder_migrations.ml

@@ -72,53 +72,69 @@ let setup_log =
   in
   Cmdliner.Term.(const setup_log $ Logs_cli.level ())
 
+open Cmdliner
+
 let actions (module M : MIGRATION) =
   let c s = s ^ "-" ^ M.identifier in
   let v doc from_ver to_ver = Printf.sprintf "%s (DB version %Ld -> %Ld)" doc from_ver to_ver in
-  [
-    (Cmdliner.Term.(const do_database_action $ const M.migrate $ setup_log $ datadir),
-     Cmdliner.Term.info ~doc:(v M.migrate_doc M.old_version M.new_version)
-       (c "migrate"));
-    (Cmdliner.Term.(const do_database_action $ const M.rollback $ setup_log $ datadir),
-     Cmdliner.Term.info ~doc:(v M.rollback_doc M.new_version M.old_version)
-       (c "rollback"));
-  ]
+  let migrate_cmd =
+    let term = Term.(
+        const do_database_action $ const M.migrate $ setup_log $ datadir) in
+    let info = Cmd.info ~doc:(v M.migrate_doc M.old_version M.new_version)
+        (c "migrate") in
+    Cmd.v info term
+  in
+  let rollback_cmd =
+    let term = Term.(
+        const do_database_action $ const M.rollback $ setup_log $ datadir) in
+    let info = Cmd.info ~doc:(v M.rollback_doc M.new_version M.old_version)
+        (c "rollback") in
+    Cmd.v info term
+  in
+  [ migrate_cmd; rollback_cmd ]
 
 let f20210308 =
   let doc = "Remove broken builds as fixed in commit a57798f4c02eb4d528b90932ec26fb0b718f1a13. \
     Note that the files on disk have to be removed manually." in
-  Cmdliner.Term.(const do_database_action $ const M20210308.fixup $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "fixup-2021-03-08"
+  let term = Term.(const do_database_action $ const M20210308.fixup $ setup_log $ datadir) in
+  let info = Cmd.info ~doc "fixup-2021-03-08" in
+  Cmd.v info term
 
 let f20210707a =
   let doc = "Remove orb.deb and orb.txz that ended up in the build." in
-  Cmdliner.Term.(const do_database_action $ const M20210707a.fixup $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "fixup-2021-07-07a"
+  let term = Term.(const do_database_action $ const M20210707a.fixup $ setup_log $ datadir) in
+  let info = Cmd.info ~doc "fixup-2021-07-07a" in
+  Cmd.v info term
 
 let f20210707b =
   let doc = "Move *.deb.debug to bin/*.deb and remove the earlier bin/*.deb. Adjust main_binary of build." in
-  Cmdliner.Term.(const do_database_action $ const M20210707b.fixup $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "fixup-2021-07-07b"
+  let term = Term.(const do_database_action $ const M20210707b.fixup $ setup_log $ datadir) in
+  let info = Cmd.info ~doc "fixup-2021-07-07b" in
+  Cmd.v info term
 
 let f20210707c =
   let doc = "Strip bin/*.{hvt,xen} if no *.{hvt,xen} exists. Adjust build_artifact table and main_binary of build." in
-  Cmdliner.Term.(const do_database_action $ const M20210707c.fixup $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "fixup-2021-07-07c"
+  let term = Term.(const do_database_action $ const M20210707c.fixup $ setup_log $ datadir) in
+  let info = Cmd.info ~doc "fixup-2021-07-07c" in
+  Cmd.v info term
 
 let f20210707d =
   let doc = "Remove ./ from filepath." in
-  Cmdliner.Term.(const do_database_action $ const M20210707d.fixup $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "fixup-2021-07-07d"
+  let term = Term.(const do_database_action $ const M20210707d.fixup $ setup_log $ datadir) in
+  let info = Cmd.info ~doc "fixup-2021-07-07d" in
+  Cmd.v info term
 
 let f20210712b =
   let doc = "Remove build-hashes and README from artifacts." in
-  Cmdliner.Term.(const do_database_action $ const M20210712b.fixup $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "fixup-2021-07-12b"
+  let term = Term.(const do_database_action $ const M20210712b.fixup $ setup_log $ datadir) in
+  let info = Cmd.info ~doc "fixup-2021-07-12b" in
+  Cmd.v info term
 
 let f20210910 =
   let doc = "Undo builds with script and console mixed up." in
-  Cmdliner.Term.(const do_database_action $ const M20210910.fixup $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "fixup-2021-09-10"
+  let term = Term.(const do_database_action $ const M20210910.fixup $ setup_log $ datadir) in
+  let info = Cmd.info ~doc "fixup-2021-09-10" in
+  Cmd.v info term
 
 let help_cmd =
   let topic =
@@ -126,17 +142,16 @@ let help_cmd =
     Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"MIGRATION" [])
   in
   let doc = "Builder migration help" in
-  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ topic)),
-  Cmdliner.Term.info ~doc "help"
-
-let default_cmd =
-  let doc = "Builder migration command" in
-  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ const None)),
-  Cmdliner.Term.info ~doc "builder-migrations"
+  let term = Term.(ret (const help $ Arg.man_format $ choice_names $ topic)) in
+  let info = Cmd.info ~doc "help" in
+  Cmd.v info term
 
 let () =
-  Cmdliner.Term.eval_choice
-    default_cmd
+  let doc = "Builder migration command" in
+  let default_term = Term.(ret (const help $ Arg.man_format $ choice_names $ const None)) in
+  let default_info = Cmd.info ~doc "builder-migrations" in
+  Cmd.group
+    ~default:default_term default_info
     (List.concat [
         [ help_cmd ];
         actions (module M20210126);
@@ -164,4 +179,5 @@ let () =
         [ f20210910 ];
         actions (module M20211105);
       ])
-  |> Cmdliner.Term.exit
+  |> Cmd.eval
+  |> exit

bin/visualizations/builder_viz.ml

@@ -53,10 +53,10 @@ let print_treemap_html elf_path elf_size =
     ]
   in
   let override_css = {|
-    .module {
+    .treemap-module {
       fill: rgb(60, 60, 87);
     }
-    .functor > text, .module > text {
+    .treemap-functor > text, .treemap-module > text {
       fill: bisque;
     }
   |}
@@ -86,9 +86,9 @@ let print_dependencies_html file =
   let html = Render.Html.of_assoc ~override_css graph in
   Format.printf "%a" Render.Html.pp html
 
-module Cmd = struct
+module Cmd_aux = struct
 
-  module Arg = struct
+  module Arg_aux = struct
 
     let elf_path =
       let doc = "The file-path of the debug-ELF to be analyzed" in
@@ -127,15 +127,19 @@ module Cmd = struct
 
   end
 
+  open Cmdliner
+
   let treemap =
     let doc = "Dump treemap SVG and CSS wrapped in HTML" in
-    Cmdliner.Term.(pure print_treemap_html $ Arg.elf_path $ Arg.elf_size),
-    Cmdliner.Term.info ~doc "treemap"
+    let term = Term.(const print_treemap_html $ Arg_aux.elf_path $ Arg_aux.elf_size) in
+    let info = Cmd.info ~doc "treemap" in
+    Cmd.v info term
 
   let dependencies =
     let doc = "Dump opam dependencies SVG and CSS wrapped in HTML" in
-    Cmdliner.Term.(pure print_dependencies_html $ Arg.opam_switch_path),
-    Cmdliner.Term.info ~doc "dependencies"
+    let term = Term.(const print_dependencies_html $ Arg_aux.opam_switch_path) in
+    let info = Cmd.info ~doc "dependencies" in
+    Cmd.v info term
 
   let help =
     let topic =
@@ -143,20 +147,26 @@ module Cmd = struct
       Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"COMMAND" [])
     in
     let doc = "Builder database help" in
-    Cmdliner.Term.(ret (const Aux.help $ man_format $ choice_names $ topic)),
-    Cmdliner.Term.info ~doc "help"
+    let term = Term.(ret (const Aux.help $ Arg.man_format $ choice_names $ topic)) in
+    let info = Cmd.info ~doc "help" in
+    Cmd.v info term
 
-  let default =
+  let default_info, default_cmd =
     let doc = "Builder database command" in
-    Cmdliner.Term.(ret (const Aux.help $ man_format $ choice_names $ const None)),
-    Cmdliner.Term.info ~doc "builder-viz"
+    let term = Term.(ret (const Aux.help $ Arg.man_format $ choice_names $ const None)) in
+    let info = Cmd.info ~doc "builder-viz" in
+    info, term
 
 end
 
 let () =
-  Cmdliner.Term.eval_choice Cmd.default [
-    Cmd.help;
-    Cmd.treemap;
-    Cmd.dependencies;
-  ]
-  |> Cmdliner.Term.exit
+  let open Cmdliner in
+  Cmd.group
+    ~default:Cmd_aux.default_cmd Cmd_aux.default_info
+    [
+      Cmd_aux.help;
+      Cmd_aux.treemap;
+      Cmd_aux.dependencies;
+    ]
+  |> Cmd.eval
+  |> exit

builder-web.opam

@@ -43,7 +43,7 @@ depends: [
   "mirage-crypto"
   "asn1-combinators"
   "logs"
-  "cmdliner"
+  "cmdliner" {>= "1.1.0"}
   "uri"
   "fmt" {>= "0.8.7"}
   "omd"

test/test_builder_db.ml

@@ -126,7 +126,7 @@ let test_user_unauth (module Db : CONN) =
 
 let job_name = "test-job"
 let script = Fpath.v "/dev/null"
-let uuid = Uuidm.create `V4
+let uuid = Uuidm.v `V4
 let console = Fpath.v "/dev/null"
 let start = Option.get (Ptime.of_float_s 0.)
 let finish = Option.get (Ptime.of_float_s 1.)
@@ -203,7 +203,7 @@ let test_build_get_all (module Db : CONN) =
   Db.collect_list Builder_db.Build.get_all job_id >>| fun builds ->
   Alcotest.(check int) "one build" (List.length builds) 1
 
-let uuid' = Uuidm.create `V4
+let uuid' = Uuidm.v `V4
 let start' = Option.get (Ptime.of_float_s 3600.)
 let finish' = Option.get (Ptime.of_float_s 3601.)