Add local git bridge

Normally, we use datakit-github to monitor the state of a remote
repository on GitHub and use that as the input to the CI. When getting
started with DataKitCI it is more convenient to be able to monitor a
local Git repository.

Makefile

@@ -31,6 +31,9 @@ server:
 github:
 	ocaml pkg/pkg.ml build -n datakit-github -q
 
+bridge-local-git:
+	ocaml pkg/pkg.ml build -n datakit-bridge-local-git -q
+
 prometheus-app:
 	ocaml pkg/pkg.ml build -n prometheus-app -q --tests true
 	ocaml pkg/pkg.ml test _build/prometheus/tests/test.native

_tags

@@ -1,6 +1,6 @@
 true: -traverse
 true : bin_annot, safe_string
-not <ci/**>: warn_error(+1..49-3), warn(A-4-41-44)
+not <ci/**> and not <bridge/local/**>: warn_error(+1..49-3), warn(A-4-41-44)
 not <prometheus/**>: package(bytes lwt astring logs result cstruct fmt rresult)
 <ci/static/**>: traverse
 

bridge/github/main.ml

@@ -2,10 +2,10 @@ open Lwt.Infix
 open Astring
 open Result
 
-let src = Logs.Src.create "gh-bridge" ~doc:"Github bridge for Datakit "
+let src = Logs.Src.create "gh-bridge" ~doc:"Github bridge for Datakit"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-let src9p = Logs.Src.create "g9p" ~doc:"Github bridge for Datakit (9p) "
+let src9p = Logs.Src.create "g9p" ~doc:"Github bridge for Datakit (9p)"
 module Log9p = (val Logs.src_log src9p : Logs.LOG)
 
 let quiet_9p () =
@@ -268,7 +268,7 @@ let capabilities =
   Arg.(value & opt cap Datakit_github.Capabilities.all doc)
 
 let term =
-  let doc = "Bridge between GiHub API and Datakit." in
+  let doc = "Bridge between GitHub API and Datakit." in
   let man = [
     `S "DESCRIPTION";
     `P "$(tname) exposes a subset of the GitHub API as a 9p \

bridge/local/Makefile

@@ -0,0 +1,5 @@
+all:
+	make -w -C ../.. bridge-local-git
+
+clean:
+	make -C ../.. clean

bridge/local/_tags

@@ -0,0 +1,4 @@
+true: warn(A)
+true: strict_sequence, safe_string, annot, bin_annot
+true: package(cmdliner, logs, datakit-client, protocol-9p.unix, fmt.cli, fmt.tty, logs.cli)
+true: package(irmin.unix, irmin.git, irmin-watcher, datakit-github.client)

bridge/local/main.ml

@@ -0,0 +1,113 @@
+open Lwt.Infix
+
+let src = Logs.Src.create "bridge-local-git" ~doc:"Local Git bridge for Datakit"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let src9p = Logs.Src.create "bridge-local-git.9p" ~doc:"Local Git bridge for Datakit (9p)"
+module Log9p = (val Logs.src_log src9p : Logs.LOG)
+module Client9p = Client9p_unix.Make(Log9p)
+module Store = Irmin_unix.Irmin_git.FS(Irmin.Contents.String)(Irmin.Ref.String)(Irmin.Hash.SHA1)
+module DK = Datakit_client_9p.Make(Client9p)
+
+module Sync = Sync.Make(Store)(DK)
+
+let failf fmt =
+  Fmt.kstrf failwith fmt
+
+let start () (protocol, address) repos =
+  Log.info (fun f -> f "Connecting to DataKit server on %s:%s" protocol address);
+  Irmin.Private.Watch.set_listen_dir_hook Irmin_watcher.hook;
+  Lwt_main.run begin
+    Lwt.catch
+      (fun () ->
+         Client9p.connect protocol address () >|= function
+         | Ok c -> c
+         | Error (`Msg m) -> failwith m
+      )
+      (fun ex ->
+         failf "Failed to connect to DataKit server at proto=%S addr=%S: %s"
+           protocol address (Printexc.to_string ex)
+      )
+    >|= DK.connect >>= fun dk ->
+    repos |> Lwt_list.map_p (fun (name, root) ->
+        Log.info (fun f -> f "Monitoring local repository %S" root);
+        let config = Irmin_unix.Irmin_git.config ~root ~bare:true () in
+        Store.Repo.create config >|= fun store -> (name, store)
+      )
+    >>= Sync.run dk
+  end
+
+(* Command-line parsing *)
+
+open Cmdliner
+
+let datakit_endpoint =
+  let doc =
+    Arg.info ~doc:"DataKit store for metadata."
+      ~docv:"ADDR" ["metadata-store"]
+  in
+  Arg.(value (opt (pair ~sep:':' string string) ("tcp","localhost:5640") doc))
+
+let pp_level f lvl =
+  let style, msg = match lvl with
+    | Logs.App -> `Black, "APP"
+    | Logs.Error -> `Red, "ERR"
+    | Logs.Warning -> `Red, "WRN"
+    | Logs.Info -> `None, "INF"
+    | Logs.Debug ->  `Cyan, "DBG"
+  in
+  Fmt.pf f "%a" Fmt.(styled style string) msg
+
+let pp_timestamp f x =
+  let open Unix in
+  let tm = localtime x in
+  Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d"
+    (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
+
+let report src level ~over k msgf =
+  let k _ = over (); k () in
+  msgf @@ fun ?header:_ ?tags:_ fmt ->
+  let src = Logs.Src.name src in
+  Format.kfprintf k Format.err_formatter ("%a %a [%s] @[" ^^ fmt ^^ "@]@.")
+    pp_timestamp (Unix.gettimeofday ())
+    pp_level level
+    src
+
+let init style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter { Logs.report }
+
+let setup_log =
+  Term.(const init $ Fmt_cli.style_renderer () $ Logs_cli.level ())
+
+let repo_id =
+  let parse s =
+    match Datakit_github.Repo.of_string s with
+    | None -> `Error (Fmt.strf "Bad repository name %S (format should be user/project)" s)
+    | Some x -> `Ok x
+  in
+  (parse, Datakit_github.Repo.pp)
+
+let repo = Arg.(pair ~sep:':' repo_id dir)
+
+let repos =
+  let doc = Arg.info []
+      ~doc:"A Git repository to monitor and the name to use for it. e.g. 'my/my-project:/tmp/my-project'"
+      ~docv:"NAME:PATH" in
+  Arg.(non_empty @@ pos_all repo [] doc)
+
+let main =
+  let doc = "Bridge between a local Git repository and Datakit." in
+  let man = [
+    `S "DESCRIPTION";
+    `P "$(tname) is a local replacement for datakit-github. \
+        It allows you to test DataKitCI against a local Git repository \
+        without having to configure GitHub integration first.";
+  ] in
+  Term.(pure start $ setup_log $ datakit_endpoint $ repos),
+  Term.info (Filename.basename Sys.argv.(0)) ~doc ~man
+
+let () = match Term.eval main with
+  | `Error _ -> exit 1
+  | `Help | `Version | `Ok () -> ()

bridge/local/sync.ml

@@ -0,0 +1,107 @@
+open Lwt.Infix
+open Datakit_github
+
+let src = Logs.Src.create "bridge-local-git.sync" ~doc:"Local Git bridge sync for Datakit"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Make
+    (S : Irmin.S with type branch_id = string and type commit_id = Irmin.Hash.SHA1.t)
+    (DK : Datakit_S.CLIENT)
+= struct
+  module Conv = Datakit_github_conv.Make(DK)
+
+  let ( >>*= ) x f =
+    x >>= function
+    | Ok x -> f x
+    | Error e -> Lwt.fail (Failure (Fmt.to_to_string DK.pp_error e))
+
+  type t = {
+    repos : Repo.Set.t;
+    metadata_branch : DK.Branch.t;
+    mutable known : Commit.t Ref.Index.t;
+    cond : unit Lwt_condition.t;        (* Fires when [known] changes. *)
+  }
+
+  let on_change t repo_id irmin_repo branch =
+    Log.info (fun f -> f "Notification for %S" branch);
+    S.Private.Ref.read (S.Private.Repo.ref_t irmin_repo) branch >|= fun head ->
+    let old = t.known in
+    let id = (repo_id, ["heads"; branch]) in
+    let next =
+      match head with
+      | None -> Ref.Index.remove id old
+      | Some head -> Ref.Index.add id (Commit.v repo_id (S.Hash.to_hum head)) old
+    in
+    if t.known != next then (
+      Log.info (fun f -> f "Update for %S" branch);
+      t.known <- next;
+      Lwt_condition.broadcast t.cond ();
+    )
+
+  let watch t (name, repo) =
+    let callback branch _diff = on_change t name repo branch in
+    S.Repo.watch_branches ~init:[] repo callback >>= fun (_stop : (unit -> unit Lwt.t)) ->
+    (* XXX: In theory, we should be able to pass [~init:[]] and have Irmin notify us
+       of the initial state. However, Irmin's [watch_branches] is buggy. *)
+    S.Repo.branches repo >>= Lwt_list.iter_s (fun b -> on_change t name repo b)
+
+  let read_refs t tr =
+    DK.Transaction.parents tr >>*= function
+    | [] -> Lwt.return Ref.Set.empty
+    | [p] -> Conv.refs ~repos:t.repos (DK.Commit.tree p)
+    | _ -> assert false (* We never make merge transactions. *)
+
+  let update_ref tr ~changelog ~new_state existing_ref =
+    Log.info (fun f -> f "Updating ref %a" Ref.pp existing_ref);
+    let id = Ref.id existing_ref in
+    match Ref.Index.find id !new_state with
+    | None ->
+      Log.info (fun f -> f "Branch %a no longer exists" Ref.pp existing_ref);
+      Buffer.add_string changelog (Fmt.strf "Removing deleted branch %a@." Ref.pp existing_ref);
+      Conv.remove_elt tr (`Ref (Ref.id existing_ref));
+    | Some new_head ->
+      new_state := Ref.Index.remove id !new_state;
+      if Commit.equal new_head (Ref.commit existing_ref) then Lwt.return ()
+      else (
+        let r = Ref.v new_head (Ref.name existing_ref) in
+        Buffer.add_string changelog (Fmt.strf "Updating existing branch to %a@." Ref.pp r);
+        Conv.update_elt tr (`Ref r)
+      )
+
+  let add_ref tr ~changelog (id, commit) =
+    Log.info (fun f -> f "Add ref %a" Ref.pp_id id);
+    let r = Ref.v commit (snd id) in
+    Buffer.add_string changelog (Fmt.strf "Tracking new branch %a@." Ref.pp r);
+    Conv.update_elt tr (`Ref r)
+
+  let sync t new_state =
+    Log.info (fun f -> f "Copy state to DataKit");
+    DK.Branch.with_transaction t.metadata_branch (fun tr ->
+        let changelog = Buffer.create 128 in
+        read_refs t tr >>= fun old_refs ->
+        let new_state = ref new_state in
+        Lwt_list.iter_s (update_ref tr ~changelog ~new_state) (Ref.Set.elements old_refs) >>= fun () ->
+        let new_state = !new_state in
+        Lwt_list.iter_s (add_ref tr ~changelog) (Ref.Index.bindings new_state) >>= fun () ->
+        match Buffer.contents changelog with
+        | "" ->
+          Log.info (fun f -> f "No updates needed");
+          DK.Transaction.abort tr >|= fun () -> Ok ()
+        | message ->
+          DK.Transaction.commit tr ~message
+      )
+    >>*= Lwt.return
+
+  let run dk repos =
+    DK.branch dk "github-metadata" >>*= fun metadata_branch ->
+    let cond = Lwt_condition.create () in
+    let monitored = List.map fst repos |> Repo.Set.of_list in
+    let t = { repos = monitored; metadata_branch; known = Ref.Index.empty; cond } in
+    Lwt_list.iter_p (watch t) repos >>= fun () ->
+    let rec aux () =
+      let next = Lwt_condition.wait t.cond in
+      sync t t.known >>= fun () ->
+      next >>= aux
+    in
+    aux ()
+end

bridge/local/sync.mli

@@ -0,0 +1,5 @@
+module Make
+    (S : Irmin.S with type branch_id = string and type commit_id = Irmin.Hash.SHA1.t)
+    (DK : Datakit_S.CLIENT) : sig
+  val run : DK.t -> (Datakit_github.Repo.t * S.Repo.t) list -> 'a Lwt.t
+end

ci/skeleton/.gitignore

@@ -0,0 +1 @@
+secrets

ci/skeleton/Makefile

@@ -5,5 +5,9 @@ all: exampleCI
 %CI:
 	ocamlbuild ${OCAMLBUILD_FLAGS} $@.native
 
+run-example: exampleCI.native
+	-mkdir secrets
+	./exampleCI.native --secrets=./secrets --web-ui=https://localhost:8443 --metadata-store=tcp:127.0.0.1:5640 -v
+
 clean:
 	ocamlbuild -clean

datakit-bridge-local-git.opam

@@ -0,0 +1,23 @@
+opam-version: "1.2"
+maintainer:   "thomas.leonard@docker.com"
+authors:      ["Thomas Leonard"]
+license:      "Apache"
+homepage:     "https://github.com/docker/datakit"
+bug-reports:  "https://github.com/docker/datakit/issues"
+dev-repo:     "https://github.com/docker/datakit.git"
+doc:          "https://docker.github.io/datakit/"
+
+build: [
+  "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "-n" "datakit-bridge-local-git"
+]
+
+depends: [
+  "ocamlfind"  {build}
+  "ocamlbuild" {build}
+  "topkg"      {build}
+  "cmdliner"
+  "lwt" {>= "2.7.0"}
+  "logs" "fmt"
+  "protocol-9p" {>= "0.8.0"}
+  "datakit-client" {>= "0.7.0"}
+]

pkg/META.bridge-local-git

@@ -0,0 +1,8 @@
+description = "Local alternative to datakit-github (for testing)"
+version = "%%VERSION%%"
+requires = "lwt.unix datakit-github.client"
+archive(byte)   = "datakit-bridge-local-git.cma"
+archive(native) = "datakit-bridge-local-git.cmxa"
+plugin(byte)    = "datakit-bridge-local-git.cma"
+plugin(native)  = "datakit-bridge-local-git.cmxs"
+exists_if       = "datakit-bridge-local-git.cma"

pkg/pkg.ml

@@ -9,6 +9,7 @@ let includes = function
   | "datakit" -> ["src"; "src/datakit"]
   | "datakit-server" -> ["src"; "src/datakit-server"]
   | "datakit-github" -> ["src"; "src/datakit"]
+  | "datakit-bridge-local-git" -> ["bridge/local"]
   | "datakit-client" -> ["src"; "src/datakit-client"]
   | x -> failwith ("Unknown includes for package: " ^ x)
 
@@ -87,6 +88,12 @@ let () =
       Pkg.mllib "bridge/github/datakit-github-server.mllib";
       Pkg.bin   "bridge/github/main" ~dst:"datakit-github" ;
     ]
+  | "datakit-bridge-local-git" -> Ok [
+      Pkg.lib   "pkg/META.bridge-local-git"     ~dst:"META";
+      Pkg.lib   "datakit-bridge-local-git.opam" ~dst:"opam";
+      Pkg.mllib "bridge/local/datakit-bridge-local-git.mllib";
+      Pkg.bin   "bridge/local/main" ~dst:"datakit-bridge-local-git" ;
+    ]
   | "datakit-ci" -> Ok [
       Pkg.lib   "pkg/META.ci"     ~dst:"META";
       Pkg.lib   "datakit-ci.opam" ~dst:"opam";