diff options
| -rw-r--r-- | context_mirror_bot.ml | 155 |
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 () |