summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--context_mirror_bot.ml155
1 files changed, 79 insertions, 76 deletions
diff --git a/context_mirror_bot.ml b/context_mirror_bot.ml
index 2ac9d97..749c0d3 100644
--- a/context_mirror_bot.ml
+++ b/context_mirror_bot.ml
@@ -80,7 +80,8 @@ let sources =
let bot_owner = "Philipp Gesang"
let owner_contact = "phg+robots@phi-gamma.net"
-let repo_root = "/home/mirror/mirror"
+(*let repo_root = "/home/mirror/mirror"*)
+let repo_root = "/home/phg/src/context-mirror"
let repo_subdir = "context-git"
let repo_dir = Filename.concat repo_root repo_subdir
let git_dir = Filename.concat repo_dir ".git"
@@ -189,9 +190,15 @@ let verbosity = ref 0
let set_verbosity n = verbosity := n
-let msg ?lev:(lev=0) str =
- if !verbosity >= lev then
- Printf.printf "[bot %s] %s\n%!" (timestamp ()) str
+let msg ?lev:(lev=0) =
+ Printf.(
+ if !verbosity < lev then
+ ifprintf stdout
+ else
+ let fin oc = output_char oc '\n'; flush oc in
+ let pp oc = kfprintf fin stdout in
+ kfprintf pp stdout "[bot %s] %!" (timestamp ())
+ )
let err str =
Printf.eprintf "[bot %s: error] %s\n%!" (timestamp ()) str
@@ -264,7 +271,7 @@ let list_of_pipe cmd =
* keep the stderr around so as to prevent error messages
* from flooding the terminal.
*)
- msg ~lev:1 (Printf.sprintf "exec “%s”" cmd);
+ msg ~lev:1 "exec “%s”" cmd;
let (so, si, se) = open_process_full cmd (environment ()) in
let rec aux acc =
try
@@ -330,7 +337,7 @@ end = struct
exception Copy_ssh_key_failed
let write_config () =
- msg ~lev:1 ("Write git configuration to " ^ git_config_file);
+ msg ~lev:1 "Write git configuration to [%s]" git_config_file;
let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc] 0o600 git_config_file in
output_string oc gitconfig;
close_out oc
@@ -362,7 +369,7 @@ end = struct
aux static_files
let init () =
- msg ("Initializing new repository with state from " ^ bootstrap_repo);
+ msg "Initializing new repository with state from [%s]" bootstrap_repo;
match exec_commands [
"git init";
"git remote add initial-source " ^ bootstrap_repo;
@@ -373,26 +380,26 @@ end = struct
| Good -> install_files (); true
let fetch remote =
- msg ("Fetching remote " ^ remote);
+ msg "Fetching remote [%s]" remote;
match list_of_pipe ("git fetch " ^ remote) with
| None -> raise (Git_fetch_failed remote)
| Some _ -> ()
let pull ?rbr:(rbr="mirror") br =
- msg ~lev:1 (Printf.sprintf "tentatively checkout new branch %s from remote %s" br rbr);
+ msg ~lev:1 "tentatively checkout new branch [%s] from remote [%s]" br rbr;
let () = match list_of_pipe (* this fails if the branch already exists *)
(Printf.sprintf "git checkout -b \"%s\" \"%s\"" br rbr) with
- | Some _ -> msg (Printf.sprintf "new branch %s created" br)
+ | Some _ -> msg "new branch [%s] created" br
| None -> (* branch exists, do regular checkout *)
begin
- msg ~lev:1 (Printf.sprintf "branch %s already exists; performing normal checkout" br);
+ msg ~lev:1 "branch [%s] already exists; performing normal checkout" br;
match list_of_pipe (Printf.sprintf "git checkout \"%s\"" br) with
| None -> raise (Git_checkout_failed br)
| Some _ -> ()
end
in
match list_of_pipe ("git pull --ff") with
- | Some _ -> msg ~lev:1 (Printf.sprintf "pulled branch %s just fine" br)
+ | Some _ -> msg ~lev:1 "pulled branch %s just fine" br
| None -> raise (Git_pull_failed (Printf.sprintf "%s (remote: %s)" br rbr))
let last_commit br =
@@ -412,9 +419,9 @@ end = struct
end
let set_path path =
- msg ~lev:1 (Printf.sprintf "GIT_WORK_TREE=%s" path);
- msg ~lev:1 (Printf.sprintf "GIT_DIR=%s" git_dir);
- msg ~lev:1 (Printf.sprintf "GIT_SSH=%s" ssh_wrapper);
+ msg ~lev:1 "GIT_WORK_TREE=%s" path;
+ msg ~lev:1 "GIT_DIR=%s" git_dir;
+ msg ~lev:1 "GIT_SSH=%s" ssh_wrapper;
Unix.putenv "GIT_WORK_TREE" path;
Unix.putenv "GIT_DIR" git_dir;
Unix.putenv "GIT_SSH" ssh_wrapper
@@ -439,11 +446,8 @@ end = struct
| None -> true
| Some _ -> false
in
- msg (Printf.sprintf
- "Importing %s into %s branch %s."
- dst
- (if needs_branch then "new" else "old")
- branch);
+ msg "Importing [%s] into [%s] branch [%s]."
+ dst (if needs_branch then "new" else "old") branch;
match exec_commands [
(* remove current contents and replace it with the extracted files *)
(Printf.sprintf "rm -rf -- %s/*" repo_dir);
@@ -511,15 +515,15 @@ let ensure_dir d =
| _ -> raise (Bad_file "“%d” is not a directory.")
with
| Unix_error (err, _, _) when err = ENOENT ->
- msg ("Creating directory " ^ d);
- FileUtil.mkdir ~parent:true d
+ msg "Creating directory [%s]" d;
+ FileUtil.mkdir ~parent:true d
let ensure_dst_repo d =
if not (Git.is_repo ()) then
if Git.init () then `New else `Fail
else
begin
- msg ("Found existing repository at " ^ d);
+ msg "Found existing repository at [%s]" d;
`Exists
end
@@ -528,10 +532,10 @@ let copy_static_files () =
(fun (src, _) ->
let dst = Filename.concat repo_root src in
if file_exists dst then
- msg ~lev:1 (Printf.sprintf "File %s exists at %s, skipping." src dst)
+ msg ~lev:1 "File [%s] exists at [%s], skipping." src dst
else
begin
- msg ~lev:1 (Printf.sprintf "Install %s exists to %s" src dst);
+ msg ~lev:1 "Install [%s] exists to [%s]" src dst;
match list_of_pipe (Printf.sprintf "cp -f %s %s" src dst) with
| None -> raise (Prepare_failed (Printf.sprintf "Error preparing file %s." src))
| Some _ -> ()
@@ -555,7 +559,6 @@ let user_agent = Printf.sprintf
bot_owner
owner_contact
-
let grab url writer =
let open Curl in
let c = init () in
@@ -620,10 +623,10 @@ let extract_timestamp src =
let date_changed ts src =
let repo_ts = extract_timestamp src in
- msg (Printf.sprintf "ts: %s; repo_ts: %s -> %s"
+ msg "ts: %s; repo_ts: %s -> %s"
(format_time ts)
(format_time repo_ts)
- (if ts <> repo_ts then "changed" else "unchanged"));
+ (if ts <> repo_ts then "changed" else "unchanged");
if ts <> repo_ts then
Changed repo_ts
else
@@ -634,10 +637,10 @@ let download_zipball src =
let dst = Filename.concat repo_root (src.name ^ ".zip") in
if file_exists dst then
begin
- msg (Printf.sprintf "Destination file %s exists, removing." dst);
+ msg "Destination file [%s] exists, removing." dst;
Unix.unlink dst
end;
- msg (Printf.sprintf "Downloading source archive %s" src.url);
+ msg "Downloading source archive [%s]" src.url;
grab_file src.url dst;
dst
@@ -660,7 +663,7 @@ let handle_zipball = function
| Stagnation -> Extract_ignored "Nothing todo."
| New_zip download ->
begin
- msg (Printf.sprintf "Extracting %s to %s" download.file download.dst);
+ msg "Extracting [%s] to [%s]" download.file download.dst;
match unzip download.file download.dst with
| Some _ -> Path download
| None -> Extract_failed download.branch
@@ -675,31 +678,30 @@ let usage = Printf.sprintf "Usage:
" self
let run_status () =
- if not (dir_exists repo_dir) then msg ("No directory at " ^ repo_dir) else
+ if not (dir_exists repo_dir) then
+ msg "No directory at [%s]" repo_dir else
begin
match list_of_pipe "git branch -a" with
- | None -> msg ("No git repository at " ^ repo_dir)
- | Some all_branches ->
- let known = List.fold_left
- (fun acc line ->
- let l = String.length line in
- if l < 3 then acc else
- begin
- let br = String.sub line 2 (l - 2) in
- if source_known br sources then
- br :: acc
- else
- acc
- end) [] all_branches
- in
- List.iter
- (fun br ->
- let tm = Git.last_commit br in
- msg (Printf.sprintf
- "Found branch %7s with timestamp %s."
- br
- (format_time tm)))
- known
+ | None -> msg "No git repository at [%s]" repo_dir
+ | Some all_branches ->
+ let known = List.fold_left
+ (fun acc line ->
+ let l = String.length line in
+ if l < 3 then acc else
+ begin
+ let br = String.sub line 2 (l - 2) in
+ if source_known br sources then
+ br :: acc
+ else
+ acc
+ end) [] all_branches
+ in
+ List.iter
+ (fun br ->
+ let tm = Git.last_commit br in
+ msg "Found branch %7s with timestamp %s."
+ br (format_time tm))
+ known
end
let run_check () =
@@ -707,26 +709,27 @@ let run_check () =
(fun src ->
let local_ts = Git.last_commit src.name in
let upstream_ts = extract_timestamp src in
- msg (Printf.sprintf "%s:" src.name);
- msg (Printf.sprintf " local: %s" (format_time local_ts));
- msg (Printf.sprintf " upstream: %s%s"
+ msg "%s:" src.name;
+ msg " local: %s" (format_time local_ts);
+ msg " upstream: %s%s"
(format_time upstream_ts)
- (if local_ts <> upstream_ts then " (new)" else "")))
+ (if local_ts <> upstream_ts then " (new)" else ""))
let run_prepare () =
ensure_dir repo_dir;
copy_static_files ();
match ensure_dst_repo repo_dir with
- | `New -> msg (Printf.sprintf "Created new local repository at %s." repo_dir)
- | `Exists -> msg (Printf.sprintf
- "Found local repository at %s,%s"
- repo_dir
- (List.fold_left
- (fun acc src -> (acc ^ Printf.sprintf
- " %s: %s"
- src.name
- (format_time (Git.last_commit src.name))))
- "" sources))
+ | `New -> msg "Created new local repository at [%s]." repo_dir
+ | `Exists ->
+ msg
+ "Found local repository at %s,%s"
+ repo_dir
+ (List.fold_left
+ (fun acc src -> (acc ^ Printf.sprintf
+ " %s: %s"
+ src.name
+ (format_time (Git.last_commit src.name))))
+ "" sources)
| `Fail -> raise (Bad_env "Failed to initialize destination repository.")
let run_download () =
@@ -744,10 +747,10 @@ let run_update () =
let _ = List.iter
(fun st ->
match st with
- | Import_ignored rationale -> msg rationale
+ | Import_ignored rationale -> msg "%s" rationale
| Import_failed errmsg -> err errmsg
| Imported br ->
- msg (Printf.sprintf "Pushing %s to mirrors ..." br);
+ msg "Pushing [%s] to mirrors ..." br;
match Git.push br with
| Good -> msg "Success!"
| Bad errmsg ->
@@ -773,9 +776,9 @@ let run_cleanup () =
forall_sources
(fun src ->
let name = src.name in
- msg (Printf.sprintf "Removing %s ->" name);
+ msg "Removing [%s] ->" name;
List.iter (fun p ->
- msg (Printf.sprintf " %s" p);
+ msg " [%s]" p;
ignore (list_of_pipe ("rm -rf -- " ^ p)))
[ mk_tmp_webpage name;
Filename.concat repo_root name;
@@ -785,11 +788,11 @@ let run_push () =
forall_sources
(fun src ->
let name = src.name in
- msg (Printf.sprintf "Pushing branch %s to mirrors ..." name);
+ msg "Pushing branch [%s] to mirrors ..." name;
match Git.push name with
- | Good -> msg "Success!"
- | Bad errmsg ->
- err (Printf.sprintf "Failed to push %s: “%s”" name errmsg))
+ | Good -> msg "Success!"
+ | Bad errmsg ->
+ err (Printf.sprintf "Failed to push [%s]: “%s”" name errmsg))
let run_files () = Git.install_files ()