robur/blog.robur.coop
4
0
Fork 1
Code Issues 2 Pull requests Projects Releases Packages Wiki Activity Actions

Use a custom git commit message

Browse source 
Requires yocaml#76b27c6282ff343e618f53c03153008a7ee2366e or later.
This commit is contained in:
Reynir Björnsson 2023-11-15 17:01:28 +01:00
parent 9c1c28a4ef
commit 60e9541a70
1 changed files with 17 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
src/blogger.ml
View file

@ -125,6 +125,20 @@ let run_git_config key = function
| Ok (value, _) -> Some value | Ok (value, _) -> Some value
| Error _ -> None) | Error _ -> None)
let run_git_rev_parse default =
let open Bos in
let value = OS.Cmd.run_out Cmd.(v "git" % "rev-parse" % "HEAD") in
match OS.Cmd.out_string value with
| Ok (value, (_, `Exited 0)) -> value
| Ok (value, (run_info, _)) ->
Logs.warn (fun m -> m "Failed to get commit id: %a: %s"
Cmd.pp (OS.Cmd.run_info_cmd run_info)
value);
default
| Error `Msg e ->
Logs.warn (fun m -> m "Failed to get commit id: %s" e);
default
let get_name_and_email name email = let get_name_and_email name email =
let name = run_git_config "user.name" name in let name = run_git_config "user.name" name in
let email = run_git_config "user.email" email in let email = run_git_config "user.email" email in
@ -144,12 +158,14 @@ let name_and_email =
let build_and_push _quiet remote (author, email) hook = let build_and_push _quiet remote (author, email) hook =
let fiber () = let fiber () =
let open Lwt.Syntax in let open Lwt.Syntax in
let commit_id = run_git_rev_parse "an unknown state" in
let comment = Printf.sprintf "Built from %s" commit_id in
let* ctx = unix_ctx_with_ssh () in let* ctx = unix_ctx_with_ssh () in
let* res = let* res =
Yocaml_git.execute Yocaml_git.execute
(module Yocaml_unix) (module Yocaml_unix)
(module Pclock) (module Pclock)
~ctx ?author ?email remote (program ~target:"") ~ctx ?author ?email ~comment remote (program ~target:"")
in in
match res with match res with
| Error (`Msg err) -> Fmt.failwith "build-and-push: %s." err | Error (`Msg err) -> Fmt.failwith "build-and-push: %s." err