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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
let ( <.> ) f g x = f (g x)
module Capability = Capability
include struct
open Protocol
module Proto_request = Proto_request
module Advertised_refs = Advertised_refs
module Want = Want
module Have = Have
module Result = Result
module Negotiation = Negotiation
module Shallow = Shallow
module Commands = Commands
module Status = Status
end
module Witness = struct
type 'a send =
| Proto_request : Proto_request.t send
| Want : (string, string) Want.t send
| Done : unit send
| Flush : unit send
| Commands : (string, string) Commands.t send
| Send_pack : { side_band : bool; stateless : bool } -> string send
| Advertised_refs : (string, string) Advertised_refs.t send
| Acks : string Negotiation.t list send
type 'a recv =
| Advertised_refs : (string, string) Advertised_refs.t recv
| Result : string Result.t recv
| Status : bool -> string Status.t recv
| Packet : bool -> string recv
| Commands : (string, string) Commands.t option recv
| Recv_pack : {
side_band : bool;
push_stdout : string -> unit;
push_stderr : string -> unit;
}
-> [ `Payload of string * int * int
| `End_of_transmission
| `Stdout
| `Stderr ]
recv
| Ack : string Negotiation.t recv
| Flush : unit recv
| Shallows : string Shallow.t list recv
| Want : (string, string) Want.t option recv
| Have : string Have.t recv
end
module Value = struct
open Pkt_line
type encoder = Encoder.encoder
type decoder = Decoder.decoder
include Witness
type error = [ Protocol.Encoder.error | Protocol.Decoder.error ]
let encode :
type a. encoder -> a send -> a -> (unit, [> Encoder.error ]) State.t =
fun encoder w v ->
let encoder_state =
let open Protocol.Encoder in
match w with
| Proto_request -> encode_proto_request encoder v
| Want -> encode_want encoder v
| Done -> encode_done encoder
| Commands -> encode_commands encoder v
| Send_pack { side_band; stateless } ->
encode_pack ~side_band ~stateless encoder v
| Flush -> encode_flush encoder
| Advertised_refs -> encode_advertised_refs encoder v
| Acks -> encode_acks encoder v
in
let rec translate_to_state_t = function
| Encoder.Done -> State.Return ()
| Write { continue; buffer; off; len } ->
State.Write
{ k = translate_to_state_t <.> continue; buffer; off; len }
| Error err -> State.Error (err :> error)
in
translate_to_state_t encoder_state
let decode : type a. decoder -> a recv -> (a, [> Decoder.error ]) State.t =
fun decoder w ->
let rec transl :
(a, [> Protocol.Decoder.error ]) Decoder.state ->
(a, [> Decoder.error ]) State.t = function
| Decoder.Done v -> State.Return v
| Read { buffer; off; len; continue; eof } ->
State.Read
{ k = transl <.> continue; buffer; off; len; eof = transl <.> eof }
| Error { error; _ } -> State.Error error
in
transl
(let open Protocol.Decoder in
match w with
| Advertised_refs -> decode_advertised_refs decoder
| Result -> decode_result decoder
| Commands -> decode_commands decoder
| Recv_pack { side_band; push_stdout; push_stderr } ->
decode_pack ~side_band ~push_stdout ~push_stderr decoder
| Ack -> decode_negotiation decoder
| Status sideband -> decode_status ~sideband decoder
| Flush -> decode_flush decoder
| Shallows -> decode_shallows decoder
| Packet trim -> decode_packet ~trim decoder
| Have -> decode_have decoder
| Want -> decode_want decoder)
end
type ('a, 'err) t = ('a, 'err) State.t =
| Read of {
buffer : bytes;
off : int;
len : int;
k : int -> ('a, 'err) t;
eof : unit -> ('a, 'err) t;
}
| Write of { buffer : string; off : int; len : int; k : int -> ('a, 'err) t }
| Return of 'a
| Error of 'err
module Context = struct
type t = State.Context.t
type capabilities = State.Context.capabilities = {
my_caps : Capability.t list;
their_caps : Capability.t list;
}
let make = State.Context.make
let with_decoder = State.Context.with_decoder
let replace_their_caps = State.Context.replace_their_caps
let is_cap_shared = State.Context.is_cap_shared
let capabilities = State.Context.capabilities
end
include Witness
let proto_request = Proto_request
let advertised_refs = Advertised_refs
let send_want : _ send = Want
let negotiation_done = Done
let negotiation_result = Result
let commands : _ send = Commands
let recv_pack ?(push_stdout = ignore) ?(push_stderr = ignore) side_band =
Recv_pack { side_band; push_stdout; push_stderr }
let recv_flush : _ recv = Flush
let status sideband = Status sideband
let flush : _ send = Flush
let recv_ack : _ recv = Ack
let send_acks : _ send = Acks
let shallows = Shallows
let send_pack ?(stateless = false) side_band =
Send_pack { side_band; stateless }
let packet ~trim = Packet trim
let send_advertised_refs : _ send = Advertised_refs
let recv_want : _ recv = Want
let recv_have : _ recv = Have
let recv_commands : _ recv = Commands
include State.Scheduler (State.Context) (Value)
let pp_error ppf = function
| #Protocol.Encoder.error as err -> Protocol.Encoder.pp_error ppf err
| #Protocol.Decoder.error as err -> Protocol.Decoder.pp_error ppf err
module Unsafe = struct
let write context packet =
let encoder = State.Context.encoder context in
Protocol.Encoder.unsafe_encode_packet encoder ~packet
end