Merge branch '20220221_fix_cmdliner_deprecations'
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/87
This commit is contained in:
commit
b6f6090ce5
5 changed files with 152 additions and 101 deletions
|
|
@ -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;
|
||||
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.Term.exit
|
||||
|> Cmdliner.Cmd.eval
|
||||
|> exit
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
let open Cmdliner in
|
||||
Cmd.group
|
||||
~default:Cmd_aux.default_cmd Cmd_aux.default_info
|
||||
[
|
||||
Cmd_aux.help;
|
||||
Cmd_aux.treemap;
|
||||
Cmd_aux.dependencies;
|
||||
]
|
||||
|> Cmdliner.Term.exit
|
||||
|> Cmd.eval
|
||||
|> exit
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ depends: [
|
|||
"mirage-crypto"
|
||||
"asn1-combinators"
|
||||
"logs"
|
||||
"cmdliner"
|
||||
"cmdliner" {>= "1.1.0"}
|
||||
"uri"
|
||||
"fmt" {>= "0.8.7"}
|
||||
"omd"
|
||||
|
|
|
|||
Loading…
Reference in a new issue