Skip to content

Commit

Permalink
Merge pull request #342 from samoht/remove-labels
Browse files Browse the repository at this point in the history
Remove labels
  • Loading branch information
samoht authored Nov 29, 2020
2 parents b57f635 + f82baca commit eab97d3
Show file tree
Hide file tree
Showing 26 changed files with 140 additions and 168 deletions.
6 changes: 3 additions & 3 deletions bench/cost.ml
Original file line number Diff line number Diff line change
Expand Up @@ -86,11 +86,11 @@ module Fake_protocol2 = struct
let close _ = Ok ()
end

let fake0 = Tuyau.register ~protocol:(module Fake_protocol0)
let fake0 = Tuyau.register (module Fake_protocol0)

let fake1 = Tuyau.register ~protocol:(module Fake_protocol1)
let fake1 = Tuyau.register (module Fake_protocol1)

let fake2 = Tuyau.register ~protocol:(module Fake_protocol2)
let fake2 = Tuyau.register (module Fake_protocol2)

let hello_world = "Hello World!\n"

Expand Down
8 changes: 4 additions & 4 deletions src/async-ssl/conduit_async_ssl.ml
Original file line number Diff line number Diff line change
Expand Up @@ -189,7 +189,7 @@ let protocol_with_ssl :
let writer = writer
end in
let module M = Protocol (Flow) in
Conduit_async.register ~protocol:(module M)
Conduit_async.register (module M)

