initial ssh (client) support using awa-ssh

git.opam

@@ -36,8 +36,8 @@ depends: [
   "checkseum"  {>= "0.0.9"}
   "stdlib-shims"
   "ke"
-  "encore"     {>= "0.5"}
-  "duff"
+  "encore"     {>= "0.5" & < "0.6"}
+  "duff"       {< "0.3"}
   "hex"
   "ocplib-endian"
   "rresult"

src/git-mirage/git_mirage.ml

@@ -29,6 +29,8 @@ module Sync (G : Git.S) = struct
 
   module Tcp = Git.Tcp.Make (Net) (Endpoint) (G)
 
+  module Ssh = Git.Ssh.Make (Net) (Endpoint) (G)
+
   module Client = struct
     (* XXX(samoht): too much copy/paste from git-unix ... *)
 
@@ -93,15 +95,17 @@ module Sync (G : Git.S) = struct
 
   module Http = Git_http.Sync.CohttpMake (Client) (Endpoint) (G)
 
-  type error = Tcp of Tcp.error | Http of Http.error
+  type error = Tcp of Tcp.error | Http of Http.error | Ssh of Ssh.error
 
   let pp_error ppf = function
     | Tcp x -> Tcp.pp_error ppf x
     | Http x -> Http.pp_error ppf x
+    | Ssh x -> Ssh.pp_error ppf x
 
   let dispatch e f =
     match Uri.scheme e.uri with
     | Some "git" -> f `Tcp
+    | Some "ssh" -> f `Ssh
     | Some ("http" | "https") -> f `Http
     | Some s -> Fmt.invalid_arg "%a: invalid scheme (%s)" Uri.pp_hum e.uri s
     | None -> Fmt.invalid_arg "%a: missing scheme" Uri.pp_hum e.uri
@@ -118,17 +122,22 @@ module Sync (G : Git.S) = struct
   let tcp_error x =
     Lwt.map (function Ok _ as x -> x | Error e -> Error (Tcp e)) x
 
+  let ssh_error x =
+    Lwt.map (function Ok _ as x -> x | Error e -> Error (Ssh e)) x
+
   let http_error x =
     Lwt.map (function Ok _ as x -> x | Error e -> Error (Http e)) x
 
   let push t ~push ?capabilities e =
     dispatch e (function
-      | `Tcp -> Tcp.push t ~push ?capabilities e |> tcp_error
-      | `Http -> Http.push t ~push ?capabilities e |> http_error )
+        | `Tcp -> Tcp.push t ~push ?capabilities e |> tcp_error
+        | `Ssh -> Ssh.push t ~push ?capabilities e |> ssh_error
+        | `Http -> Http.push t ~push ?capabilities e |> http_error )
 
   let ls t ?capabilities e =
     dispatch e (function
       | `Tcp -> Tcp.ls t ?capabilities e |> tcp_error
+      | `Ssh -> Ssh.ls t ?capabilities e |> ssh_error
       | `Http -> Http.ls t ?capabilities e |> http_error )
 
   let fetch t ?shallow ?capabilities ~notify ~negociate ~have ~want ?deepen e =
@@ -137,6 +146,10 @@ module Sync (G : Git.S) = struct
           Tcp.fetch t ?shallow ?capabilities ~notify ~negociate ~have ~want
             ?deepen e
           |> tcp_error
+      | `Ssh ->
+          Ssh.fetch t ?shallow ?capabilities ~notify ~negociate ~have ~want
+            ?deepen e
+          |> ssh_error
       | `Http ->
           Http.fetch t ?shallow ?capabilities ~notify ~negociate ~have ~want
             ?deepen e
@@ -145,27 +158,33 @@ module Sync (G : Git.S) = struct
   let clone t ?capabilities ~reference e =
     dispatch e (function
       | `Tcp -> Tcp.clone t ?capabilities ~reference e |> tcp_error
+      | `Ssh -> Ssh.clone t ?capabilities ~reference e |> ssh_error
       | `Http -> Http.clone t ?capabilities ~reference e |> http_error )
 
   let fetch_some t ?capabilities ~references e =
     dispatch e (function
       | `Tcp -> Tcp.fetch_some t ?capabilities ~references e |> tcp_error
+      | `Ssh -> Ssh.fetch_some t ?capabilities ~references e |> ssh_error
       | `Http -> Http.fetch_some t ?capabilities ~references e |> http_error )
 
   let fetch_all t ?capabilities ~references e =
     dispatch e (function
       | `Tcp -> Tcp.fetch_all t ?capabilities ~references e |> tcp_error
+      | `Ssh -> Ssh.fetch_all t ?capabilities ~references e |> ssh_error
       | `Http -> Http.fetch_all t ?capabilities ~references e |> http_error )
 
   let fetch_one t ?capabilities ~reference e =
     dispatch e (function
       | `Tcp -> Tcp.fetch_one t ?capabilities ~reference e |> tcp_error
+      | `Ssh -> Ssh.fetch_one t ?capabilities ~reference e |> ssh_error
       | `Http -> Http.fetch_one t ?capabilities ~reference e |> http_error )
 
   let update_and_create t ?capabilities ~references e =
     dispatch e (function
       | `Tcp ->
           Tcp.update_and_create t ?capabilities ~references e |> tcp_error
+      | `Ssh ->
+          Ssh.update_and_create t ?capabilities ~references e |> ssh_error
       | `Http ->
           Http.update_and_create t ?capabilities ~references e |> http_error )
 end

