From c398cd664d809aa6d9a08f3c73f4cecba2f09cd4 Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Mon, 8 Feb 2021 12:57:37 +0500 Subject: [PATCH] we want 'state_flow.ml' (previously 'smart_flow.ml'), a module that translates state read-write monad into 'flow' operations, to be usable both by 'Smart' and 'Wire_proto_v2'; hence, they shouldn't have own copies of Context --- fuzz/dune | 2 +- src/git/dune | 9 ++++---- src/not-so-smart/dune | 25 ++++++++++++-------- src/not-so-smart/fetch.mli | 2 +- src/not-so-smart/smart.ml | 28 ++--------------------- src/not-so-smart/state.ml | 38 +++++++++++++++++++------------ src/not-so-smart/state.mli | 21 ++++++++++------- src/not-so-smart/state_flow.ml | 16 ++++++------- src/not-so-smart/wire_proto_v2.ml | 28 ++--------------------- test/smart/dune | 12 +++++----- 10 files changed, 78 insertions(+), 103 deletions(-) diff --git a/fuzz/dune b/fuzz/dune index 2958a4957..a31aa53a6 100644 --- a/fuzz/dune +++ b/fuzz/dune @@ -11,7 +11,7 @@ (executable (name smart) (modules smart) - (libraries fmt crowbar digestif.c git.nss.smart)) + (libraries capability fmt crowbar digestif.c git.nss.smart)) (rule (alias runtest) diff --git a/src/git/dune b/src/git/dune index a2751b0ae..1cc46266a 100644 --- a/src/git/dune +++ b/src/git/dune @@ -1,7 +1,8 @@ (library (name git) (public_name git) - (libraries bigarray-compat mimic rresult git.nss.sigs git.nss.pck optint - loose decompress.de decompress.zl result git.nss.smart logs lwt cstruct - angstrom bigstringaf carton ke fmt checkseum git.nss.git git.nss.hkt - ocamlgraph astring fpath loose_git carton-lwt carton-git digestif encore)) + (libraries bigarray-compat capability mimic rresult git.nss.sigs git.nss.pck + optint loose decompress.de decompress.zl result git.nss.smart logs lwt + cstruct angstrom bigstringaf carton ke fmt checkseum git.nss.git + git.nss.hkt ocamlgraph astring fpath loose_git carton-lwt carton-git + digestif encore)) diff --git a/src/not-so-smart/dune b/src/not-so-smart/dune index 38b30d3de..7f3913559 100644 --- a/src/not-so-smart/dune +++ b/src/not-so-smart/dune @@ -8,14 +8,20 @@ (name state) (public_name git.nss.state) (modules state) - (libraries git.nss.pkt-line fmt)) + (libraries git.nss.capability git.nss.pkt-line fmt)) + +(library + (name capability) + (public_name git.nss.capability) + (modules capability) + (libraries astring fmt)) (library (name smart) (public_name git.nss.smart) - (modules smart filter capability protocol) - (libraries git.nss.pkt-line git.nss.state result rresult ipaddr domain-name - astring fmt)) + (modules smart filter protocol) + (libraries git.nss.pkt-line git.nss.state capability result rresult ipaddr + domain-name astring fmt)) (library (name wire_proto_v2) @@ -52,14 +58,14 @@ (name pck) (public_name git.nss.pck) (modules pck) - (libraries sigs psq logs smart)) + (libraries sigs capability psq logs smart)) (library (name nss) (public_name git.nss) (modules nss fetch push) (libraries fmt result rresult logs ipaddr domain-name smart sigs neg pck - git.nss.state-flow git.nss.state wire_proto_v2)) + capability git.nss.state-flow git.nss.state wire_proto_v2)) (library (name unixiz) @@ -72,6 +78,7 @@ (name smart_git) (public_name git.nss.git) (modules smart_git smart_git_intf) - (libraries bigarray-compat mimic mirage-flow unixiz ipaddr decompress.de - decompress.zl cstruct logs astring result rresult bigstringaf fmt emile - lwt domain-name uri sigs smart pck nss digestif carton carton-lwt)) + (libraries bigarray-compat capability mimic mirage-flow unixiz ipaddr + decompress.de decompress.zl cstruct logs astring result rresult + bigstringaf fmt emile lwt domain-name uri sigs smart pck nss digestif + carton carton-lwt)) diff --git a/src/not-so-smart/fetch.mli b/src/not-so-smart/fetch.mli index 33dfec5dc..b13dbf88e 100644 --- a/src/not-so-smart/fetch.mli +++ b/src/not-so-smart/fetch.mli @@ -44,7 +44,7 @@ module Make ?uses_git_transport:bool -> host:[ `host ] Domain_name.t -> path:string -> - Wire_proto_v2.Context.capabilities State.Context.t -> + State.Context.t -> Flow.t -> Wire_proto_v2.Proto_vals_v2.Ls_refs.request -> Wire_proto_v2.Proto_vals_v2.Ls_refs.response IO.t diff --git a/src/not-so-smart/smart.ml b/src/not-so-smart/smart.ml index be2127b81..b462d549b 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -110,31 +110,7 @@ type ('a, 'err) t = ('a, 'err) State.t = | Return of 'a | Error of 'err -module Context = struct - type capabilities = { - client_caps : Capability.t list; - server_caps : Capability.t list; - } - - 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 - +module Context = State.Context include Witness let proto_request = Proto_request @@ -159,7 +135,7 @@ let send_pack ?(stateless = false) side_band = let packet ~trim = Packet trim let send_advertised_refs : _ send = Advertised_refs -include State.Scheduler (Context) (Value) +include State.Scheduler (Value) let pp_error ppf = function | #Protocol.Encoder.error as err -> Protocol.Encoder.pp_error ppf err diff --git a/src/not-so-smart/state.ml b/src/not-so-smart/state.ml index 13c38c033..371e23776 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -34,33 +34,43 @@ module type VALUE = sig end module Context = struct - open Pkt_line + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } - type 'ctx t = { - encoder : Encoder.encoder; - decoder : Decoder.decoder; - mutable ctx : 'ctx; + type t = { + encoder : Pkt_line.Encoder.encoder; + decoder : Pkt_line.Decoder.decoder; + mutable capabilities : capabilities; } - type encoder = Encoder.encoder - type decoder = Decoder.decoder + type encoder = Pkt_line.Encoder.encoder + type decoder = Pkt_line.Decoder.decoder let pp _pp_ctx _ppf _t = () - let make ctx = - { encoder = Encoder.create (); decoder = Decoder.create (); ctx } + let make ~client_caps = + let capabilities = { client_caps; server_caps = [] } in + { + encoder = Pkt_line.Encoder.create (); + decoder = Pkt_line.Decoder.create (); + capabilities; + } let encoder { encoder; _ } = encoder let decoder { decoder; _ } = decoder - let context { ctx; _ } = ctx + let capabilities { capabilities; _ } = capabilities + + let replace_server_caps ctx server_caps = + ctx.capabilities <- { ctx.capabilities with server_caps } - let update t ~(f : old_ctx:'ctx -> 'ctx) = - let new_ctx = f ~old_ctx:t.ctx in - t.ctx <- new_ctx + let is_cap_shared { capabilities = { client_caps; server_caps }; _ } cap = + 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 module Scheduler - (Context : CONTEXT) (Value : VALUE with type encoder = Context.encoder and type decoder = Context.decoder) = diff --git a/src/not-so-smart/state.mli b/src/not-so-smart/state.mli index f5ec304f7..9b382edbf 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -33,20 +33,25 @@ module type VALUE = sig end module Context : sig - type 'ctx t + type t type encoder = Pkt_line.Encoder.encoder type decoder = Pkt_line.Decoder.decoder - 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 + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } + + val pp : Capability.t Fmt.t -> t Fmt.t + val make : client_caps:Capability.t list -> t + val encoder : t -> encoder + val decoder : t -> decoder + val capabilities : t -> capabilities + val replace_server_caps : t -> Capability.t list -> unit + val is_cap_shared : t -> Capability.t -> bool end module Scheduler - (Context : CONTEXT) (Value : VALUE with type encoder = Context.encoder and type decoder = Context.decoder) : sig diff --git a/src/not-so-smart/state_flow.ml b/src/not-so-smart/state_flow.ml index a9a0217c7..a9bb6ef67 100644 --- a/src/not-so-smart/state_flow.ml +++ b/src/not-so-smart/state_flow.ml @@ -24,7 +24,7 @@ struct fl -> ('res, [ `Protocol of error ]) Read_write.t -> ('res, s) io = - fun scheduler io_raise _Flow flow state -> + fun scheduler io_raise flow_ops flow state -> let { bind; return } = scheduler in let ( >>= ) = bind in @@ -45,7 +45,7 @@ struct | Read { k; buffer; off; len; eof } -> ( let rd_n_bytes = min (Cstruct.len cbuff) len in Log.debug (fun m -> m "Start to read %d byte(s)." rd_n_bytes); - _Flow.recv flow (Cstruct.sub cbuff 0 rd_n_bytes) >>= function + flow_ops.recv flow (Cstruct.sub cbuff 0 rd_n_bytes) >>= function | Ok `End_of_flow -> Log.debug (fun m -> m "Got end of input."); unwrap (eof ()) @@ -54,20 +54,20 @@ struct Cstruct.blit_to_bytes cbuff 0 buffer off len; unwrap (k len) | Error err -> - Log.err (fun m -> m "Got an error: %a." _Flow.pp_error err); - failwithf "%a" _Flow.pp_error err) + Log.err (fun m -> m "Got an error: %a." flow_ops.pp_error err); + failwithf "%a" flow_ops.pp_error err) | Write { k; buffer; off; len } -> - (* TODO: Avoid writing by loop if we can; - otherwise, the loop writes once and terminates *) + (* TODO: almost always we can write in one go instead of calling a loop, + so we should try writing and call loop if we aren't done *) let rec loop tmp = if Cstruct.is_empty tmp then unwrap (k len) else - _Flow.send flow tmp >>= function + flow_ops.send flow tmp >>= function | Ok shift -> Log.debug (fun m -> m "Wrote %d byte(s). %s" shift (Cstruct.to_string tmp)); loop (Cstruct.shift tmp shift) - | Error err -> failwithf "%a" _Flow.pp_error err + | Error err -> failwithf "%a" flow_ops.pp_error err in Cstruct.of_string buffer ~off ~len |> loop in diff --git a/src/not-so-smart/wire_proto_v2.ml b/src/not-so-smart/wire_proto_v2.ml index 4937513bb..2b537b82f 100644 --- a/src/not-so-smart/wire_proto_v2.ml +++ b/src/not-so-smart/wire_proto_v2.ml @@ -18,31 +18,7 @@ module Witness = struct | Ls_refs_res : Proto_vals_v2.Ls_refs.response recv end -(* TODO: copy of Smart.Context; remove duplication *) -module Context = struct - type capabilities = { - client_caps : Capability.t list; - server_caps : Capability.t list; - } - - 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 +module Context = State.Context type ('a, 'err) t = ('a, 'err) State.t = | Read of { @@ -102,7 +78,7 @@ module Value = struct | Ls_refs_res -> Proto_vals_v2.Decoder.decode_ls_refs_response decoder) end -include State.Scheduler (Context) (Value) +include State.Scheduler (Value) let pp_error ppf = function | #Proto_vals_v2.Encoder.error as err -> diff --git a/test/smart/dune b/test/smart/dune index 05af015fb..6fefe972a 100644 --- a/test/smart/dune +++ b/test/smart/dune @@ -2,12 +2,12 @@ (name test) (modules append fifo hTTP loopback lwt_backend ref store_backend test uid unix_backend pipe) - (libraries bigarray-compat mirage-flow mimic git.nss.unixiz git git-unix - result curl.lwt mirage-crypto-rng.unix digestif digestif.c domain-name - git.nss git.nss.wire-proto-v2 git.nss.git bos fpath carton-lwt bigstringaf - git.nss.sigs git.nss.hkt fmt git.nss.pck carton rresult alcotest - git.nss.smart lwt.unix mmap astring lwt cstruct uri fmt.tty logs.fmt - alcotest-lwt cohttp-lwt-unix git-cohttp-unix)) + (libraries bigarray-compat capability git.nss.state mirage-flow mimic + git.nss.unixiz git git-unix result curl.lwt mirage-crypto-rng.unix + digestif digestif.c domain-name git.nss git.nss.wire-proto-v2 git.nss.git + bos fpath carton-lwt bigstringaf git.nss.sigs git.nss.hkt fmt git.nss.pck + carton rresult alcotest git.nss.smart lwt.unix mmap astring lwt cstruct + uri fmt.tty logs.fmt alcotest-lwt cohttp-lwt-unix git-cohttp-unix)) (executable (name test_edn)