execute all executables in <conigdir>/upload-hooks when an upload succeeded

Only uploads with a single main binary invoke the hooks (since they use the
main_binary)

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"

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

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

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 ())

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