robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merged with main/master

Browse source
This commit is contained in:
rand00 2022-03-16 12:10:25 +01:00
commit 60ee718160
6 changed files with 156 additions and 105 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

104
bin/builder_db_app.ml
View file

@ -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

23
bin/builder_web_app.ml
View file

@ -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

80
bin/migrations/builder_migrations.ml
View file

@ -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

48
bin/visualizations/builder_viz.ml
View file

@ -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

2
builder-web.opam
View file

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

4
test/test_builder_db.ml
View file

@ -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.)