diff --git a/fuzz/smart.ml b/fuzz/smart.ml index 8b9e35fea..252c8fc16 100644 --- a/fuzz/smart.ml +++ b/fuzz/smart.ml @@ -52,7 +52,7 @@ let ( >>= ) = Crowbar.dynamic_bind let () = let of_string str = - let ctx = Smart.Context.make [] in + let ctx = Smart.Context.make ~client_caps:[] in let state = Smart.decode ctx (Smart.packet ~trim:false) (fun _ctx res -> Return res) in @@ -85,7 +85,7 @@ let () = let () = let of_string str = - let ctx = Smart.Context.make [] in + let ctx = Smart.Context.make ~client_caps:[] in let state = Smart.decode ctx Smart.advertised_refs (fun _ctx res -> Return res) in @@ -105,7 +105,7 @@ let () = go state in let to_string v = - let ctx = Smart.Context.make [] in + let ctx = Smart.Context.make ~client_caps:[] in let buf = Buffer.create 0x1000 in let state = Smart.encode ctx Smart.send_advertised_refs v (fun _ctx -> diff --git a/src/not-so-smart/fetch.ml b/src/not-so-smart/fetch.ml index 9c804a893..7702aceaa 100644 --- a/src/not-so-smart/fetch.ml +++ b/src/not-so-smart/fetch.ml @@ -75,7 +75,7 @@ struct let fetch_v1 ?(uses_git_transport = false) ?(push_stdout = ignore) ?(push_stderr = ignore) ~capabilities ?deepen ?want:(refs = `None) ~host path flow store access fetch_cfg pack = - let capabilities = + let client_caps = (* XXX(dinosaure): HTTP ([stateless]) enforces no-done capabilities. Otherwise, you never will receive the PACK file. *) if fetch_cfg.Neg.no_done && not (no_done capabilities) then @@ -93,10 +93,11 @@ struct let* v = recv ctx advertised_refs in let v = Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v in let uids, refs = references refs (Smart.Advertised_refs.refs v) in - Smart.Context.update ctx (Smart.Advertised_refs.capabilities v); + let server_caps = Smart.Advertised_refs.capabilities v in + Smart.Context.replace_server_caps ctx server_caps; return (uids, refs) in - let ctx = Smart.Context.make capabilities in + let ctx = Smart.Context.make ~client_caps in let negotiator = Neg.make ~compare:Uid.compare in Neg.tips sched access store negotiator |> prj >>= fun () -> Smart_flow.run sched fail io flow (prelude ctx) |> prj diff --git a/src/not-so-smart/find_common.ml b/src/not-so-smart/find_common.ml index 5289b4df1..41e965b20 100644 --- a/src/not-so-smart/find_common.ml +++ b/src/not-so-smart/find_common.ml @@ -108,13 +108,16 @@ let find_common ({ bind; return } as scheduler) io flow Smart.( let uid = (to_hex <.> fst) uid in let others = List.map (to_hex <.> fst) others in - let capabilities, _ = Smart.Context.capabilities ctx in + let { Smart.Context.client_caps; _ } = + Smart.Context.capabilities ctx + in let deepen = (deepen :> [ `Depth of int | `Not of string | `Timestamp of int64 ] option) in send ctx want - (Want.want ~capabilities ~shallows:shallowed ?deepen uid ~others)) + (Want.want ~capabilities:client_caps ~shallows:shallowed ?deepen uid + ~others)) >>= fun () -> (match deepen with | None -> return () diff --git a/src/not-so-smart/push.ml b/src/not-so-smart/push.ml index 3375c65a6..0567e0679 100644 --- a/src/not-so-smart/push.ml +++ b/src/not-so-smart/push.ml @@ -39,8 +39,8 @@ struct pp_error = Flow.pp_error; } - let push ?(uses_git_transport = true) ~capabilities:caps cmds ~host path flow - store access push_cfg pack = + let push ?(uses_git_transport = true) ~capabilities:client_caps cmds ~host + path flow store access push_cfg pack = let fiber ctx = let open Smart in let* () = @@ -50,10 +50,11 @@ struct else return () in let* v = recv ctx advertised_refs in - Context.update ctx (Smart.Advertised_refs.capabilities v); + let server_caps = Smart.Advertised_refs.capabilities v in + Context.replace_server_caps ctx server_caps; return (Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v) in - let ctx = Smart.Context.make caps in + let ctx = Smart.Context.make ~client_caps in Smart_flow.run sched fail io flow (fiber ctx) |> prj >>= fun advertised_refs -> Pck.commands sched diff --git a/src/not-so-smart/smart.ml b/src/not-so-smart/smart.ml index 7813c9d3d..66c304240 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -111,12 +111,28 @@ type ('a, 'err) t = ('a, 'err) State.t = | Error of 'err module Context = struct - type t = State.Context.t + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } - let make = State.Context.make - let update = State.Context.update - let is_cap_shared = State.Context.is_cap_shared - let capabilities = State.Context.capabilities + let pp_capabilities _ppf _v = () + + include State.Context + + type nonrec t = capabilities t + + let make ~client_caps = make { client_caps; server_caps = [] } + let pp ppf v = pp pp_capabilities ppf v + let capabilities ctx = context ctx + + let replace_server_caps ctx caps = + update ~f:(fun ~old_ctx -> { old_ctx with server_caps = caps }) ctx + + let is_cap_shared ctx cap = + let { client_caps; server_caps } = capabilities ctx in + let is_cap_in caps = List.exists (fun c -> Capability.equal c cap) caps in + is_cap_in client_caps && is_cap_in server_caps end include Witness @@ -143,7 +159,7 @@ let send_pack ?(stateless = false) side_band = let packet ~trim = Packet trim let send_advertised_refs : _ send = Advertised_refs -include State.Scheduler (State.Context) (Value) +include State.Scheduler (Context) (Value) let pp_error ppf = function | #Protocol.Encoder.error as err -> Protocol.Encoder.pp_error ppf err @@ -151,6 +167,6 @@ let pp_error ppf = function module Unsafe = struct let write context packet = - let encoder = State.Context.encoder context in + let encoder = Context.encoder context in Protocol.Encoder.unsafe_encode_packet encoder ~packet end diff --git a/src/not-so-smart/smart.mli b/src/not-so-smart/smart.mli index 603a2a411..1425f4d1b 100644 --- a/src/not-so-smart/smart.mli +++ b/src/not-so-smart/smart.mli @@ -194,10 +194,15 @@ val pp_error : error Fmt.t module Context : sig type t - val make : Capability.t list -> t - val update : t -> Capability.t list -> unit + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } + + val make : client_caps:Capability.t list -> t + val capabilities : t -> capabilities + val replace_server_caps : t -> Capability.t list -> unit val is_cap_shared : t -> Capability.t -> bool - val capabilities : t -> Capability.t list * Capability.t list end type 'a send diff --git a/src/not-so-smart/state.ml b/src/not-so-smart/state.ml index e44057a74..53502d9e6 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -36,35 +36,27 @@ end module Context = struct open Pkt_line - type t = { + type 'ctx t = { encoder : Encoder.encoder; decoder : Decoder.decoder; - mutable capabilities : Capability.t list * Capability.t list; + mutable ctx : 'ctx; } type encoder = Encoder.encoder type decoder = Decoder.decoder - let pp _ppf _t = () + let pp _pp_ctx _ppf _t = () - let make capabilities = - { - encoder = Encoder.create (); - decoder = Decoder.create (); - capabilities = capabilities, []; - } + let make ctx = + { encoder = Encoder.create (); decoder = Decoder.create (); ctx } let encoder { encoder; _ } = encoder let decoder { decoder; _ } = decoder - let capabilities { capabilities; _ } = capabilities - - let update ({ capabilities = client_side, _; _ } as t) server_side = - t.capabilities <- client_side, server_side + let context { ctx; _ } = ctx - let is_cap_shared t capability = - let client_side, server_side = t.capabilities in - let a = List.exists (Capability.equal capability) client_side in - a && List.exists (Capability.equal capability) server_side + let update t ~(f : old_ctx:'ctx -> 'ctx) = + let new_ctx = f ~old_ctx:t.ctx in + t.ctx <- new_ctx end module Scheduler diff --git a/src/not-so-smart/state.mli b/src/not-so-smart/state.mli index fa6748125..2549d88cd 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -33,19 +33,16 @@ module type VALUE = sig end module Context : sig - open Pkt_line + type 'ctx t + type encoder = Pkt_line.Encoder.encoder + type decoder = Pkt_line.Decoder.decoder - include - CONTEXT - with type encoder = Encoder.encoder - and type decoder = Decoder.decoder - - val make : Capability.t list -> t - (** [make caps] creates [Context.t] with client's capabilities [caps] *) - - val capabilities : t -> Capability.t list * Capability.t list - val update : t -> Capability.t list -> unit - val is_cap_shared : t -> Capability.t -> bool + val pp : 'ctx Fmt.t -> 'ctx t Fmt.t + val encoder : 'ctx t -> encoder + val decoder : 'ctx t -> decoder + val make : 'ctx -> 'ctx t + val context : 'ctx t -> 'ctx + val update : 'ctx t -> f:(old_ctx:'ctx -> 'ctx) -> unit end module Scheduler