diff --git a/Makefile b/Makefile index 98f81bd92..8a4cb6226 100644 --- a/Makefile +++ b/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 diff --git a/_tags b/_tags index a37489818..30b67b3e9 100644 --- a/_tags +++ b/_tags @@ -1,6 +1,6 @@ true: -traverse true : bin_annot, safe_string -not : warn_error(+1..49-3), warn(A-4-41-44) +not and not : warn_error(+1..49-3), warn(A-4-41-44) not : package(bytes lwt astring logs result cstruct fmt rresult) : traverse diff --git a/bridge/github/main.ml b/bridge/github/main.ml index 936c99d85..df04f2a2a 100644 --- a/bridge/github/main.ml +++ b/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 \ diff --git a/bridge/local/Makefile b/bridge/local/Makefile new file mode 100644 index 000000000..de94ec3c6 --- /dev/null +++ b/bridge/local/Makefile @@ -0,0 +1,5 @@ +all: + make -w -C ../.. bridge-local-git + +clean: + make -C ../.. clean diff --git a/bridge/local/_tags b/bridge/local/_tags new file mode 100644 index 000000000..11f4d5ddb --- /dev/null +++ b/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) diff --git a/bridge/local/main.ml b/bridge/local/main.ml new file mode 100644 index 000000000..a8cfcd108 --- /dev/null +++ b/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 () -> () diff --git a/bridge/local/main.mli b/bridge/local/main.mli new file mode 100644 index 000000000..e69de29bb diff --git a/bridge/local/sync.ml b/bridge/local/sync.ml new file mode 100644 index 000000000..9935e4cab --- /dev/null +++ b/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 diff --git a/bridge/local/sync.mli b/bridge/local/sync.mli new file mode 100644 index 000000000..c67bb13b5 --- /dev/null +++ b/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 diff --git a/ci/skeleton/.gitignore b/ci/skeleton/.gitignore new file mode 100644 index 000000000..db2fc0de6 --- /dev/null +++ b/ci/skeleton/.gitignore @@ -0,0 +1 @@ +secrets diff --git a/ci/skeleton/Makefile b/ci/skeleton/Makefile index 24226cf72..1dd37b31c 100644 --- a/ci/skeleton/Makefile +++ b/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 diff --git a/datakit-bridge-local-git.opam b/datakit-bridge-local-git.opam new file mode 100644 index 000000000..c3436bc86 --- /dev/null +++ b/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"} +] diff --git a/pkg/META.bridge-local-git b/pkg/META.bridge-local-git new file mode 100644 index 000000000..b5bb2bc6d --- /dev/null +++ b/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" diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 9a94bf61c..dbbbef7a3 100755 --- a/pkg/pkg.ml +++ b/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";