add sync operation

1 files changed, 43 insertions, 1 deletions

diff --git a/context_mirror_bot.ml b/context_mirror_bot.ml
index 5da9172..0053126 100644
--- a/context_mirror_bot.ml
+++ b/context_mirror_bot.ml
@@ -76,7 +76,8 @@ let sources =
 let bot_owner       = "Philipp Gesang"
 let owner_contact   = "phg42.2a@gmail.com"
 
-let repo_root       = "/home/mirror/mirror"
+(*let repo_root       = "/home/mirror/mirror"*)
+let repo_root       = "/home/phg/src/mirror"
 let repo_subdir     = "context-git"
 let repo_dir        = Filename.concat repo_root repo_subdir
 let git_dir         = Filename.concat repo_dir ".git"
@@ -295,6 +296,8 @@ module Git : sig
   val import : extract_status -> import_status
   val push : string -> status
   val install_files : unit -> unit
+  val fetch : string -> unit
+  val pull : ?rbr:string -> string -> unit
   exception Git_checkout_failed of string
 end = struct
   exception Git_init_failed
@@ -303,6 +306,8 @@ end = struct
   exception Git_checkout_failed of string
   exception Git_branch_failed of string
   exception Git_commit_failed of string
+  exception Git_fetch_failed of string
+  exception Git_pull_failed of string
   exception Import_files_failed
   exception Copy_ssh_key_failed
 
@@ -349,6 +354,29 @@ end = struct
       | Bad _ -> raise Git_init_failed
       | Good -> install_files (); true
 
+  let fetch remote =
+    msg ("Fetching remote " ^ 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);
+    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)
+    | None -> (* branch exists, do regular checkout *)
+        begin
+          msg ~lev:1 (Printf.sprintf "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)
+    | None -> raise (Git_pull_failed (Printf.sprintf "%s (remote: %s)" br rbr))
+
   let last_commit br =
     match list_of_pipe ("git checkout " ^ br) with
     | None -> raise (Git_checkout_failed br)
@@ -706,6 +734,19 @@ let run_update () =
   in
   ()
 
+let run_sync () =
+  Git.fetch "mirror";
+  Git.fetch "garden";
+  Git.pull "beta";
+  Git.pull "current";
+  Git.pull ~rbr:"garden/master" "garden-master";
+  let name = "garden-master" in
+  msg "Pushing changes from context garden repo to mirror";
+  match Git.push name with
+    | Good -> msg "Success!"
+    | Bad errmsg ->
+        err (Printf.sprintf "Failed to push %s: “%s”" name errmsg)
+
 let run_cleanup () =
   forall_sources
     (fun src ->
@@ -751,6 +792,7 @@ let parse_argv () =
     ("--check",    Arg.Unit (fun () -> j.kind <- Action ("status"  , run_status  ); ()), "check source timestamps");
     ("--status",   Arg.Unit (fun () -> j.kind <- Action ("check"   , run_check   ); ()), "print status of local repo");
     ("--update",   Arg.Unit (fun () -> j.kind <- Action ("update"  , run_update  ); ()), "update from sources");
+    ("--sync",     Arg.Unit (fun () -> j.kind <- Action ("sync"    , run_sync    ); ()), "sync local repo");
     ("--prepare",  Arg.Unit (fun () -> j.kind <- Action ("prepare" , run_prepare ); ()), "prepare local repository");
     ("--download", Arg.Unit (fun () -> j.kind <- Action ("download", run_download); ()), "download source packages");
     ("--clean",    Arg.Unit (fun () -> j.kind <- Action ("cleanup" , run_cleanup ); ()), "remove leftover files");