Add support for mirage unikernels push/pull

.merlin

@@ -1,4 +1,4 @@
 PKG cstruct dolog ocamlgraph re zip uri lwt mstruct cmdliner mirage-types
-PKG nocrypto hex cohttp.lwt
+PKG nocrypto hex cohttp.lwt mirage-flow tcpip mirage-http
 B _build/**
 S lib/

_oasis

@@ -59,7 +59,8 @@ Library "git-mirage"
   FindlibParent:     git
   Findlibname:       mirage
   Modules:           Git_mirage
-  BuildDepends:      git, mirage-types.lwt, io-page
+  BuildDepends:      git, git.http, mirage-types.lwt, io-page, conduit.mirage,
+                     dns.mirage, mirage-http, mirage-flow
 
 Executable ogit
   Build$:           flag(unix)

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: e133fb3b60d71dc9fc763023ec98d12f)
+# DO NOT EDIT (digest: 06aaa0d80bf14b05f783a596c236e9d4)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -83,17 +83,24 @@ true: annot, bin_annot
 <lib/unix/*.ml{,i,y}>: use_git-http
 # Library git-mirage
 "lib/mirage/git-mirage.cmxs": use_git-mirage
+<lib/mirage/*.ml{,i,y}>: pkg_cohttp.lwt
+<lib/mirage/*.ml{,i,y}>: pkg_conduit.mirage
+<lib/mirage/*.ml{,i,y}>: pkg_dns.mirage
 <lib/mirage/*.ml{,i,y}>: pkg_dolog
 <lib/mirage/*.ml{,i,y}>: pkg_hex
 <lib/mirage/*.ml{,i,y}>: pkg_io-page
 <lib/mirage/*.ml{,i,y}>: pkg_lwt
+<lib/mirage/*.ml{,i,y}>: pkg_mirage-flow
+<lib/mirage/*.ml{,i,y}>: pkg_mirage-http
 <lib/mirage/*.ml{,i,y}>: pkg_mirage-types.lwt
 <lib/mirage/*.ml{,i,y}>: pkg_mstruct
 <lib/mirage/*.ml{,i,y}>: pkg_nocrypto
 <lib/mirage/*.ml{,i,y}>: pkg_ocamlgraph
 <lib/mirage/*.ml{,i,y}>: pkg_uri
+<lib/mirage/*.ml{,i,y}>: pkg_uri.services
 <lib/mirage/*.ml{,i,y}>: pkg_zip
 <lib/mirage/*.ml{,i,y}>: use_git
+<lib/mirage/*.ml{,i,y}>: use_git-http
 # Executable ogit
 <bin/ogit.{native,byte}>: pkg_cmdliner
 <bin/ogit.{native,byte}>: pkg_cohttp.lwt
@@ -131,13 +138,17 @@ true: annot, bin_annot
 <lib_test/test.{native,byte}>: pkg_alcotest
 <lib_test/test.{native,byte}>: pkg_cohttp.lwt
 <lib_test/test.{native,byte}>: pkg_conduit.lwt-unix
+<lib_test/test.{native,byte}>: pkg_conduit.mirage
+<lib_test/test.{native,byte}>: pkg_dns.mirage
 <lib_test/test.{native,byte}>: pkg_dolog
 <lib_test/test.{native,byte}>: pkg_hex
 <lib_test/test.{native,byte}>: pkg_io-page
 <lib_test/test.{native,byte}>: pkg_io-page.unix
 <lib_test/test.{native,byte}>: pkg_lwt
 <lib_test/test.{native,byte}>: pkg_lwt.unix
+<lib_test/test.{native,byte}>: pkg_mirage-flow
 <lib_test/test.{native,byte}>: pkg_mirage-fs-unix
+<lib_test/test.{native,byte}>: pkg_mirage-http
 <lib_test/test.{native,byte}>: pkg_mirage-types.lwt
 <lib_test/test.{native,byte}>: pkg_mstruct
 <lib_test/test.{native,byte}>: pkg_nocrypto
@@ -152,13 +163,17 @@ true: annot, bin_annot
 <lib_test/*.ml{,i,y}>: pkg_alcotest
 <lib_test/*.ml{,i,y}>: pkg_cohttp.lwt
 <lib_test/*.ml{,i,y}>: pkg_conduit.lwt-unix
+<lib_test/*.ml{,i,y}>: pkg_conduit.mirage
+<lib_test/*.ml{,i,y}>: pkg_dns.mirage
 <lib_test/*.ml{,i,y}>: pkg_dolog
 <lib_test/*.ml{,i,y}>: pkg_hex
 <lib_test/*.ml{,i,y}>: pkg_io-page
 <lib_test/*.ml{,i,y}>: pkg_io-page.unix
 <lib_test/*.ml{,i,y}>: pkg_lwt
 <lib_test/*.ml{,i,y}>: pkg_lwt.unix
+<lib_test/*.ml{,i,y}>: pkg_mirage-flow
 <lib_test/*.ml{,i,y}>: pkg_mirage-fs-unix
+<lib_test/*.ml{,i,y}>: pkg_mirage-http
 <lib_test/*.ml{,i,y}>: pkg_mirage-types.lwt
 <lib_test/*.ml{,i,y}>: pkg_mstruct
 <lib_test/*.ml{,i,y}>: pkg_nocrypto
@@ -173,4 +188,4 @@ true: annot, bin_annot
 # OASIS_STOP
 true: debug, bin_annot
 true: warn(A-4-41-44)
-# true: warn_error_A
+# true: warn_error_A

lib/META

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 0cfe2aa098ce6d02dc061890c7f81b04)
+# DO NOT EDIT (digest: 6a049cffde61a6940559de4a10ea3566)
 version = "1.4.11"
 description = "A low-level interface to Git in pure OCaml"
 requires = "mstruct dolog ocamlgraph zip nocrypto uri lwt hex"
@@ -33,7 +33,8 @@ package "top" (
 package "mirage" (
  version = "1.4.11"
  description = "A low-level interface to Git in pure OCaml"
- requires = "git mirage-types.lwt io-page"
+ requires =
+ "git git.http mirage-types.lwt io-page conduit.mirage dns.mirage mirage-http mirage-flow"
  archive(byte) = "git-mirage.cma"
  archive(byte, plugin) = "git-mirage.cma"
  archive(native) = "git-mirage.cmxa"

lib/mirage/git_mirage.ml

@@ -177,3 +177,231 @@ module FS (FS: FS) = struct
   include Git.FS.Make(M)
 
 end
+
+module IO_helper (Channel: V1_LWT.CHANNEL) = struct
+
+  let write oc s =
+    let buf = Cstruct.of_string s in
+    Channel.write_buffer oc buf;
+    Channel.flush oc
+
+  let read_all ic =
+    let len = 4096 in
+    let res = Buffer.create len in
+    let rec aux () =
+      Channel.read_some ~len ic >>= fun buf ->
+      match Cstruct.len buf with
+      | 0 -> return_unit
+      | i ->
+        Buffer.add_string res (Cstruct.to_string buf);
+        if len = i then return_unit
+        else aux ()
+    in
+    aux () >>= fun () ->
+    return (Buffer.contents res)
+
+  let read_exactly ic n =
+    let res = Bytes.create n in
+    let rec aux off =
+      if off >= n then return_unit
+      else (
+        Channel.read_some ~len:(n-off) ic >>= fun buf ->
+        match Cstruct.len buf with
+        | 0 -> return_unit
+        | i ->
+          Cstruct.blit_to_string buf 0 res off i;
+          aux (off + i)
+      ) in
+    aux 0 >>= fun () ->
+    return res
+
+  let flush _ = Lwt.return_unit
+
+end
+
+(* channel with functional constructors. *)
+module Fchannel = Channel.Make(Fflow)
+
+module In_channel = struct
+  include Fchannel
+  let make ?close input =
+    create (Fflow.make ?close ~input ())
+end
+
+module Out_channel = struct
+  include Fchannel
+  let make ?close output =
+    create (Fflow.make ?close ~output ())
+end
+
+(* Cohttp IO with functional input/channel constructors *)
+module FIO = Cohttp_mirage_io.Make(Fchannel)
+
+(* hanlde the git:// connections *)
+module Git_protocol (Conduit: Conduit_mirage.S) = struct
+
+  module Flow = Conduit.Flow
+  module Channel = Channel.Make(Flow)
+  include IO_helper (Channel)
+
+  let with_connection (resolver, ctx) uri ?init fn =
+    assert (Git.Sync.protocol uri = `Ok `Git);
+    Log.debug "Connecting to %s" (Uri.to_string uri);
+    Resolver_lwt.resolve_uri ~uri resolver >>= fun endp ->
+    Conduit.endp_to_client ~ctx endp >>= fun client ->
+    Conduit.connect ~ctx client >>= fun (flow, _, _) ->
+    let ic = Channel.create flow in
+    let oc = Channel.create flow in
+    Lwt.finalize
+      (fun () ->
+         begin match init with
+           | None   -> return_unit
+           | Some s -> write oc s
+         end >>= fun () ->
+         fn (ic, oc))
+      (fun () -> Channel.close ic)
+
+end
+
+(* hanlde the http(s):// connections *)
+module Smart_HTTP (Conduit: Conduit_mirage.S) = struct
+
+  module Conduit_channel = Channel.Make(Conduit.Flow)
+  module HTTP_IO = Cohttp_mirage_io.Make(Conduit_channel)
+  module Net = struct
+    module IO = HTTP_IO
+    type ctx = { resolver: Resolver_lwt.t; ctx: Conduit.ctx; }
+    let sexp_of_ctx { resolver; ctx} =
+      Sexplib.Type.List [
+        Resolver_lwt.sexp_of_t resolver;
+        Conduit.sexp_of_ctx ctx
+      ]
+    let default_ctx = { resolver = Resolver_mirage.localhost; ctx = Conduit.default_ctx }
+    let connect_uri ~ctx uri =
+      Resolver_lwt.resolve_uri ~uri ctx.resolver >>= fun endp ->
+      Conduit.endp_to_client ~ctx:ctx.ctx endp >>= fun client ->
+      Conduit.connect ~ctx:ctx.ctx client >>= fun (flow, _, _) ->
+      let ch = Conduit_channel.create flow in
+      return (flow, ch, ch)
+    let close_in _ = ()
+    let close_out oc = ignore_result (Conduit_channel.close oc)
+    let close _ oc = ignore_result (Conduit_channel.close oc)
+  end
+  module Request = Cohttp_lwt.Make_request(HTTP_IO)
+  module Response = Cohttp_lwt.Make_response(HTTP_IO)
+  module HTTP = struct
+    include Cohttp_lwt.Make_client(HTTP_IO)(Request)(Response)(Net)
+    let oc x = x
+    let ic x = x
+    let close_in = Net.close_in
+    let close_out oc = Net.close () oc
+  end
+
+  type ctx = HTTP.ctx
+
+  include IO_helper(Fchannel)
+
+  module HTTP_fn = Git_http.Flow(HTTP)(In_channel)(Out_channel)
+  let with_conduit ctx ?init uri fn =
+    Net.connect_uri ~ctx uri >>= fun (_, ic, oc) ->
+    Lwt.finalize
+      (fun () ->
+         begin match init with
+           | None   -> return_unit
+           | Some s -> HTTP_IO.write oc s
+         end >>= fun () ->
+         fn (ic, oc))
+      (fun () -> Conduit_channel.close ic)
+
+  let with_connection (ctx:ctx) (uri:Uri.t) ?init fn =
+    assert (Git.Sync.protocol uri =`Ok `Smart_HTTP);
+    HTTP_fn.with_http ?init (with_conduit ctx ?init:None) uri fn
+
+  module Flow = Fflow
+  module Channel = Fchannel
+
+end
+
+module Make (Conduit: Conduit_mirage.S) = struct
+
+  module G = Git_protocol(Conduit)
+  module H = Smart_HTTP(Conduit)
+
+  type ctx = Resolver_lwt.t * Conduit.ctx
+
+  module Flow = struct
+    type 'a io = 'a Lwt.t
+    type buffer = Cstruct.t
+    module G = G.Flow
+    module H = H.Flow
+    type flow = [`Git of G.flow | `HTTP of H.flow ]
+    type error = [ `Git of G.error | `HTTP of H.error ]
+    let error_message = function
+      | `Git e  -> "git: " ^ G.error_message e
+      | `HTTP e -> "http: " ^ H.error_message e
+    let git_err f t =
+      f t >>= function
+      | `Error (x:G.error) -> Lwt.return (`Error (`Git x))
+      | `Ok x -> Lwt.return (`Ok x)
+      | `Eof -> Lwt.return `Eof
+    let http_err f t =
+      f t >>= function
+      | `Error (x:H.error) -> Lwt.return (`Error (`HTTP x))
+      | `Ok x -> Lwt.return (`Ok x)
+      | `Eof -> Lwt.return `Eof
+    let read = function
+      | `Git g -> git_err G.read g
+      | `HTTP h -> http_err H.read h
+    let write t v = match t with
+      | `Git g -> git_err (G.write g) v
+      | `HTTP h -> http_err (H.write h) v
+    let writev t v = match t with
+      | `Git g -> git_err (G.writev g) v
+      | `HTTP h -> http_err (H.writev h) v
+    let close = function
+      | `Git g -> G.close g
+      | `HTTP h -> H.close h
+  end
+
+  module Channel = Channel.Make(Flow)
+  include IO_helper(Channel)
+  type ic = Channel.t
+  type oc = Channel.t
+
+  let with_connection ?ctx uri ?init fn =
+    let resolver, ctx = match ctx with
+      | Some x -> x
+      | None   ->
+        let { H.Net.resolver; ctx } = H.Net.default_ctx in
+        resolver, ctx
+    in
+    match Git.Sync.protocol uri with
+    | `Ok `SSH -> failwith "GIT+SSH is not supported with Mirage"
+    | `Ok `Git ->
+      let fn (ic, oc) =
+        let ic = `Git (G.Channel.to_flow ic) in
+        let oc = `Git (G.Channel.to_flow oc) in
+        fn (Channel.create ic, Channel.create oc)
+      in
+      G.with_connection (resolver, ctx) ?init uri fn
+    | `Ok `Smart_HTTP ->
+      let ctx = { H.Net.resolver; ctx } in
+      let fn (ic, oc) =
+        let ic = `HTTP (H.Channel.to_flow ic) in
+        let oc = `HTTP (H.Channel.to_flow oc) in
+        fn (Channel.create ic, Channel.create oc)
+      in
+      H.with_connection ctx ?init:None uri fn
+    | `Not_supported x ->
+      fail (Failure ("Scheme " ^ x ^ " not supported yet"))
+    | `Unknown ->
+      fail (Failure ("Unknown protocol. Must supply a scheme like git://"))
+
+end
+
+module Sync (Conduit: Conduit_mirage.S) = struct
+  module M = Make (Conduit)
+  module IO = M
+  module Result = Git.Sync.Result
+  module Make = Git.Sync.Make(M)
+end

lib/mirage/git_mirage.mli

@@ -31,3 +31,12 @@ end
 
 module FS (FS: FS): Git.FS.S
 (** Create a Irmin store from raw block devices hanlder. *)
+
+module Sync (Conduit: Conduit_mirage.S): sig
+  module IO: Git.Sync.IO with type ctx = Resolver_lwt.t * Conduit.ctx
+  module Result: (module type of
+                   Git.Sync.Result with type fetch = Git.Sync.Result.fetch
+                                    and type push  = Git.Sync.Result.push)
+  module Make (S: Git.Store.S): Git.Sync.S
+    with type t = S.t and type ctx = IO.ctx
+end

myocamlbuild.ml

@@ -1,5 +1,5 @@
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 5468245a1606b05bd162b04d433b2c4a) *)
+(* DO NOT EDIT (digest: cef41d9503d35814c45b4aa8b250012c) *)
 module OASISGettext = struct
 (* # 22 "src/oasis/OASISGettext.ml" *)
 
@@ -621,7 +621,7 @@ let package_default =
        [
           ("lib_test", ["lib"; "lib/mirage"; "lib/unix"]);
           ("lib/unix", ["lib"; "lib/http"]);
-          ("lib/mirage", ["lib"]);
+          ("lib/mirage", ["lib"; "lib/http"]);
           ("lib/http", ["lib"]);
           ("bin", ["lib"; "lib/unix"])
        ]

opam

@@ -9,7 +9,7 @@ dev-repo:     "https://github.com/mirage/ocaml-git.git"
 build: [
   ["./configure"
      "--prefix" prefix
-     "--%{mirage-types-lwt:enable}%-mirage"
+     "--%{mirage-http+mirage-flow+mirage-types-lwt:enable}%-mirage"
      "--%{mirage-fs-unix+alcotest:enable}%-tests"
      "--%{conduit+cohttp+base-unix:enable}%-unix"
   ]
@@ -40,6 +40,8 @@ depopts: [
   "cohttp"
   "conduit"
   "mirage-types-lwt"
+  "mirage-http"
+  "mirage-flow"
 ]
 conflicts: [
  "cohttp"  {<= "0.15.0"}