From ca7c227ed1251ed401f60d43d99c9cafdc4390a9 Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Mon, 12 Oct 2020 11:23:11 +0200 Subject: [PATCH 1/4] implement ogit-fetch --- git-unix.opam | 6 + src/git-unix/ogit-fetch/dune | 8 ++ src/git-unix/ogit-fetch/main.ml | 202 ++++++++++++++++++++++++++++++++ 3 files changed, 216 insertions(+) create mode 100644 src/git-unix/ogit-fetch/dune create mode 100644 src/git-unix/ogit-fetch/main.ml diff --git a/git-unix.opam b/git-unix.opam index a3371b640..462b425f2 100644 --- a/git-unix.opam +++ b/git-unix.opam @@ -39,9 +39,15 @@ depends: [ "alcotest" {with-test & >= "1.1.0"} "alcotest-lwt" {with-test & >= "1.1.0"} "base64" {with-test & >= "3.0.0"} + # for ogit-fetch : + "git-cohttp-unix" + "mirage-clock" + "mirage-clock-unix" ] pin-depends: [ [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "awa" "git+https://github.com/mirage/awa-ssh.git#e54302ecd5fe541c2fbecb277cb11bba40032b81"] + [ "awa-conduit" "git+https://github.com/mirage/awa-ssh.git#e54302ecd5fe541c2fbecb277cb11bba40032b81"] ] diff --git a/src/git-unix/ogit-fetch/dune b/src/git-unix/ogit-fetch/dune new file mode 100644 index 000000000..c25ba5e2a --- /dev/null +++ b/src/git-unix/ogit-fetch/dune @@ -0,0 +1,8 @@ +(executable + (name main) + (package git-unix) + (public_name ogit-fetch) + (libraries git git-unix cohttp-lwt-unix conduit conduit-lwt mirage-clock + mirage-clock-unix awa awa-conduit nss.git fpath rresult result lwt + lwt.unix git-cohttp-unix cmdliner mtime mtime.clock.os fmt.cli fmt.tty + logs.cli logs.fmt)) diff --git a/src/git-unix/ogit-fetch/main.ml b/src/git-unix/ogit-fetch/main.ml new file mode 100644 index 000000000..d39907195 --- /dev/null +++ b/src/git-unix/ogit-fetch/main.ml @@ -0,0 +1,202 @@ +let () = Random.self_init () + +open Git_unix +module Sync = Sync (Store) (Git_cohttp_unix) + +let src = Logs.Src.create "ogit-fetch" ~doc:"logs binary event" + +module Log = (val Logs.src_log src : Logs.LOG) + +let pad n x = + if String.length x > n then x else x ^ String.make (n - String.length x) ' ' + +let pp_header ppf (level, header) = + let level_style = + match level with + | Logs.App -> Logs_fmt.app_style + | Logs.Debug -> Logs_fmt.debug_style + | Logs.Warning -> Logs_fmt.warn_style + | Logs.Error -> Logs_fmt.err_style + | Logs.Info -> Logs_fmt.info_style + in + let level = Logs.level_to_string (Some level) in + Fmt.pf ppf "[%a][%a]" + (Fmt.styled level_style Fmt.string) + level (Fmt.option Fmt.string) + (Option.map (pad 10) header) + +let reporter ppf = + let report src level ~over k msgf = + let k _ = + over (); + k () + in + let with_src_and_stamp h _ k fmt = + let dt = Mtime.Span.to_us (Mtime_clock.elapsed ()) in + Fmt.kpf k ppf + ("%s %a %a: @[" ^^ fmt ^^ "@]@.") + (pad 10 (Fmt.strf "%+04.0fus" dt)) + pp_header (level, h) + Fmt.(styled `Magenta string) + (pad 10 @@ Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_src_and_stamp header tags k fmt + in + { Logs.report } + +let setup_logs style_renderer level ppf = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (reporter ppf); + let quiet = match style_renderer with Some _ -> true | None -> false in + quiet, ppf + +type error = [ `Store of Store.error | `Sync of Sync.error ] + +let store_err err = `Store err +let sync_err err = `Sync err + +let pp_error ppf = function + | `Store err -> Fmt.pf ppf "(`Store %a)" Store.pp_error err + | `Sync err -> Fmt.pf ppf "(`Sync %a)" Sync.pp_error err + +module SSH = Awa_conduit.Make (Lwt) (Conduit_lwt) (Mclock) + +let ssh_protocol = SSH.protocol_with_ssh Conduit_lwt.TCP.protocol + +let ssh_cfg edn ssh_seed = + assert (String.length ssh_seed > 0); + let key = Awa.Keys.of_seed ssh_seed in + match edn with + | { Smart_git.scheme = `SSH user; path; _ } -> + let req = Awa.Ssh.Exec (Fmt.strf "git-upload-pack '%s'" path) in + Some { Awa_conduit.user; key; req; authenticator = None } + | _ -> None + +let ssh_resolve (ssh_cfg : Awa_conduit.endpoint) domain_name = + let open Lwt.Infix in + Conduit_lwt.TCP.resolve ~port:22 domain_name >|= function + | Some edn -> Some (edn, ssh_cfg) + | None -> None + +let main (ssh_seed : string) + (references : (Git.Reference.t * Git.Reference.t) list) (directory : string) + (repository : Smart_git.endpoint) : (unit, 'error) Lwt_result.t = + let repo_root = + (match directory with "" -> Sys.getcwd () | _ -> directory) |> Fpath.v + in + let ( >>?= ) = Lwt_result.bind in + let ( >>!= ) v f = Lwt_result.map_err f v in + let resolvers = + let git_scheme_resolver = Conduit_lwt.TCP.resolve ~port:9418 in + let ssh_cfg = ssh_cfg repository ssh_seed in + Cohttp_lwt_unix.Net.empty + |> Conduit_lwt.add Conduit_lwt.TCP.protocol git_scheme_resolver + |> Conduit_lwt.add ssh_protocol (ssh_resolve @@ Option.get ssh_cfg) + (* FIXME add support for SSH *) + in + Store.v repo_root >>!= store_err >>?= fun store -> + let push_stdout = print_endline in + let push_stderr = prerr_endline in + Sync.fetch ~push_stdout ~push_stderr ~resolvers repository store + (`Some references) + >>!= sync_err + >>?= fun _ -> Lwt.return (Ok ()) + +open Cmdliner + +module Flag = struct + (** We want ogit-fetch to have the following interface: + ogit-fetch [-r | --root ] [--output ] [--progress] ... *) + + (* TODO polish code & CLI *) + + let output = + let conv' = + let parse str = + match str with + | "stdout" -> Ok Fmt.stdout + | "stderr" -> Ok Fmt.stderr + | s -> Error (`Msg (Fmt.strf "%s is not an output." s)) + in + let print ppf v = + Fmt.pf ppf "%s" (if v == Fmt.stdout then "stdout" else "stderr") + in + Arg.conv ~docv:"" (parse, print) + in + let doc = + "Output of the progress status. Can take values 'stdout' (default) or \ + 'stderr'." + in + Arg.(value & opt conv' Fmt.stdout & info [ "output" ] ~doc ~docv:"") + + let progress = + let doc = + "Progress status is reported on the standard error stream by default \ + when it is attached to a terminal, unless -q is specified. This flag \ + forces progress status even if the standard error stream is not \ + directed to a terminal." + in + Arg.(value & flag & info [ "progress" ] ~doc) + + let directory = + let doc = "indicate path to repository root containing '.git' folder" in + Arg.(value & opt string "" & info [ "r"; "root" ] ~doc ~docv:"") + + let ssh_seed = + let doc = "seed for SSH generated by awa_gen_key" in + Arg.(value & opt string "" & info [ "s"; "seed" ] ~doc ~docv:"") + + (** passed argument needs to be a URI of the repository *) + let repository = + let endpoint = + let parse = Smart_git.endpoint_of_string in + let print = Smart_git.pp_endpoint in + Arg.conv ~docv:"" (parse, print) + in + let doc = "URI leading to repository" in + Arg.( + required & pos 0 (some endpoint) None & info [] ~docv:"" ~doc) + + (** can be several references of form "remote_ref:local_ref" or "remote_ref", where the latter means that the local_ref should + have the same name *) + let references = + let reference = + let parse str = Ok (Git.Reference.v str) in + let print = Git.Reference.pp in + Arg.conv ~docv:"" (parse, print) + in + let doc = "" in + Arg.( + non_empty + & pos_right 0 (pair ~sep:':' reference reference) [] + & info ~doc ~docv:"" []) +end + +let setup_log = + Term.( + const setup_logs + $ Fmt_cli.style_renderer () + $ Logs_cli.level () + $ Flag.output) + +let main _ ssh_seed references directory repository _ = + match Lwt_main.run (main ssh_seed references directory repository) with + | Ok () -> `Ok () + | Error (#error as err) -> `Error (false, Fmt.strf "%a" pp_error err) + +let command = + let doc = "Fetch a Git repository by the HTTP protocol." in + let exits = Term.default_exits in + ( Term.( + ret + ( const main + $ Flag.progress + $ Flag.ssh_seed + $ Flag.references + $ Flag.directory + $ Flag.repository + $ setup_log )), + Term.info "ogit-fetch" ~version:"v0.1" ~doc ~exits ) + +let () = Term.(exit @@ eval command) From 2c1d1fcb780cdd7229db158a0766a530cbb5e016 Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Wed, 14 Oct 2020 14:02:22 +0200 Subject: [PATCH 2/4] fix incorrect pin-depends by adding version to pinned deps --- git-unix.opam | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/git-unix.opam b/git-unix.opam index 462b425f2..e53d85ee3 100644 --- a/git-unix.opam +++ b/git-unix.opam @@ -39,15 +39,15 @@ depends: [ "alcotest" {with-test & >= "1.1.0"} "alcotest-lwt" {with-test & >= "1.1.0"} "base64" {with-test & >= "3.0.0"} - # for ogit-fetch : "git-cohttp-unix" "mirage-clock" "mirage-clock-unix" + "awa-conduit" ] pin-depends: [ [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "awa" "git+https://github.com/mirage/awa-ssh.git#e54302ecd5fe541c2fbecb277cb11bba40032b81"] - [ "awa-conduit" "git+https://github.com/mirage/awa-ssh.git#e54302ecd5fe541c2fbecb277cb11bba40032b81"] + [ "awa.dev" "git+https://github.com/dinosaure/awa-ssh.git#e54302ecd5fe541c2fbecb277cb11bba40032b81"] + [ "awa-conduit.dev" "git+https://github.com/dinosaure/awa-ssh.git#e54302ecd5fe541c2fbecb277cb11bba40032b81"] ] From fed11d50eef4c2224d6521142e9724ac5d4cca7d Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 14 Oct 2020 15:49:21 +0200 Subject: [PATCH 3/4] Upgrade the appveyor.yml file to include git-cohttp{,-unix} --- appveyor.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/appveyor.yml b/appveyor.yml index 3f9025eab..fb7fba9ea 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -7,7 +7,7 @@ environment: FORK_BRANCH: master CYG_ROOT: C:\cygwin64 OPAM_SWITCH: 4.08.1+mingw64c - PINS: "carton.dev:. carton-lwt.dev:. carton-git.dev:. nss.dev:. git.dev:. git-unix.dev:." + PINS: "carton.dev:. carton-lwt.dev:. carton-git.dev:. nss.dev:. git.dev:. git-cohttp.dev:. git-cohttp-unix.dev:. git-unix.dev:." matrix: - PACKAGE: "git.dev" - PACKAGE: "git-unix.dev" From d387ff7c852efbc137cb2b3bb0120ea9918183d3 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 14 Oct 2020 21:32:47 +0200 Subject: [PATCH 4/4] Update Travis CI with new packages git-cohttp & git-cohttp-unix --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 18904f261..cc5326b97 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.t script: bash -ex .travis-opam.sh env: global: - - PINS="carton.dev:. carton-lwt.dev:. carton-git.dev:. nss.dev:. git.dev:. git-unix.dev:." + - PINS="carton.dev:. carton-lwt.dev:. carton-git.dev:. nss.dev:. git.dev:. git-unix.dev:. git-cohttp.dev:. git-cohttp-unix.dev:." matrix: - OCAML_VERSION=4.08 PACKAGE="git.dev" - OCAML_VERSION=4.09 PACKAGE="git.dev"