Functorize State.Context and make client vs server capability handling more explicit

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 ->

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

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 ()

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

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,14 +159,14 @@ 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
   | #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
+    let encoder = Context.encoder context in
     Protocol.Encoder.unsafe_encode_packet encoder ~packet
 end

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

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

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