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 "/var/db/builder-web/builder.sqlite3" & info ~doc ["dbpath"]) let dbpath_new = let doc = "sqlite3 database path" in Cmdliner.Arg.(value & opt string "/var/db/builder-web/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