diff --git a/bin/builder_db_app.ml b/bin/builder_db_app.ml index ac2312c..08ab6d9 100644 --- a/bin/builder_db_app.ml +++ b/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 diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 8b04792..cb43880 100644 --- a/bin/builder_web_app.ml +++ b/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 diff --git a/bin/migrations/builder_migrations.ml b/bin/migrations/builder_migrations.ml index 49aec0e..c751981 100644 --- a/bin/migrations/builder_migrations.ml +++ b/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 diff --git a/bin/visualizations/builder_viz.ml b/bin/visualizations/builder_viz.ml index 77eec07..fcb11e3 100644 --- a/bin/visualizations/builder_viz.ml +++ b/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 diff --git a/builder-web.opam b/builder-web.opam index a34ab6e..5af5369 100644 --- a/builder-web.opam +++ b/builder-web.opam @@ -43,7 +43,7 @@ depends: [ "mirage-crypto" "asn1-combinators" "logs" - "cmdliner" + "cmdliner" {>= "1.1.0"} "uri" "fmt" {>= "0.8.7"} "omd" diff --git a/test/test_builder_db.ml b/test/test_builder_db.ml index 77f61e0..66acbe3 100644 --- a/test/test_builder_db.ml +++ b/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.)