src/git-mirage/git_mirage.mli

@@ -16,6 +16,8 @@ val endpoint :
 module Sync (G : Git.S) : sig
   module Tcp : Git.Sync.S with module Store := G and type Endpoint.t = endpoint
 
+  module Ssh : Git.Sync.S with module Store := G and type Endpoint.t = endpoint
+
   module Http :
     Git_http.Sync.S with module Store := G and type Client.endpoint = endpoint
 

src/git-mirage/net.ml

@@ -49,12 +49,18 @@ let read {ic; _} raw off len =
       (* XXX(dinosaure): Channel.error is not a variant. *)
       Lwt.return_ok 0
 
-let socket (t : endpoint) =
+let socket ?cmd (t : endpoint) =
   let open Lwt.Infix in
   let uri = (t.uri :> Uri.t) in
   Resolver_lwt.resolve_uri ~uri t.resolver
   >>= fun endp ->
-  Conduit_mirage.client endp
+  let config =
+    match Cohttp.Header.get t.headers "config", cmd with
+    | None, None -> None
+    | Some cfg, Some e -> Some (e ^ ":" ^ cfg)
+    | _ -> None
+  in
+  Conduit_mirage.client ?config endp
   >>= fun client ->
   Conduit_mirage.connect t.conduit client
   >>= fun flow ->

src/git-unix/net.ml

@@ -33,7 +33,7 @@ let host uri =
   | None ->
       Fmt.kstrf failwith "Expected a git url with host: %a." Uri.pp_hum uri
 
-let socket (e : endpoint) =
+let socket ?cmd:_ (e : endpoint) =
   let open Lwt.Infix in
   let uri = e.uri in
   Log.debug (fun l ->

src/git/git.ml

@@ -37,4 +37,5 @@ module Buffer = Cstruct_buffer
 module Hash = Hash
 module Gri = Gri
 module Tcp = Tcp
+module Ssh = Ssh
 module Path = Path

src/git/git.mli

@@ -33,6 +33,7 @@ module Buffer = Cstruct_buffer
 module Hash = Hash
 module Gri = Gri
 module Tcp = Tcp
+module Ssh = Ssh
 module Path = Path
 
 module type FILE = S.FILE

src/git/smart.ml

@@ -698,7 +698,7 @@ module type CLIENT = sig
 
   val pp_result : result Fmt.t
   val run : context -> action -> process
-  val context : Common.git_proto_request -> context * process
+  val context : Common.git_proto_request option -> context * process
 end
 
 module Decoder
@@ -2542,10 +2542,13 @@ struct
       ; encoder= Encoder.encoder ()
       ; capabilities= [] }
     in
-    ( context
-    , encode (`GitProtoRequest c)
-        (decode Decoder.ReferenceDiscovery (fun refs ctx -> match refs with
-             | Ok refs -> ctx.capabilities <- refs.Common.capabilities ; `Refs refs
-             | Error (`Msg err) -> `SmartError err))
-        context )
+    let decoder =
+      decode Decoder.ReferenceDiscovery (fun refs ctx -> match refs with
+          | Ok refs -> ctx.capabilities <- refs.Common.capabilities ; `Refs refs
+          | Error (`Msg err) -> `SmartError err)
+    in
+    ( context ,
+      match c with
+      | None -> decoder context
+      | Some c -> encode (`GitProtoRequest c) decoder context)
 end

src/git/smart.mli

@@ -494,7 +494,7 @@ module type CLIENT = sig
   (** [run ctx action] sends an action to the server and schedule a specific
       {!Decoder.transaction} then. *)
 
-  val context : Common.git_proto_request -> context * process
+  val context : Common.git_proto_request option -> context * process
   (** [context request] makes a new context and the continuation of the
       transport. *)
 end