diff --git a/src/not-so-smart/decoder.ml b/src/not-so-smart/decoder.ml index a98b1bf69..14990a9f9 100644 --- a/src/not-so-smart/decoder.ml +++ b/src/not-so-smart/decoder.ml @@ -1,7 +1,7 @@ type decoder = { buffer : Bytes.t; mutable pos : int; mutable max : int } let io_buffer_size = 65536 -let decoder () = { buffer = Bytes.create io_buffer_size; pos = 0; max = 0 } +let create () = { buffer = Bytes.create io_buffer_size; pos = 0; max = 0 } let decoder_from x = let max = String.length x in diff --git a/src/not-so-smart/decoder.mli b/src/not-so-smart/decoder.mli index b2600b2c6..69bfbb5d4 100644 --- a/src/not-so-smart/decoder.mli +++ b/src/not-so-smart/decoder.mli @@ -1,7 +1,7 @@ type decoder = { buffer : bytes; mutable pos : int; mutable max : int } val io_buffer_size : int -val decoder : unit -> decoder +val create : unit -> decoder val decoder_from : string -> decoder val end_of_input : decoder -> int diff --git a/src/not-so-smart/encoder.ml b/src/not-so-smart/encoder.ml index 437a9d805..0a8d1a64a 100644 --- a/src/not-so-smart/encoder.ml +++ b/src/not-so-smart/encoder.ml @@ -14,7 +14,7 @@ type 'err state = | Done let io_buffer_size = 65536 -let encoder () = { payload = Bytes.create io_buffer_size; pos = 0 } +let create () = { payload = Bytes.create io_buffer_size; pos = 0 } exception Leave of error diff --git a/src/not-so-smart/encoder.mli b/src/not-so-smart/encoder.mli index 80e20abb6..eaab5fa98 100644 --- a/src/not-so-smart/encoder.mli +++ b/src/not-so-smart/encoder.mli @@ -1,7 +1,7 @@ type encoder = { payload : Bytes.t; mutable pos : int } val io_buffer_size : int -val encoder : unit -> encoder +val create : unit -> encoder type error = [ `No_enough_space ] diff --git a/src/not-so-smart/fetch.ml b/src/not-so-smart/fetch.ml index 6e2f1e490..b2eeef3b7 100644 --- a/src/not-so-smart/fetch.ml +++ b/src/not-so-smart/fetch.ml @@ -94,15 +94,11 @@ struct return (uids, refs) in let ctx = Smart.make capabilities in - let negotiator = Neg.negotiator ~compare:Uid.compare in + let negotiator = Neg.make ~compare:Uid.compare in Neg.tips sched access store negotiator |> prj >>= fun () -> Neg.run sched fail io flow (prelude ctx) |> prj >>= fun (uids, refs) -> let hex = - { - Neg.to_hex = Uid.to_hex; - Neg.of_hex = Uid.of_hex; - Neg.compare = Uid.compare; - } + { Neg.to_hex = Uid.to_hex; of_hex = Uid.of_hex; compare = Uid.compare } in Neg.find_common sched io flow fetch_cfg hex access store negotiator ctx ?deepen uids diff --git a/src/not-so-smart/find_common.ml b/src/not-so-smart/find_common.ml index 1e6c83ceb..68f1269f9 100644 --- a/src/not-so-smart/find_common.ml +++ b/src/not-so-smart/find_common.ml @@ -68,8 +68,6 @@ let unsafe_write_have ctx hex = let packet = Fmt.strf "have %s\n" hex in Smart.Unsafe.write ctx packet -let unsafe_write_done ctx = Smart.Unsafe.write ctx "done\n" - let next_flush stateless count = if stateless then if count < _large_flush then count lsl 1 else count * 11 / 10 diff --git a/src/not-so-smart/neg.ml b/src/not-so-smart/neg.ml index 3044467a2..38e4c5b98 100644 --- a/src/not-so-smart/neg.ml +++ b/src/not-so-smart/neg.ml @@ -1,14 +1,12 @@ -open Find_common +type nonrec ('a, 's) raise = ('a, 's) Find_common.raise -type nonrec ('a, 's) raise = ('a, 's) raise - -type nonrec configuration = configuration = { +type nonrec configuration = Find_common.configuration = { stateless : bool; mutable multi_ack : [ `None | `Some | `Detailed ]; no_done : bool; } -type nonrec 'uid hex = 'uid hex = { +type nonrec 'uid hex = 'uid Find_common.hex = { to_hex : 'uid -> string; of_hex : string -> 'uid; compare : 'uid -> 'uid -> int; @@ -16,7 +14,7 @@ type nonrec 'uid hex = 'uid hex = { type 'uid negotiator = 'uid Default.t -let negotiator ~compare = Default.make ~compare -let run = run -let find_common = find_common -let tips = tips +let make ~compare = Default.make ~compare +let run = Find_common.run +let find_common = Find_common.find_common +let tips = Find_common.tips diff --git a/src/not-so-smart/neg.mli b/src/not-so-smart/neg.mli index 672bb3757..362122158 100644 --- a/src/not-so-smart/neg.mli +++ b/src/not-so-smart/neg.mli @@ -34,7 +34,7 @@ type 'uid hex = { type ('a, 's) raise = exn -> ('a, 's) io type 'uid negotiator -val negotiator : compare:('uid -> 'uid -> int) -> 'uid negotiator +val make : compare:('uid -> 'uid -> int) -> 'uid negotiator val run : 's scheduler -> diff --git a/src/not-so-smart/state.ml b/src/not-so-smart/state.ml index 7a8880670..4f51a18ac 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -48,8 +48,8 @@ module Context = struct let make capabilities = { - encoder = Encoder.encoder (); - decoder = Decoder.decoder (); + encoder = Encoder.create (); + decoder = Decoder.create (); capabilities = capabilities, []; } @@ -63,8 +63,7 @@ module Context = struct let shared capability t = let client_side, server_side = t.capabilities in let a = List.exists (Capability.equal capability) client_side in - let b = List.exists (Capability.equal capability) server_side in - a && b + a && List.exists (Capability.equal capability) server_side end module Scheduler @@ -75,25 +74,38 @@ module Scheduler struct type error = Value.error - let rec go ~f m = - match m with - | Return v -> f v - | Read { k; off; len; buffer; eof } -> - Read { k = go ~f <.> k; off; len; buffer; eof = go ~f <.> eof } - | Write { k; off; len; buffer } -> - Write { k = go ~f <.> k; off; len; buffer } - | Error err -> Error err - let bind : ('a, 'err) t -> f:('a -> ('b, 'err) t) -> ('b, 'err) t = - fun m ~f -> - match m with - | Return v -> f v - | Error err -> Error err - | Read _ -> go ~f m - | Write _ -> go ~f m + let rec aux ~f m = + match m with + | Return v -> f v + | Read { k; off; len; buffer; eof } -> + Read { k = aux ~f <.> k; off; len; buffer; eof = aux ~f <.> eof } + | Write { k; off; len; buffer } -> + Write { k = aux ~f <.> k; off; len; buffer } + | Error err -> Error err + in + fun m ~f -> + match m with + | Return v -> f v + | Error err -> Error err + | Read _ -> aux ~f m + | Write _ -> aux ~f m let ( let* ) m f = bind m ~f let ( >>= ) m f = bind m ~f + let return v = Return v + let fail error = Error error + + let reword_error f x = + let rec go = function + | Read { k; buffer; off; len; eof } -> + Read { k = go <.> k; buffer; off; len; eof = go <.> eof } + | Write { k; buffer; off; len } -> + Write { k = go <.> k; buffer; off; len } + | Return v -> Return v + | Error err -> Error (f err) + in + go x let encode : type a. @@ -139,18 +151,5 @@ struct = fun ctx w -> decode ctx w (fun _ctx v -> Return v) - let reword_error f x = - let rec go = function - | Read { k; buffer; off; len; eof } -> - Read { k = go <.> k; buffer; off; len; eof = go <.> eof } - | Write { k; buffer; off; len } -> - Write { k = go <.> k; buffer; off; len } - | Return v -> Return v - | Error err -> Error (f err) - in - go x - - let return v = Return v - let fail error = Error error - let error_msgf fmt = Fmt.kstrf (fun err -> Error (`Msg err)) fmt + let error_msgf fmt = Fmt.kstr (fun err -> Error (`Msg err)) fmt end diff --git a/src/not-so-smart/state.mli b/src/not-so-smart/state.mli index 5030e9430..e3641ebf5 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -54,6 +54,9 @@ module Scheduler val bind : ('a, 'err) t -> f:('a -> ('b, 'err) t) -> ('b, 'err) t val ( let* ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t val ( >>= ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t + val return : 'v -> ('v, 'err) t + val fail : 'err -> ('v, 'err) t + val reword_error : ('err0 -> 'err1) -> ('v, 'err0) t -> ('v, 'err1) t val encode : Context.t -> @@ -72,9 +75,6 @@ module Scheduler Context.t -> 'a Value.send -> 'a -> (unit, [> `Protocol of error ]) t val recv : Context.t -> 'a Value.recv -> ('a, [> `Protocol of error ]) t - val return : 'v -> ('v, 'err) t - val fail : 'err -> ('v, 'err) t - val reword_error : ('err0 -> 'err1) -> ('v, 'err0) t -> ('v, 'err1) t val error_msgf : ('a, Format.formatter, unit, ('b, [> `Msg of string ]) t) format4 -> 'a