274 lines
9.3 KiB
OCaml
274 lines
9.3 KiB
OCaml
open Rresult.R.Infix
|
|
|
|
let or_die exit_code = function
|
|
| Ok r -> r
|
|
| Error e ->
|
|
Format.eprintf "Database error: %a" Caqti_error.pp e;
|
|
exit exit_code
|
|
|
|
let save_data outputdir (filepath, data) =
|
|
let localpath = Fpath.(outputdir // filepath) in
|
|
(* FIXME: return an error?! *)
|
|
let () =
|
|
match Bos.OS.File.exists localpath with
|
|
| Ok false ->
|
|
Logs.warn (fun m -> m "artifact file %a does not exist in %a"
|
|
Fpath.pp filepath Fpath.pp outputdir)
|
|
| Error (`Msg e) ->
|
|
Logs.warn (fun m -> m "artifact file error %a: %s"
|
|
Fpath.pp localpath e)
|
|
| Ok true -> ()
|
|
in
|
|
(filepath, localpath, data)
|
|
|
|
let get_by_uuid uuid (module Db : Caqti_blocking.CONNECTION) =
|
|
Uuidm.of_string uuid |> Option.to_result ~none:"bad uuid" >>= fun uuid ->
|
|
Db.find_opt Builder_db.Build.get_by_uuid uuid
|
|
|> Result.map_error (fun e ->
|
|
Fmt.strf "Error getting build %a: %a" Uuidm.pp uuid Caqti_error.pp e)
|
|
|
|
let db_add_build (job, uuid, console, start, finish, result, artifacts)
|
|
(input_files : (Fpath.t * Fpath.t * string) list)
|
|
(module Db : Caqti_blocking.CONNECTION) =
|
|
let open Builder_db in
|
|
let job_name = job.Builder.name in
|
|
Db.exec Job.try_add job_name >>= fun () ->
|
|
Db.find Job.get_id_by_name job_name >>= fun job_id ->
|
|
Db.exec Build.add { Build.uuid; start; finish; result; console;
|
|
script = job.Builder.script; job_id } >>= fun () ->
|
|
Db.find last_insert_rowid () >>= fun id ->
|
|
List.fold_left
|
|
(fun r (filepath, localpath, data) ->
|
|
r >>= fun () ->
|
|
let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
|
|
Db.exec Build_artifact.add ({ filepath; localpath; sha256 }, id))
|
|
(Ok ())
|
|
artifacts >>= fun () ->
|
|
List.fold_left
|
|
(fun r (filepath, localpath, data) ->
|
|
r >>= fun () ->
|
|
let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
|
|
Db.exec Build_file.add ({ filepath; localpath; sha256 }, id))
|
|
(Ok ())
|
|
input_files
|
|
|
|
let add_build conn builddir =
|
|
let f = Fpath.(builddir / "full") in
|
|
let outputdir = Fpath.(builddir / "output") in
|
|
let inputdir = Fpath.(builddir / "input") in
|
|
let uuid = Fpath.basename builddir in
|
|
match get_by_uuid uuid conn with
|
|
| Error e -> Logs.warn (fun m -> m "%s" e)
|
|
| Ok (Some _) -> Logs.debug (fun m -> m "Skipping %a, already in database" Fpath.pp builddir)
|
|
| Ok None ->
|
|
Logs.debug (fun m -> m "Adding build %a" Fpath.pp builddir);
|
|
match Bos.OS.File.read f with
|
|
| Error (`Msg e) ->
|
|
Logs.warn (fun m -> m "Error getting build %a: %s"
|
|
Fpath.pp builddir e)
|
|
| Ok contents ->
|
|
match Builder.Asn.exec_of_cs (Cstruct.of_string contents) with
|
|
| Error (`Msg e) ->
|
|
Logs.warn (fun m -> m "Error parsing build file %a: %s"
|
|
Fpath.pp f e)
|
|
| Ok (job, uuid, console, start, finish, result, data) ->
|
|
let data = List.map (save_data outputdir) data in
|
|
let input_files = List.map (save_data inputdir) job.Builder.files in
|
|
match db_add_build (job, uuid, console, start, finish, result, data) input_files conn with
|
|
| Error e ->
|
|
Logs.err (fun m -> m "Error inserting build %a: %a"
|
|
Fpath.pp builddir Caqti_error.pp e)
|
|
| Ok () -> ()
|
|
|
|
let add_job conn jobdir =
|
|
Logs.debug (fun m -> m "Adding job %a" Fpath.pp jobdir);
|
|
match Bos.OS.Dir.contents jobdir with
|
|
| Error (`Msg e) ->
|
|
Logs.warn (fun m ->
|
|
m "Error getting job %s: %s\n" (Fpath.basename jobdir) e)
|
|
| Ok builds ->
|
|
List.iter (add_build conn) builds
|
|
|
|
let add_jobs conn datadir =
|
|
Bos.OS.Dir.contents datadir >>|
|
|
List.filter (fun f -> not Fpath.(equal (v "state") f)) >>|
|
|
List.iter (add_job conn)
|
|
|
|
let add () dbpath datadir =
|
|
let datadir = Fpath.v datadir in
|
|
Logs.debug (fun m -> m "Data dir: %a" Fpath.pp datadir);
|
|
let conn =
|
|
match Caqti_blocking.connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ()) with
|
|
| Error e ->
|
|
Logs.err (fun m -> m "Error connecting to database: %a" Caqti_error.pp e);
|
|
exit 1
|
|
| Ok conn ->
|
|
conn
|
|
in
|
|
match add_jobs conn datadir with
|
|
| Ok () -> ()
|
|
| Error (`Msg e) ->
|
|
Logs.err (fun m -> m "Error getting jobs: %s\n" e);
|
|
exit 2
|
|
|
|
let do_migrate dbpath =
|
|
Caqti_blocking.connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ())
|
|
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
|
|
List.fold_left
|
|
(fun r migrate ->
|
|
r >>= fun () ->
|
|
Logs.debug (fun m -> m "Executing migration query: %a" Caqti_request.pp migrate);
|
|
Db.exec migrate ())
|
|
(Ok ())
|
|
Builder_db.migrate
|
|
|
|
let migrate () dbpath =
|
|
or_die 1 (do_migrate dbpath)
|
|
|
|
let user_mod action dbpath password_iter username =
|
|
let r =
|
|
Caqti_blocking.connect
|
|
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
|
|
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
|
|
print_string "Password: ";
|
|
flush stdout;
|
|
(* FIXME: getpass *)
|
|
let password = read_line () in
|
|
let user_info = Builder_web_auth.hash ?password_iter ~username ~password () in
|
|
match action with
|
|
| `Add ->
|
|
Db.exec Builder_db.User.add user_info
|
|
| `Update ->
|
|
Db.exec Builder_db.User.update_user user_info
|
|
in
|
|
or_die 1 r
|
|
|
|
let user_add () dbpath username = user_mod `Add dbpath username
|
|
|
|
let user_update () dbpath username = user_mod `Update dbpath username
|
|
|
|
let user_list () dbpath =
|
|
let r =
|
|
Caqti_blocking.connect
|
|
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
|
|
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
|
|
Db.iter_s Builder_db.User.get_all
|
|
(fun username -> Ok (print_endline username))
|
|
()
|
|
in
|
|
or_die 1 r
|
|
|
|
let user_remove () dbpath username =
|
|
let r =
|
|
Caqti_blocking.connect
|
|
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
|
|
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
|
|
Db.exec Builder_db.User.remove_user username
|
|
in
|
|
or_die 1 r
|
|
|
|
let help man_format cmds = function
|
|
| None -> `Help (man_format, None)
|
|
| Some cmd ->
|
|
if List.mem cmd cmds
|
|
then `Help (man_format, Some cmd)
|
|
else `Error (true, "Unknown command: " ^ cmd)
|
|
|
|
let dbpath =
|
|
let doc = "sqlite3 database path" in
|
|
Cmdliner.Arg.(value &
|
|
opt non_dir_file "builder.sqlite3" &
|
|
info ~doc ["dbpath"])
|
|
|
|
let dbpath_new =
|
|
let doc = "sqlite3 database path" in
|
|
Cmdliner.Arg.(value &
|
|
opt string "builder.sqlite3" &
|
|
info ~doc ["dbpath"])
|
|
|
|
let username =
|
|
let doc = "username" in
|
|
Cmdliner.Arg.(required &
|
|
pos 0 (some string) None &
|
|
info ~doc ~docv:"USERNAME" [])
|
|
|
|
let password_iter =
|
|
let doc = "password hash count" in
|
|
Cmdliner.Arg.(value &
|
|
opt (some int) None &
|
|
info ~doc ["hash-count"])
|
|
|
|
let datadir =
|
|
let doc = Cmdliner.Arg.info ~doc:"builder data dir" ["datadir"] in
|
|
Cmdliner.Arg.(value &
|
|
opt dir "/var/db/builder/" doc)
|
|
|
|
let setup_log =
|
|
let setup_log level =
|
|
Logs.set_level level;
|
|
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ());
|
|
Logs.debug (fun m -> m "Set log level %s" (Logs.level_to_string level))
|
|
in
|
|
Cmdliner.Term.(const setup_log $ Logs_cli.level ())
|
|
|
|
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 add_cmd =
|
|
let doc = "populates database with builder data" in
|
|
let man =
|
|
[ `S "DESCRIPTION";
|
|
`P "Scrape builder data directory information and insert into builder-web database.";
|
|
`P "It assumes the `full' files are stored in a directory hierarchy of the following shape:";
|
|
`Pre "/path/to/datadir/JOB-NAME/BUILD-UUID/full";
|
|
`P "Before parsing, The UUID in the filesystem is looked up in the database \
|
|
to see if already exists.\
|
|
It is assumed the UUIDs correspond.";
|
|
]
|
|
in
|
|
(Cmdliner.Term.(pure add $ setup_log $ dbpath $ datadir),
|
|
Cmdliner.Term.info ~doc ~man "add")
|
|
|
|
let user_add_cmd =
|
|
let doc = "add a user" in
|
|
(Cmdliner.Term.(pure user_add $ setup_log $ dbpath $ password_iter $ username),
|
|
Cmdliner.Term.info ~doc "user-add")
|
|
|
|
let user_update_cmd =
|
|
let doc = "update a user password" in
|
|
(Cmdliner.Term.(pure user_update $ setup_log $ dbpath $ password_iter $ username),
|
|
Cmdliner.Term.info ~doc "user-update")
|
|
|
|
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 user_list_cmd =
|
|
let doc = "list all users" in
|
|
(Cmdliner.Term.(pure user_list $ setup_log $ dbpath),
|
|
Cmdliner.Term.info ~doc "user-list")
|
|
|
|
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" [])
|
|
in
|
|
let doc = "Builder database help" in
|
|
Cmdliner.Term.(ret (const help $ man_format $ choice_names $ topic)),
|
|
Cmdliner.Term.info ~doc "help"
|
|
|
|
let default_cmd =
|
|
let doc = "Builder database command" in
|
|
Cmdliner.Term.(ret (const help $ man_format $ choice_names $ const None)),
|
|
Cmdliner.Term.info ~doc "builder-db"
|
|
|
|
let () =
|
|
Mirage_crypto_rng_unix.initialize ();
|
|
Cmdliner.Term.eval_choice
|
|
default_cmd
|
|
[help_cmd; add_cmd; migrate_cmd;
|
|
user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd]
|
|
|> Cmdliner.Term.exit
|