diff --git a/bin/builder_system.ml b/bin/builder_system.ml index 551ca84..0c3bd1c 100644 --- a/bin/builder_system.ml +++ b/bin/builder_system.ml @@ -10,3 +10,8 @@ let default_datadir = match Lazy.force uname with | `FreeBSD -> "/var/db/builder-web" | `Linux -> "/var/lib/builder-web" + +let default_configdir = + match Lazy.force uname with + | `FreeBSD -> "/usr/local/etc/builder-web" + | `Linux -> "/etc/builder-web" diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 599e450..8b04792 100644 --- a/bin/builder_web_app.ml +++ b/bin/builder_web_app.ml @@ -78,9 +78,10 @@ let init_influx name data = in Lwt.async report -let setup_app level influx port host datadir = +let setup_app level influx port host datadir configdir = let dbpath = Printf.sprintf "%s/builder.sqlite3" datadir in let datadir = Fpath.v datadir in + let configdir = Fpath.v configdir in let () = init_influx "builder-web" influx in match Builder_web.init dbpath datadir with | Error (#Caqti_error.load as e) -> @@ -96,7 +97,7 @@ let setup_app level influx port host datadir = @@ Dream.logger @@ Dream.sql_pool ("sqlite3:" ^ dbpath) @@ Http_status_metrics.handle - @@ Builder_web.add_routes datadir + @@ Builder_web.add_routes datadir configdir @@ Builder_web.not_found open Cmdliner @@ -124,6 +125,10 @@ let datadir = let doc = "data directory" in Arg.(value & opt dir Builder_system.default_datadir & info [ "d"; "datadir" ] ~doc) +let configdir = + let doc = "config directory" in + Arg.(value & opt dir Builder_system.default_configdir & info [ "c"; "configdir" ] ~doc) + let port = let doc = "port" in Arg.(value & opt int 3000 & info [ "p"; "port" ] ~doc) @@ -137,7 +142,7 @@ 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) in + 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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index b7fe5e4..325f006 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -106,7 +106,7 @@ let dream_svg ?status ?code ?headers body = |> Dream.with_header "Content-Type" "image/svg+xml" |> Lwt.return -let add_routes datadir = +let add_routes datadir configdir = let datadir_global = Dream.new_global ~name:"datadir" (fun () -> datadir) in let builds req = @@ -404,7 +404,7 @@ let add_routes datadir = let datadir = Dream.global datadir_global req in (Lwt.return (Dream.local Authorization.user_info_local req |> Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) -> - Dream.sql req (Model.add_build datadir user_id exec)) + Dream.sql req (Model.add_build ~configdir ~datadir user_id exec)) |> if_error "Internal server error" ~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e)) >>= fun () -> Dream.respond "" |> Lwt_result.ok @@ -502,7 +502,7 @@ let add_routes datadir = in (Lwt.return (Dream.local Authorization.user_info_local req |> Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) -> - Dream.sql req (Model.add_build datadir user_id exec)) + Dream.sql req (Model.add_build ~configdir ~datadir user_id exec)) |> if_error "Internal server error" ~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e)) >>= fun () -> Dream.respond "" |> Lwt_result.ok diff --git a/lib/model.ml b/lib/model.ml index 78db10a..4a18a74 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -31,7 +31,7 @@ let read_file datadir filepath = Lwt_result.return data) (function | Unix.Unix_error (e, _, _) -> - Logs.warn (fun m -> m "Error reading local file %a: %s" + Log.warn (fun m -> m "Error reading local file %a: %s" Fpath.pp filepath (Unix.error_message e)); Lwt.return_error (`File_error filepath) | e -> Lwt.fail e) @@ -301,7 +301,8 @@ let prepare_staging staging_dir = else Lwt_result.return () let add_build - datadir + ~configdir + ~datadir user_id ((job : Builder.script_job), uuid, console, start, finish, result, raw_artifacts) (module Db : CONN) = @@ -383,17 +384,20 @@ let add_build artifacts >>= fun () -> Db.collect_list Build_artifact.get_all_by_build id >>= fun artifacts -> (match List.filter (fun (_, p) -> Fpath.(is_prefix (v "bin/") p.filepath)) artifacts with - | [ (build_artifact_id, _) ] -> Db.exec Build.set_main_binary (id, build_artifact_id) + | [ (build_artifact_id, p) ] -> + Db.exec Build.set_main_binary (id, build_artifact_id) >|= fun () -> + Some p | [] -> Log.debug (fun m -> m "Zero binaries for build %a" Uuidm.pp uuid); - Lwt_result.return () + Lwt_result.return None | xs -> Log.warn (fun m -> m "Multiple binaries for build %a: %a" Uuidm.pp uuid Fmt.(list ~sep:(any ",") Fpath.pp) (List.map (fun (_, a) -> a.filepath) xs)); - Lwt_result.return ()) >>= fun () -> + Lwt_result.return None) >>= fun main_binary -> Db.commit () >>= fun () -> - commit_files datadir staging_dir job_name uuid + commit_files datadir staging_dir job_name uuid >|= fun () -> + main_binary in Lwt_result.bind_lwt_err (or_cleanup r) (fun e -> @@ -402,4 +406,46 @@ let add_build Result.iter_error (fun e' -> Log.err (fun m -> m "Failed rollback: %a" Caqti_error.pp e')) r; - e)) + e)) >>= function + | None -> Lwt.return (Ok ()) + | Some p -> + let main_binary = p.localpath + and `Hex sha256 = Hex.of_cstruct p.sha256 + and uuid = Uuidm.to_string uuid + and time = + let (y, m, d), ((hh, mm, ss), _) = Ptime.to_date_time start in + Printf.sprintf "%04d%02d%02d%02d%02d%02d" y m d hh mm ss + and job = job.name + in + let args = + String.concat " " + (List.map (fun s -> "\"" ^ String.escaped s ^ "\"") + [ "--build-time=" ^ time ; "--sha256=" ^ sha256 ; "--job=" ^ job ; + "--uuid=" ^ uuid ; Fpath.(to_string (datadir // main_binary)) ]) + in + Log.debug (fun m -> m "executing hooks with %s" args); + let dir = Fpath.(configdir / "upload-hooks") in + (try + Lwt.return (Ok (Some (Unix.opendir (Fpath.to_string dir)))) + with + Unix.Unix_error _ -> Lwt.return (Ok None)) >>= function + | None -> Lwt.return (Ok ()) + | Some dh -> + try + let is_executable file = + let st = Unix.stat (Fpath.to_string file) in + st.Unix.st_perm land 0o111 = 0o111 && + st.Unix.st_kind = Unix.S_REG + in + let rec go () = + let next_file = Unix.readdir dh in + let file = Fpath.(dir / next_file) in + if is_executable file then + ignore (Sys.command (Fpath.to_string file ^ " " ^ args ^ " &")); + go () + in + go () + with + | End_of_file -> + Unix.closedir dh; + Lwt.return (Ok ()) diff --git a/lib/model.mli b/lib/model.mli index a7e00d4..0e36ee7 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -93,7 +93,8 @@ val user : string -> Caqti_lwt.connection -> val authorized : [`user] Builder_db.id -> string -> Caqti_lwt.connection -> (unit, [> Caqti_error.call_or_retrieve | `Msg of string ]) result Lwt.t val add_build : - Fpath.t -> + configdir:Fpath.t -> + datadir:Fpath.t -> [`user] Builder_db.id -> (Builder.script_job * Uuidm.t * (int * string) list * Ptime.t * Ptime.t * Builder.execution_result * (Fpath.t * string) list) ->