builder-web/bin/builder_db.ml

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