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..34188c762 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -111,12 +111,25 @@ 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 + include State.Context (struct + type t = capabilities + end) + + let make ~client_caps = make { client_caps; server_caps = [] } + 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 +156,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 +164,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..9f6d11797 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -33,13 +33,17 @@ module type VALUE = sig val decode : decoder -> 'a recv -> ('a, error) t end -module Context = struct +module type Additional_context = sig + type t +end + +module Context (Ac : Additional_context) = struct open Pkt_line type t = { encoder : Encoder.encoder; decoder : Decoder.decoder; - mutable capabilities : Capability.t list * Capability.t list; + mutable ctx : Ac.t; } type encoder = Encoder.encoder @@ -47,24 +51,16 @@ module Context = struct let pp _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:Ac.t -> Ac.t) = + 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..7aca3ca0b 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -32,20 +32,19 @@ module type VALUE = sig val decode : decoder -> 'a recv -> ('a, error) t end -module Context : sig - open Pkt_line +module type Additional_context = sig + type t +end +module Context : functor (Ac : Additional_context) -> sig 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] *) + with type encoder = Pkt_line.Encoder.encoder + and type decoder = Pkt_line.Decoder.decoder - 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 make : Ac.t -> t + val context : t -> Ac.t + val update : t -> f:(old_ctx:Ac.t -> Ac.t) -> unit end module Scheduler