1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
module Ctx = struct
type error = Unix.error * string * string
type write_error = [ `Closed | `Error of Unix.error * string * string ]
let pp_error ppf (err, f, v) =
Fmt.pf ppf "%s(%s): %s" f v (Unix.error_message err)
let pp_write_error ppf = function
| `Closed -> Fmt.pf ppf "Connection closed by peer"
| `Error (err, f, v) -> Fmt.pf ppf "%s(%s): %s" f v (Unix.error_message err)
type flow = { ic : in_channel; oc : out_channel }
type endpoint = {
user : string
; path : string
; host : string
; port : int
; mode : [ `Rd | `Wr ]
}
let connect { user; path; host; port; mode } =
let edn = Fmt.str "%s@%s" user host in
let cmd =
match mode with
| `Wr -> Fmt.str {sh|git-receive-pack '%s'|sh} path
| `Rd -> Fmt.str {sh|git-upload-pack '%s'|sh} path
in
let cmd = Fmt.str "ssh -p %d %s %a" port edn Fmt.(quote string) cmd in
try
let ic, oc = Unix.open_process cmd in
Lwt.return_ok { ic; oc }
with Unix.Unix_error (err, f, v) -> Lwt.return_error (`Error (err, f, v))
let read t =
let tmp = Bytes.create 0x1000 in
try
let len = input t.ic tmp 0 0x1000 in
if len = 0 then Lwt.return_ok `Eof
else Lwt.return_ok (`Data (Cstruct.of_bytes tmp ~off:0 ~len))
with Unix.Unix_error (err, f, v) -> Lwt.return_error (err, f, v)
let write t cs =
let str = Cstruct.to_string cs in
try
output_string t.oc str;
flush t.oc;
Lwt.return_ok ()
with Unix.Unix_error (err, f, v) -> Lwt.return_error (`Error (err, f, v))
let writev t css =
let rec go t = function
| [] -> Lwt.return_ok ()
| x :: r -> (
let open Lwt.Infix in
write t x >>= function
| Ok () -> go t r
| Error _ as err -> Lwt.return err)
in
go t css
let close t =
close_in t.ic;
close_out t.oc;
Lwt.return_unit
let shutdown t = function
| `read ->
close_in t.ic;
Lwt.return_unit
| `write ->
close_out t.oc;
Lwt.return_unit
| `read_write -> close t
end
let register ?priority ?(name = "ssh") () =
Mimic.register ?priority ~name (module Ctx)
let context () =
let ssh_edn, _ = register () in
let k scheme user path host port mode =
match scheme with
| `SSH -> Lwt.return_some { Ctx.user; path; host; port; mode }
| _ -> Lwt.return_none
in
let open Lwt.Syntax in
let+ context = Git_net_unix.ctx @@ Happy_eyeballs_lwt.create () in
context
|> Mimic.fold Git_store.Endpoint.git_transmission
Mimic.Fun.[ req Git_store.Endpoint.git_scheme ]
~k:(function `SSH -> Lwt.return_some `Exec | _ -> Lwt.return_none)
|> Mimic.fold ssh_edn
Mimic.Fun.
[
req Git_store.Endpoint.git_scheme
; req Git_store.Endpoint.git_ssh_user
; req Git_store.Endpoint.git_path
; req Git_store.Endpoint.git_hostname
; dft Git_store.Endpoint.git_port 22
; req Git_store.Endpoint.git_capabilities
]
~k