module Make (Service : sig
include Conduit_async.SERVICE
Expand Down Expand Up @@ -279,11 +279,11 @@ end

let service_with_ssl :
type cfg edn t flow.
(cfg, t, flow) Conduit_async.Service.service ->
(cfg, t, flow) Conduit_async.Service.t ->
reader:(flow -> Reader.t) ->
writer:(flow -> Writer.t) ->
(edn, flow with_ssl) Conduit_async.protocol ->
(context * cfg, context * t, flow with_ssl) Conduit_async.Service.service =
(context * cfg, context * t, flow with_ssl) Conduit_async.Service.t =
fun service ~reader ~writer protocol ->
let module S = (val Conduit_async.Service.impl service) in
let module Service = struct
Expand All @@ -294,7 +294,7 @@ let service_with_ssl :
let writer = writer
end in
let module M = Make (Service) in
Conduit_async.Service.register ~service:(module M) ~protocol
Conduit_async.Service.register (module M) protocol

module TCP = struct
open Conduit_async.TCP
Expand Down
4 changes: 2 additions & 2 deletions src/async-ssl/conduit_async_ssl.mli
Original file line number Diff line number Diff line change
Expand Up @@ -50,11 +50,11 @@ val protocol_with_ssl :
(context * 'edn, 'flow with_ssl) protocol

val service_with_ssl :
('cfg, 't, 'flow) Service.service ->
('cfg, 't, 'flow) Service.t ->
reader:('flow -> Reader.t) ->
writer:('flow -> Writer.t) ->
('edn, 'flow with_ssl) protocol ->
(context * 'cfg, context * 't, 'flow with_ssl) Service.service
(context * 'cfg, context * 't, 'flow with_ssl) Service.t

(** {2 Composition between Host's TCP/IP stack protocol and SSL.} *)

Expand Down
4 changes: 2 additions & 2 deletions src/async-tls/conduit_async_tls.mli
Original file line number Diff line number Diff line change
Expand Up @@ -15,12 +15,12 @@ val protocol_with_tls :
type 'service service_with_tls

val service_with_tls :
('cfg, 't, 'flow) Service.service ->
('cfg, 't, 'flow) Service.t ->
('edn, 'flow protocol_with_tls) protocol ->
( 'cfg * Tls.Config.server,
't service_with_tls,
'flow protocol_with_tls )
Service.service
Service.t

(** {2 Composition between Host's TCP/IP stack protocol and TLS.} *)

Expand Down
12 changes: 6 additions & 6 deletions src/async/conduit_async.ml
Original file line number Diff line number Diff line change
Expand Up @@ -13,21 +13,21 @@ let failwith fmt = Format.kasprintf failwith fmt

let ( >>? ) x f = Async.Deferred.Result.bind x ~f

type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service
type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t

let serve :
type cfg t v.
?timeout:int ->
handler:(flow -> unit Async.Deferred.t) ->
service:(cfg, t, v) service ->
(cfg, t, v) service ->
cfg ->
unit Async.Condition.t * (unit -> unit Async.Deferred.t) =
fun ?timeout ~handler ~service cfg ->
fun ?timeout ~handler service cfg ->
let open Async in
let stop = Async.Condition.create () in
let module Svc = (val Service.impl service) in
let main () =
Service.init cfg ~service >>= function
Service.init service cfg >>= function
| Error err -> failwith "%a" Service.pp_error err
| Ok t -> (
let rec loop () =
Expand Down Expand Up @@ -180,7 +180,7 @@ module TCP = struct
Writer.close writer >>= fun () -> Async.return (Ok ()))
end

let protocol = register ~protocol:(module Protocol)
let protocol = register (module Protocol)

type configuration =
| Listen : int option * ('a, 'b) Tcp.Where_to_listen.t -> configuration
Expand Down Expand Up @@ -246,7 +246,7 @@ module TCP = struct
Fd.close (Socket.fd socket) >>= fun () -> Async.return (Ok ())
end

let service = S.register ~service:(module Service) ~protocol
let service = S.register (module Service) protocol

let resolve ~port = function
| Conduit.Endpoint.IP ip ->
Expand Down
12 changes: 6 additions & 6 deletions src/async/conduit_async.mli
Original file line number Diff line number Diff line change
Expand Up @@ -10,21 +10,21 @@ include
and type output = Cstruct.t
and type +'a io = 'a Async.Deferred.t

type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.service
type ('a, 'b, 'c) service = ('a, 'b, 'c) Service.t
(** The type for async services. *)

val serve :
?timeout:int ->
handler:(flow -> unit Async.Deferred.t) ->
service:('cfg, 't, 'v) service ->
('cfg, 't, 'v) service ->
'cfg ->
unit Async.Condition.t * (unit -> unit Async.Deferred.t)
(** [serve ~handler ~service cfg] creates an usual infinite [service] loop from
the given configuration ['cfg]. It returns the {i promise} to launch the
loop and a condition variable to stop the loop.
(** [serve ~handler t cfg] creates an infinite service loop from the given
configuration ['cfg]. It returns the {i promise} to launch the loop and a
condition variable to stop the loop.
{[
let stop, loop = serve ~handler ~service:TCP.service cfg in
let stop, loop = serve ~handler TCP.service cfg in
Async_unix.Signal.handle [ Core.Signal.int ] ~f:(fun _sig ->
Async.Condition.broadcast stop ()) ;
loop ()
Expand Down
46 changes: 20 additions & 26 deletions src/core/conduit.ml
Original file line number Diff line number Diff line change
Expand Up @@ -171,9 +171,8 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) :
| Ok _ as v -> v
| Error err -> Error (`Msg (strf "%a" Protocol.pp_error err))

let register :
type edn flow. protocol:(edn, flow) impl -> (edn, flow) protocol =
fun ~protocol ->
let register : type edn flow. (edn, flow) impl -> (edn, flow) protocol =
fun protocol ->
let key = Map.Key.create "" in
Ptr.inj (Protocol (key, protocol))

Expand Down Expand Up @@ -365,17 +364,15 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) :

module Svc = E0.Make (F)

type ('cfg, 't, 'flow) service =
type ('cfg, 't, 'flow) t =
| Service :
('cfg, 't, 'flow) thd Svc.s * (_, 'flow) protocol
-> ('cfg, 't, 'flow) service
-> ('cfg, 't, 'flow) t

let register :
type cfg t flow.
service:(cfg, t, flow) impl ->
protocol:(_, flow) protocol ->
(cfg, t, flow) service =
fun ~service ~protocol ->
type cfg s flow.
(cfg, s, flow) impl -> (_, flow) protocol -> (cfg, s, flow) t =
fun service protocol ->
let cfg = Map.Key.create "" in
Service (Svc.inj (Svc (cfg, service)), protocol)

Expand All @@ -385,48 +382,45 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) :

let equal :
type a b c d e f.
(a, b, c) service ->
(d, e, f) service ->
(a, b, c) t ->
(d, e, f) t ->
((a, d) refl * (b, e) refl * (c, f) refl) option =
fun (Service ((module A), _)) (Service ((module B), _)) ->
match A.Id with B.Id -> Some (Refl, Refl, Refl) | _ -> None

let init :
type cfg t flow.
cfg -> service:(cfg, t, flow) service -> (t, [> error ]) result io =
fun edn ~service:(Service ((module Witness), _)) ->
type cfg s flow. (cfg, s, flow) t -> cfg -> (s, [> error ]) result io =
fun (Service ((module Witness), _)) cfg ->
let (Svc (_, (module Service))) = Witness.witness in
Service.init edn >>= function
Service.init cfg >>= function
| Ok t -> return (Ok t)
| Error err -> return (error_msgf "%a" Service.pp_error err)

let accept :
type cfg t v.
service:(cfg, t, v) service -> t -> (flow, [> error ]) result io =
fun ~service:(Service ((module Witness), protocol)) t ->
type cfg s v. (cfg, s, v) t -> s -> (flow, [> error ]) result io =
fun (Service ((module Witness), protocol)) t ->
let (Svc (_, (module Service))) = Witness.witness in
Service.accept t >>= function
| Ok flow -> return (Ok (pack protocol flow))
| Error err -> return (error_msgf "%a" Service.pp_error err)

let close :
type cfg t flow.
service:(cfg, t, flow) service -> t -> (unit, [> error ]) result io =
fun ~service:(Service ((module Witness), _)) t ->
type cfg s flow. (cfg, s, flow) t -> s -> (unit, [> error ]) result io =
fun (Service ((module Witness), _)) t ->
let (Svc (_, (module Service))) = Witness.witness in
Service.close t >>= function
| Ok () -> return (Ok ())
| Error err -> return (error_msgf "%a" Service.pp_error err)

let pack : type v. (_, _, v) service -> v -> flow =
let pack : type v. (_, _, v) t -> v -> flow =
fun (Service (_, protocol)) flow -> pack protocol flow

let impl :
type cfg t flow.
(cfg, t, flow) service ->
type cfg s flow.
(cfg, s, flow) t ->
(module SERVICE
with type configuration = cfg
and type t = t
and type t = s
and type flow = flow) =
fun (Service ((module S), _)) ->
let (Svc (_, (module Service))) = S.witness in
Expand Down
67 changes: 29 additions & 38 deletions src/core/conduit_intf.ml
Original file line number Diff line number Diff line change
Expand Up @@ -206,10 +206,9 @@ module type S = sig
Endpoints allow users to create flows by either connecting directly to a
remote server or by resolving domain names (with {!connect}). *)

val register : protocol:('edn, 'flow) impl -> ('edn, 'flow) protocol
(** [register ~protocol] is the protocol using the implementation [protocol].
[protocol] must provide a [connect] function to allow client flows to be
created.
val register : ('edn, 'flow) impl -> ('edn, 'flow) protocol
(** [register i] is the protocol using the implementation [i]. [protocol] must
provide a [connect] function to allow client flows to be created.
For instance, on Unix, [Conduit] clients will use [Unix.sockaddr] as flow
endpoints, while [Unix.file_descr] would be used for the flow transport.
Expand All @@ -218,7 +217,7 @@ module type S = sig
module Conduit_tcp : sig
val t : (Unix.sockaddr, Unix.file_descr) protocol
end = struct
let t = register ~protocol:(module TCP)
let t = register (module TCP)
end
]}
Expand All @@ -230,7 +229,7 @@ module type S = sig
module Conduit_tcp_tls : sig
val t : (Unix.sockaddr * Tls.Config.client, Unix.file_descr) protocol
end = struct
let t = register ~protocol:(module TLS)
let t = register (module TLS)
end
]}
Expand Down Expand Up @@ -281,7 +280,7 @@ module type S = sig
val t : (Unix.sockaddr, Unix.file_descr) protocol
end = struct
let t = register ~protocol:(module TCP)
let t = register (module TCP)
include (val Conduit.repr t)
end
Expand Down Expand Up @@ -430,34 +429,30 @@ module type S = sig
and type t = 't
and type flow = 'flow)

type ('cfg, 't, 'flow) service
type ('cfg, 't, 'flow) t
(** The type for services, e.g. service-side protocols. ['cfg] is the type
for configuration, ['t] is the type for state states. ['flow] is the
for configuration, ['s] is the type for server states. ['flow] is the
type for underlying flows. *)

val equal :
('cfg0, 't0, 'flow0) service ->
('cfg1, 't1, 'flow1) service ->
('cfg0, 't0, 'flow0) t ->
('cfg1, 't1, 'flow1) t ->
(('cfg0, 'cfg1) refl * ('t0, 't1) refl * ('flow0, 'flow1) refl) option
(** [equal svc0 svc1] proves that [svc0] and [svc1] are physically the same.
For instance, [Conduit] asserts:
{[
let service = Service.register ~service:(module V) ;;
let service = Service.register (module V) protocol ;;
let () = match Service.equal service service with
| Some (Refl, Refl, Refl) -> ...
| _ -> assert false
]} *)

val register :
service:('cfg, 't, 'v) impl ->
protocol:(_, 'v) protocol ->
('cfg, 't, 'v) service
(** [register ~service ~protocool] is the service using the implementation
[service] bound with implementation of a [protocol]. [service] must
define [make] and [accept] function to be able to create server-side
flows.
val register : ('cfg, 't, 'v) impl -> (_, 'v) protocol -> ('cfg, 't, 'v) t
(** [register i p] is the service using the implementation [i] using the
protocol [p]. [i] should define a [make] and an [accept] function to
create server-side flows.
For instance:
Expand All @@ -466,30 +461,26 @@ module type S = sig
and type t = Unix.file_descr
and type flow = Unix.file_descr
let tcp_protocol = Conduit.register ~protocol:(module TCP_protocol)
let tcp_protocol = Conduit.register (module TCP_protocol)
let tcp_service : (Unix.sockaddr, Unix.file_descr, Unix.file_descr) Service.service =
Conduit.Service.register ~service:(module TCP_service) ~protocol:tcp_protocol
Conduit.Service.register (module TCP_service) tcp_protocol
]} *)

type error = [ `Msg of string ]

val pp_error : error Fmt.t

val init :
'cfg -> service:('cfg, 't, 'v) service -> ('t, [> error ]) result io
(** [init cfg ~service] initialises the service with the configuration
[cfg]. *)
val init : ('cfg, 't, 'v) t -> 'cfg -> ('t, [> error ]) result io
(** [init t cfg] initialises the service with the configuration [cfg]. *)

val accept :
service:('cfg, 't, 'v) service -> 't -> (flow, [> error ]) result io
(** [accept service t] waits for a connection on the service [t]. The result
is a {i flow} connected to the client. *)
val accept : ('cfg, 's, 'v) t -> 's -> (flow, [> error ]) result io
(** [accept t s] waits for a connection on the server [s]. The result is a
{i flow} connected to the client. *)

val close :
service:('cfg, 't, 'v) service -> 't -> (unit, [> error ]) result io
(** [close ~service t] releases the resources associated to the server [t]. *)
val close : ('cfg, 's, 'v) t -> 's -> (unit, [> error ]) result io
(** [close t s] releases the resources associated to the server [s]. *)

val pack : (_, _, 'v) service -> 'v -> flow
val pack : (_, _, 'v) t -> 'v -> flow
(** [pack service v] returns the abstracted value [v] as {!pack} does for a
given protocol {i witness} (bound with the given [service]). It serves
to abstract the flow created (and initialised) by the service to a
Expand All @@ -500,7 +491,7 @@ module type S = sig
Conduit.send flow "Hello World!" >>= fun _ ->
...
let run ~service cfg =
let run service cfg =
let module Service = Conduit.Service.impl service in
Service.init cfg >>? fun t ->
let rec loop t =
Expand All @@ -509,12 +500,12 @@ module type S = sig
async (fun () -> handler flow) ; loop t in
loop t
let () = run ~service:tcp_service (localhost, 8080)
let () = run ~service:tls_service (certs, (localhost, 8080))
let () = run tcp_service (localhost, 8080)
let () = run tls_service (certs, (localhost, 8080))
]} *)

val impl :
('cfg, 't, 'v) service ->
('cfg, 't, 'v) t ->
(module SERVICE
with type configuration = 'cfg
and type t = 't
Expand Down
Loading

0 comments on commit eab97d3

Please sign in to comment.