From f6bde9a8a1615f0c1fc8972bc15e63621ab65e60 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 16 May 2023 12:03:41 +0100 Subject: [PATCH] Use variant types in many places Jane Street have requested that Eio not use objects. This commit switches to an alternative scheme for representing OS resources using variants instead. The changes for users of the library are minimal - only the types change. The exception to this is if you want to provide your own implementations of resources, in which case you now provide a module rather than a class. The (small) changes to the README give a good idea of the user-facing effect. --- README.md | 58 ++---- doc/prelude.ml | 2 +- doc/rationale.md | 33 ++-- fuzz/fuzz_buf_read.ml | 22 ++- lib_eio/buf_read.ml | 33 ++-- lib_eio/buf_read.mli | 10 +- lib_eio/buf_write.mli | 2 +- lib_eio/eio.ml | 24 +-- lib_eio/eio.mli | 30 +--- lib_eio/file.ml | 123 +++++++------ lib_eio/file.mli | 104 +++++++++++ lib_eio/flow.ml | 221 +++++++++++++++-------- lib_eio/flow.mli | 126 +++++++------ lib_eio/fs.ml | 48 +++-- lib_eio/generic.ml | 13 -- lib_eio/generic.mli | 30 ---- lib_eio/mock/eio_mock.mli | 34 ++-- lib_eio/mock/flow.ml | 212 ++++++++++++---------- lib_eio/mock/net.ml | 204 ++++++++++++--------- lib_eio/net.ml | 169 +++++++++++++----- lib_eio/net.mli | 160 +++++++++++------ lib_eio/path.ml | 74 +++++--- lib_eio/path.mli | 15 +- lib_eio/process.ml | 20 ++- lib_eio/process.mli | 36 ++-- lib_eio/resource.ml | 35 ++++ lib_eio/resource.mli | 114 ++++++++++++ lib_eio/std.ml | 5 + lib_eio/std.mli | 10 ++ lib_eio/unix/eio_unix.ml | 17 +- lib_eio/unix/eio_unix.mli | 69 +++++-- lib_eio/unix/net.ml | 41 ++--- lib_eio/unix/net.mli | 35 ++-- lib_eio/unix/private.ml | 2 +- lib_eio/unix/process.ml | 6 +- lib_eio/unix/process.mli | 14 +- lib_eio/unix/resource.ml | 50 +++++- lib_eio/unix/types.ml | 6 +- lib_eio_linux/eio_linux.ml | 297 +++++++++++++++++++------------ lib_eio_linux/eio_linux.mli | 7 +- lib_eio_posix/domain_mgr.ml | 18 +- lib_eio_posix/eio_posix.ml | 10 +- lib_eio_posix/flow.ml | 180 ++++++++++--------- lib_eio_posix/fs.ml | 209 +++++++++++----------- lib_eio_posix/net.ml | 98 +++++++--- lib_eio_posix/process.ml | 6 +- lib_eio_windows/domain_mgr.ml | 18 +- lib_eio_windows/eio_windows.ml | 10 +- lib_eio_windows/flow.ml | 167 +++++++++-------- lib_eio_windows/fs.ml | 216 +++++++++++----------- lib_eio_windows/net.ml | 99 +++++++---- lib_eio_windows/test/test_net.ml | 4 +- tests/buf_reader.md | 41 +++-- tests/buf_write.md | 12 +- tests/flow.md | 20 +-- tests/network.md | 21 ++- 56 files changed, 2214 insertions(+), 1426 deletions(-) create mode 100644 lib_eio/file.mli delete mode 100644 lib_eio/generic.ml delete mode 100644 lib_eio/generic.mli create mode 100644 lib_eio/resource.ml create mode 100644 lib_eio/resource.mli create mode 100644 lib_eio/std.ml create mode 100644 lib_eio/std.mli diff --git a/README.md b/README.md index a32e3701d..e7103805a 100644 --- a/README.md +++ b/README.md @@ -1524,19 +1524,26 @@ See Eio's own tests for examples, e.g., [tests/switch.md](tests/switch.md). ## Provider Interfaces Eio applications use resources by calling functions (such as `Eio.Flow.write`). -These functions are actually wrappers that call methods on the resources. +These functions are actually wrappers that look up the implementing module and call +the appropriate function on that. This allows you to define your own resources. Here's a flow that produces an endless stream of zeros (like "/dev/zero"): ```ocaml -let zero = object - inherit Eio.Flow.source +module Zero = struct + type t = unit - method read_into buf = + let single_read () buf = Cstruct.memset buf 0; Cstruct.length buf + + let read_methods = [] (* Optional optimisations *) end + +let ops = Eio.Flow.Pi.source (module Zero) + +let zero = Eio.Resource.T ((), ops) ``` It can then be used like any other Eio flow: @@ -1549,34 +1556,6 @@ It can then be used like any other Eio flow: - : unit = () ``` -The `Flow.source` interface has some extra methods that can be used for optimisations -(for example, instead of filling a buffer with zeros it could be more efficient to share -a pre-allocated block of zeros). -Using `inherit` provides default implementations of these methods that say no optimisations are available. -It also protects you somewhat from API changes in future, as defaults can be provided for any new methods that get added. - -Although it is possible to *use* an object by calling its methods directly, -it is recommended that you use the functions instead. -The functions provide type information to the compiler, leading to clearer error messages, -and may provide extra features or sanity checks. - -For example `Eio.Flow.single_read` is defined as: - -```ocaml -let single_read (t : #Eio.Flow.source) buf = - let got = t#read_into buf in - assert (got > 0 && got <= Cstruct.length buf); - got -``` - -As an exception to this rule, it is fine to use the methods of `env` directly -(e.g. using `main env#stdin` instead of `main (Eio.Stdenv.stdin env)`. -Here, the compiler already has the type from the `Eio_main.run` call immediately above it, -and `env` is acting as a simple record. -We avoid doing that in this guide only to avoid alarming OCaml users unfamiliar with object syntax. - -See [Dynamic Dispatch](doc/rationale.md#dynamic-dispatch) for more discussion about the use of objects here. - ## Example Applications - [gemini-eio][] is a simple Gemini browser. It shows how to integrate Eio with `ocaml-tls` and `notty`. @@ -1729,9 +1708,8 @@ Of course, you could use `with_open_in` in this case to simplify it further. ### Casting -Unlike many languages, OCaml does not automatically cast objects (polymorphic records) to super-types as needed. +Unlike many languages, OCaml does not automatically cast to super-types as needed. Remember to keep the type polymorphic in your interface so users don't need to do this manually. -This is similar to the case with polymorphic variants (where APIs should use `[< ...]` or `[> ...]`). For example, if you need an `Eio.Flow.source` then users should be able to use a `Flow.two_way` without having to cast it first: @@ -1741,13 +1719,13 @@ without having to cast it first: (* BAD - user must cast to use function: *) module Message : sig type t - val read : Eio.Flow.source -> t + val read : Eio.Flow.source_ty r -> t end (* GOOD - a Flow.two_way can be used without casting: *) module Message : sig type t - val read : #Eio.Flow.source -> t + val read : _ Eio.Flow.source -> t end ``` @@ -1756,20 +1734,18 @@ If you want to store the argument, this may require you to cast internally: ```ocaml module Foo : sig type t - val of_source : #Eio.Flow.source -> t + val of_source : _ Eio.Flow.source -> t end = struct type t = { - src : Eio.Flow.source; + src : Eio.Flow.source_ty r; } let of_source x = { - src = (x :> Eio.Flow.source); + src = (x :> Eio.Flow.source_ty r); } end ``` -Note: the `#type` syntax only works on types defined by classes, whereas the slightly more verbose `` works on all object types. - ### Passing env The `env` value you get from `Eio_main.run` is a powerful capability, diff --git a/doc/prelude.ml b/doc/prelude.ml index 7f39e3d38..5b4793336 100644 --- a/doc/prelude.ml +++ b/doc/prelude.ml @@ -43,4 +43,4 @@ module Eio_main = struct end end -let parse_config (flow : #Eio.Flow.source) = ignore +let parse_config (flow : _ Eio.Flow.source) = ignore diff --git a/doc/rationale.md b/doc/rationale.md index 55e698ae1..b77ad10e5 100644 --- a/doc/rationale.md +++ b/doc/rationale.md @@ -125,7 +125,7 @@ For dynamic dispatch with subtyping, objects seem to be the best choice: An object uses a single block to store the object's fields and a pointer to the shared method table. - First-class modules and GADTs are an advanced feature of the language. - The new users we hope to attract to OCaml 5.00 are likely to be familiar with objects already. + The new users we hope to attract to OCaml 5.0 are likely to be familiar with objects already. - It is possible to provide base classes with default implementations of some methods. This can allow adding new operations to the API in future without breaking existing providers. @@ -133,24 +133,19 @@ For dynamic dispatch with subtyping, objects seem to be the best choice: In general, simulating objects using other features of the language leads to worse performance and worse ergonomics than using the language's built-in support. -In Eio, we split the provider and consumer APIs: - -- To *provide* a flow, you implement an object type. -- To *use* a flow, you call a function (e.g. `Flow.close`). - -The functions mostly just call the corresponding method on the object. -If you call object methods directly in OCaml then you tend to get poor compiler error messages. -This is because OCaml can only refer to the object types by listing the methods you seem to want to use. -Using functions avoids this, because the function signature specifies the type of its argument, -allowing type inference to work as for non-object code. -In this way, users of Eio can be largely unaware that objects are being used at all. - -The function wrappers can also provide extra checks that the API is being followed correctly, -such as asserting that a read does not return 0 bytes, -or add extra convenience functions without forcing every implementor to add them too. - -Note that the use of objects in Eio is not motivated by the use of the "Object Capabilities" security model. -Despite the name, that is not specific to objects at all. +However, in order for Eio to be widely accepted in the OCaml community, +we no longer use of objects and instead use a pair of a value and a function for looking up interfaces. +There is a problem here, because each interface has a different type, +so the function's return type depends on its input (the interface ID). +This requires using a GADT. However, GADT's don't support sub-typing. +To get around this, we use an extensible GADT to get the correct typing +(but which will raise an exception if the interface isn't supported), +and then wrap this with a polymorphic variant phantom type to help ensure +it is used correctly. + +This system gives the same performance as using objects and without requiring allocation. +However, care is needed when defining new interfaces, +since the compiler can't check that the resource really implements all the interfaces its phantom type suggests. ## Results vs Exceptions diff --git a/fuzz/fuzz_buf_read.ml b/fuzz/fuzz_buf_read.ml index f4d136141..2dec1a914 100644 --- a/fuzz/fuzz_buf_read.ml +++ b/fuzz/fuzz_buf_read.ml @@ -26,26 +26,30 @@ exception Buffer_limit_exceeded = Buf_read.Buffer_limit_exceeded let initial_size = 10 let max_size = 100 -let mock_flow next = object (self) - inherit Eio.Flow.source +module Mock_flow = struct + type t = string list ref - val mutable next = next - - method read_into buf = - match next with + let rec single_read t buf = + match !t with | [] -> raise End_of_file | "" :: xs -> - next <- xs; - self#read_into buf + t := xs; + single_read t buf | x :: xs -> let len = min (Cstruct.length buf) (String.length x) in Cstruct.blit_from_string x 0 buf 0 len; let x' = String.drop x len in - next <- (if x' = "" then xs else x' :: xs); + t := (if x' = "" then xs else x' :: xs); len + + let read_methods = [] end +let mock_flow = + let ops = Eio.Flow.Pi.source (module Mock_flow) in + fun chunks -> Eio.Resource.T (ref chunks, ops) + module Model = struct type t = string ref diff --git a/lib_eio/buf_read.ml b/lib_eio/buf_read.ml index 4120af5ba..5baad9093 100644 --- a/lib_eio/buf_read.ml +++ b/lib_eio/buf_read.ml @@ -1,11 +1,13 @@ exception Buffer_limit_exceeded +open Std + type t = { mutable buf : Cstruct.buffer; mutable pos : int; mutable len : int; - mutable flow : Flow.source option; (* None if we've seen eof *) - mutable consumed : int; (* Total bytes consumed so far *) + mutable flow : Flow.source_ty r option; (* None if we've seen eof *) + mutable consumed : int; (* Total bytes consumed so far *) max_size : int; } @@ -45,7 +47,7 @@ open Syntax let capacity t = Bigarray.Array1.dim t.buf let of_flow ?initial_size ~max_size flow = - let flow = (flow :> Flow.source) in + let flow = (flow :> Flow.source_ty r) in if max_size <= 0 then Fmt.invalid_arg "Max size %d should be positive!" max_size; let initial_size = Option.value initial_size ~default:(min 4096 max_size) in let buf = Bigarray.(Array1.create char c_layout initial_size) in @@ -128,17 +130,22 @@ let ensure_slow_path t n = let ensure t n = if t.len < n then ensure_slow_path t n -let as_flow t = - object - inherit Flow.source +module F = struct + type nonrec t = t - method read_into dst = - ensure t 1; - let len = min (buffered_bytes t) (Cstruct.length dst) in - Cstruct.blit (peek t) 0 dst 0 len; - consume t len; - len - end + let single_read t dst = + ensure t 1; + let len = min (buffered_bytes t) (Cstruct.length dst) in + Cstruct.blit (peek t) 0 dst 0 len; + consume t len; + len + + let read_methods = [] +end + +let as_flow = + let ops = Flow.Pi.source (module F) in + fun t -> Resource.T (t, ops) let get t i = Bigarray.Array1.get t.buf (t.pos + i) diff --git a/lib_eio/buf_read.mli b/lib_eio/buf_read.mli index 6e2271282..4701605cb 100644 --- a/lib_eio/buf_read.mli +++ b/lib_eio/buf_read.mli @@ -9,6 +9,8 @@ ]} *) +open Std + type t (** An input buffer. *) @@ -21,7 +23,7 @@ type 'a parser = t -> 'a @raise End_of_file The flow ended without enough data to parse an ['a]. @raise Buffer_limit_exceeded Parsing the value would exceed the configured size limit. *) -val parse : ?initial_size:int -> max_size:int -> 'a parser -> #Flow.source -> ('a, [> `Msg of string]) result +val parse : ?initial_size:int -> max_size:int -> 'a parser -> _ Flow.source -> ('a, [> `Msg of string]) result (** [parse p flow ~max_size] uses [p] to parse everything in [flow]. It is a convenience function that does @@ -32,7 +34,7 @@ val parse : ?initial_size:int -> max_size:int -> 'a parser -> #Flow.source -> (' @param initial_size see {!of_flow}. *) -val parse_exn : ?initial_size:int -> max_size:int -> 'a parser -> #Flow.source -> 'a +val parse_exn : ?initial_size:int -> max_size:int -> 'a parser -> _ Flow.source -> 'a (** [parse_exn] wraps {!parse}, but raises [Failure msg] if that returns [Error (`Msg msg)]. Catching exceptions with [parse] and then raising them might seem pointless, @@ -46,7 +48,7 @@ val parse_string : 'a parser -> string -> ('a, [> `Msg of string]) result val parse_string_exn : 'a parser -> string -> 'a (** [parse_string_exn] is like {!parse_string}, but handles errors like {!parse_exn}. *) -val of_flow : ?initial_size:int -> max_size:int -> #Flow.source -> t +val of_flow : ?initial_size:int -> max_size:int -> _ Flow.source -> t (** [of_flow ~max_size flow] is a buffered reader backed by [flow]. @param initial_size The initial amount of memory to allocate for the buffer. @@ -68,7 +70,7 @@ val of_buffer : Cstruct.buffer -> t val of_string : string -> t (** [of_string s] is a reader that reads from [s]. *) -val as_flow : t -> Flow.source +val as_flow : t -> Flow.source_ty r (** [as_flow t] is a buffered flow. Reading from it will return data from the buffer, diff --git a/lib_eio/buf_write.mli b/lib_eio/buf_write.mli index d654f9a15..2a9b875f9 100644 --- a/lib_eio/buf_write.mli +++ b/lib_eio/buf_write.mli @@ -85,7 +85,7 @@ exception Flush_aborted (** {2 Running} *) -val with_flow : ?initial_size:int -> #Flow.sink -> (t -> 'a) -> 'a +val with_flow : ?initial_size:int -> _ Flow.sink -> (t -> 'a) -> 'a (** [with_flow flow fn] runs [fn writer], where [writer] is a buffer that flushes to [flow]. Concurrently with [fn], it also runs a fiber that copies from [writer] to [flow]. diff --git a/lib_eio/eio.ml b/lib_eio/eio.ml index 077cd8171..f199e02d4 100644 --- a/lib_eio/eio.ml +++ b/lib_eio/eio.ml @@ -3,19 +3,13 @@ include Eio__core module Debug = Private.Debug let traceln = Debug.traceln -module Std = struct - module Promise = Promise - module Fiber = Fiber - module Switch = Switch - let traceln = Debug.traceln -end - +module Std = Std module Semaphore = Semaphore module Mutex = Eio_mutex module Condition = Condition module Stream = Stream module Exn = Exn -module Generic = Generic +module Resource = Resource module Flow = Flow module Buf_read = Buf_read module Buf_write = Buf_write @@ -28,17 +22,17 @@ module Fs = Fs module Path = Path module Stdenv = struct - let stdin (t : ) = t#stdin - let stdout (t : ) = t#stdout - let stderr (t : ) = t#stderr - let net (t : ) = t#net + let stdin (t : ) = t#stdin + let stdout (t : ) = t#stdout + let stderr (t : ) = t#stderr + let net (t : ) = t#net let process_mgr (t : ) = t#process_mgr let domain_mgr (t : ) = t#domain_mgr let clock (t : ) = t#clock let mono_clock (t : ) = t#mono_clock - let secure_random (t: ) = t#secure_random - let fs (t : ) = t#fs - let cwd (t : ) = t#cwd + let secure_random (t: ) = t#secure_random + let fs (t : ) = t#fs + let cwd (t : ) = t#cwd let debug (t : ) = t#debug let backend_id (t: ) = t#backend_id end diff --git a/lib_eio/eio.mli b/lib_eio/eio.mli index 4260f948e..8a8a32d8e 100644 --- a/lib_eio/eio.mli +++ b/lib_eio/eio.mli @@ -40,30 +40,18 @@ module Stream = Stream module Cancel = Eio__core.Cancel (** Commonly used standard features. This module is intended to be [open]ed. *) -module Std : sig - module Promise = Promise - module Fiber = Fiber - module Switch = Switch - - val traceln : - ?__POS__:string * int * int * int -> - ('a, Format.formatter, unit, unit) format4 -> 'a - (** Same as {!Eio.traceln}. *) -end +module Std = Std (** {1 Cross-platform OS API} The general pattern here is that each type of resource has a set of functions for using it, - plus an object type to allow defining your own implementations. - To use the resources, it is recommended that you use the functions rather than calling - methods directly. Using the functions results in better error messages from the compiler, - and may provide extra features or sanity checks. + plus a provider ([Pi]) module to allow defining your own implementations. The system resources are available from the environment argument provided by your event loop (e.g. {!Eio_main.run}). *) -(** A base class for objects that can be queried at runtime for extra features. *) -module Generic = Generic +(** Defines the base resource type. *) +module Resource = Resource (** Byte streams. *) module Flow = Flow @@ -175,9 +163,9 @@ module Stdenv : sig To use these, see {!Flow}. *) - val stdin : -> 'a - val stdout : -> 'a - val stderr : -> 'a + val stdin : -> 'a + val stdout : -> 'a + val stderr : -> 'a (** {1 File-system access} @@ -201,7 +189,7 @@ module Stdenv : sig To use this, see {!Net}. *) - val net : -> 'a + val net : -> 'a (** [net t] gives access to the process's network namespace. *) (** {1 Processes } @@ -233,7 +221,7 @@ module Stdenv : sig (** {1 Randomness} *) - val secure_random : -> 'a + val secure_random : -> 'a (** [secure_random t] is an infinite source of random bytes suitable for cryptographic purposes. *) (** {1 Debugging} *) diff --git a/lib_eio/file.ml b/lib_eio/file.ml index ec4752ba8..cb3b4fe93 100644 --- a/lib_eio/file.ml +++ b/lib_eio/file.ml @@ -1,13 +1,10 @@ -(** Tranditional Unix permissions. *) +open Std + module Unix_perm = struct type t = int - (** This is the same as {!Unix.file_perm}, but avoids a dependency on [Unix]. *) end -(** Portable file stats. *) module Stat = struct - - (** Kind of file from st_mode. **) type kind = [ | `Unknown | `Fifo @@ -19,7 +16,6 @@ module Stat = struct | `Socket ] - (** Like stat(2). *) type t = { dev : Int64.t; ino : Int64.t; @@ -36,62 +32,85 @@ module Stat = struct } end -(** A file opened for reading. *) -class virtual ro = object (_ : ) - method probe _ = None - method read_methods = [] - method virtual pread : file_offset:Optint.Int63.t -> Cstruct.t list -> int - method virtual stat : Stat.t -end +type ro_ty = [`File | Flow.source_ty | Resource.close_ty] -(** A file opened for reading and writing. *) -class virtual rw = object (_ : ) - inherit ro - method virtual pwrite : file_offset:Optint.Int63.t -> Cstruct.t list -> int -end +type 'a ro = ([> ro_ty] as 'a) r -(** [stat t] returns the {!Stat.t} record associated with [t]. *) -let stat (t : #ro) = t#stat +type rw_ty = [ro_ty | Flow.sink_ty] -(** [size t] returns the size of [t]. *) -let size t = (stat t).size +type 'a rw = ([> rw_ty] as 'a) r -(** [pread t ~file_offset bufs] performs a single read of [t] at [file_offset] into [bufs]. +module Pi = struct + module type READ = sig + include Flow.Pi.SOURCE - It returns the number of bytes read, which may be less than the space in [bufs], - even if more bytes are available. Use {!pread_exact} instead if you require - the buffer to be filled. + val pread : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int + val stat : t -> Stat.t + val close : t -> unit + end - To read at the current offset, use {!Flow.single_read} instead. *) -let pread (t : #ro) ~file_offset bufs = - let got = t#pread ~file_offset bufs in - assert (got > 0 && got <= Cstruct.lenv bufs); - got + module type WRITE = sig + include Flow.Pi.SINK + include READ with type t := t + + val pwrite : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int + end -(** [pread_exact t ~file_offset bufs] reads from [t] into [bufs] until [bufs] is full. + type (_, _, _) Resource.pi += + | Read : ('t, (module READ with type t = 't), [> ro_ty]) Resource.pi + | Write : ('t, (module WRITE with type t = 't), [> rw_ty]) Resource.pi - @raise End_of_file if the buffer could not be filled. *) -let rec pread_exact (t : #ro) ~file_offset bufs = - if Cstruct.lenv bufs > 0 then ( - let got = t#pread ~file_offset bufs in - let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in - pread_exact t ~file_offset (Cstruct.shiftv bufs got) - ) + let ro (type t) (module X : READ with type t = t) = + Resource.handler [ + H (Flow.Pi.Source, (module X)); + H (Read, (module X)); + H (Resource.Close, X.close); + ] + + let rw (type t) (module X : WRITE with type t = t) = + Resource.handler ( + H (Flow.Pi.Sink, (module X)) :: + H (Write, (module X)) :: + Resource.bindings (ro (module X)) + ) +end + +let stat (Resource.T (t, ops)) = + let module X = (val (Resource.get ops Pi.Read)) in + X.stat t + +let size t = (stat t).size + +let pread (Resource.T (t, ops)) ~file_offset bufs = + let module X = (val (Resource.get ops Pi.Read)) in + let got = X.pread t ~file_offset bufs in + assert (got > 0 && got <= Cstruct.lenv bufs); + got -(** [pwrite_single t ~file_offset bufs] performs a single write operation, writing - data from [bufs] to location [file_offset] in [t]. +let pread_exact (Resource.T (t, ops)) ~file_offset bufs = + let module X = (val (Resource.get ops Pi.Read)) in + let rec aux ~file_offset bufs = + if Cstruct.lenv bufs > 0 then ( + let got = X.pread t ~file_offset bufs in + let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in + aux ~file_offset (Cstruct.shiftv bufs got) + ) + in + aux ~file_offset bufs - It returns the number of bytes written, which may be less than the length of [bufs]. - In most cases, you will want to use {!pwrite_all} instead. *) -let pwrite_single (t : #rw) ~file_offset bufs = - let got = t#pwrite ~file_offset bufs in +let pwrite_single (Resource.T (t, ops)) ~file_offset bufs = + let module X = (val (Resource.get ops Pi.Write)) in + let got = X.pwrite t ~file_offset bufs in assert (got > 0 && got <= Cstruct.lenv bufs); got -(** [pwrite_all t ~file_offset bufs] writes all the data in [bufs] to location [file_offset] in [t]. *) -let rec pwrite_all (t : #rw) ~file_offset bufs = - if Cstruct.lenv bufs > 0 then ( - let got = t#pwrite ~file_offset bufs in - let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in - pwrite_all t ~file_offset (Cstruct.shiftv bufs got) - ) +let pwrite_all (Resource.T (t, ops)) ~file_offset bufs = + let module X = (val (Resource.get ops Pi.Write)) in + let rec aux ~file_offset bufs = + if Cstruct.lenv bufs > 0 then ( + let got = X.pwrite t ~file_offset bufs in + let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in + aux ~file_offset (Cstruct.shiftv bufs got) + ) + in + aux ~file_offset bufs diff --git a/lib_eio/file.mli b/lib_eio/file.mli new file mode 100644 index 000000000..177253340 --- /dev/null +++ b/lib_eio/file.mli @@ -0,0 +1,104 @@ +open Std + +(** Tranditional Unix permissions. *) +module Unix_perm : sig + type t = int + (** This is the same as {!Unix.file_perm}, but avoids a dependency on [Unix]. *) +end + +(** Portable file stats. *) +module Stat : sig + + type kind = [ + | `Unknown + | `Fifo + | `Character_special + | `Directory + | `Block_device + | `Regular_file + | `Symbolic_link + | `Socket + ] + (** Kind of file from st_mode. **) + + type t = { + dev : Int64.t; + ino : Int64.t; + kind : kind; + perm : Unix_perm.t; + nlink : Int64.t; + uid : Int64.t; + gid : Int64.t; + rdev : Int64.t; + size : Optint.Int63.t; + atime : float; + mtime : float; + ctime : float; + } + (** Like stat(2). *) +end + +type ro_ty = [`File | Flow.source_ty | Resource.close_ty] + +type 'a ro = ([> ro_ty] as 'a) r +(** A file opened for reading. *) + +type rw_ty = [ro_ty | Flow.sink_ty] + +type 'a rw = ([> rw_ty] as 'a) r +(** A file opened for reading and writing. *) + +module Pi : sig + module type READ = sig + include Flow.Pi.SOURCE + + val pread : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int + val stat : t -> Stat.t + val close : t -> unit + end + + module type WRITE = sig + include Flow.Pi.SINK + include READ with type t := t + + val pwrite : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int + end + + type (_, _, _) Resource.pi += + | Read : ('t, (module READ with type t = 't), [> ro_ty]) Resource.pi + | Write : ('t, (module WRITE with type t = 't), [> rw_ty]) Resource.pi + + val ro : (module READ with type t = 't) -> ('t, ro_ty) Resource.handler + + val rw : (module WRITE with type t = 't) -> ('t, rw_ty) Resource.handler +end + +val stat : _ ro -> Stat.t +(** [stat t] returns the {!Stat.t} record associated with [t]. *) + +val size : _ ro -> Optint.Int63.t +(** [size t] returns the size of [t]. *) + +val pread : _ ro -> file_offset:Optint.Int63.t -> Cstruct.t list -> int +(** [pread t ~file_offset bufs] performs a single read of [t] at [file_offset] into [bufs]. + + It returns the number of bytes read, which may be less than the space in [bufs], + even if more bytes are available. Use {!pread_exact} instead if you require + the buffer to be filled. + + To read at the current offset, use {!Flow.single_read} instead. *) + +val pread_exact : _ ro -> file_offset:Optint.Int63.t -> Cstruct.t list -> unit +(** [pread_exact t ~file_offset bufs] reads from [t] into [bufs] until [bufs] is full. + + @raise End_of_file if the buffer could not be filled. *) + +val pwrite_single : _ rw -> file_offset:Optint.Int63.t -> Cstruct.t list -> int +(** [pwrite_single t ~file_offset bufs] performs a single write operation, writing + data from [bufs] to location [file_offset] in [t]. + + It returns the number of bytes written, which may be less than the length of [bufs]. + In most cases, you will want to use {!pwrite_all} instead. *) + +val pwrite_all : _ rw -> file_offset:Optint.Int63.t -> Cstruct.t list -> unit +(** [pwrite_all t ~file_offset bufs] writes all the data in [bufs] to location [file_offset] in [t]. *) diff --git a/lib_eio/flow.ml b/lib_eio/flow.ml index 457da6e14..f1d49e6a9 100644 --- a/lib_eio/flow.ml +++ b/lib_eio/flow.ml @@ -1,106 +1,173 @@ +open Std + type shutdown_command = [ `Receive | `Send | `All ] -type read_method = .. -type read_method += Read_source_buffer of ((Cstruct.t list -> int) -> unit) +type 't read_method = .. +type 't read_method += Read_source_buffer of ('t -> (Cstruct.t list -> int) -> unit) + +type source_ty = [`R | `Flow] +type 'a source = ([> source_ty] as 'a) r + +type sink_ty = [`W | `Flow] +type 'a sink = ([> sink_ty] as 'a) r + +type shutdown_ty = [`Shutdown] +type 'a shutdown = ([> shutdown_ty] as 'a) r + +module Pi = struct + module type SOURCE = sig + type t + val read_methods : t read_method list + val single_read : t -> Cstruct.t -> int + end + + module type SINK = sig + type t + val copy : t -> src:_ source -> unit + val write : t -> Cstruct.t list -> unit + end + + module type SHUTDOWN = sig + type t + val shutdown : t -> shutdown_command -> unit + val close : t -> unit + end + + type (_, _, _) Resource.pi += + | Source : ('t, (module SOURCE with type t = 't), [> source_ty]) Resource.pi + | Sink : ('t, (module SINK with type t = 't), [> sink_ty]) Resource.pi + | Shutdown : ('t, (module SHUTDOWN with type t = 't), [> shutdown_ty]) Resource.pi + -class type close = Generic.close -let close = Generic.close + let source (type t) (module X : SOURCE with type t = t) = + Resource.handler [H (Source, (module X))] + + let sink (type t) (module X : SINK with type t = t) = + Resource.handler [H (Sink, (module X))] + + let shutdown (type t) (module X : SHUTDOWN with type t = t) = + Resource.handler [ + H (Resource.Close, X.close); + H (Shutdown, (module X)); + ] + + module type TWO_WAY = sig + include SHUTDOWN + include SOURCE with type t := t + include SINK with type t := t + end -class virtual source = object (_ : ) - method probe _ = None - method read_methods : read_method list = [] - method virtual read_into : Cstruct.t -> int + let two_way (type t) (module X : TWO_WAY with type t = t) = + Resource.handler [ + H (Shutdown, (module X)); + H (Source, (module X)); + H (Sink, (module X)); + ] end -let single_read (t : #source) buf = - let got = t#read_into buf in +open Pi + +let close = Resource.close + +let single_read (Resource.T (t, ops)) buf = + let module X = (val (Resource.get ops Source)) in + let got = X.single_read t buf in assert (got > 0 && got <= Cstruct.length buf); got -let read_methods (t : #source) = t#read_methods - let rec read_exact t buf = if Cstruct.length buf > 0 then ( let got = single_read t buf in read_exact t (Cstruct.shift buf got) ) -let cstruct_source data : source = - object (self) - val mutable data = data - - inherit source - - method private read_source_buffer fn = - let rec aux () = - match data with - | [] -> raise End_of_file - | x :: xs when Cstruct.length x = 0 -> data <- xs; aux () - | xs -> - let n = fn xs in - data <- Cstruct.shiftv xs n - in - aux () - - method! read_methods = - [ Read_source_buffer self#read_source_buffer ] - - method read_into dst = - let avail, src = Cstruct.fillv ~dst ~src:data in - if avail = 0 then raise End_of_file; - data <- src; - avail - end +module Cstruct_source = struct + type t = Cstruct.t list ref -let string_source s : source = - object - val mutable offset = 0 + let create data = ref data - inherit source + let read_source_buffer t fn = + let rec aux () = + match !t with + | [] -> raise End_of_file + | x :: xs when Cstruct.length x = 0 -> t := xs; aux () + | xs -> + let n = fn xs in + t := Cstruct.shiftv xs n + in + aux () - method read_into dst = - if offset = String.length s then raise End_of_file; + let read_methods = + [ Read_source_buffer read_source_buffer ] - let len = min (Cstruct.length dst) (String.length s - offset) in - Cstruct.blit_from_string s offset dst 0 len; - offset <- offset + len; - len - end + let single_read t dst = + let avail, src = Cstruct.fillv ~dst ~src:!t in + if avail = 0 then raise End_of_file; + t := src; + avail -class virtual sink = object (self : ) - method probe _ = None - method virtual copy : 'a. (#source as 'a) -> unit - method write bufs = self#copy (cstruct_source bufs) end -let write (t : #sink) (bufs : Cstruct.t list) = t#write bufs +let cstruct_source = + let ops = Pi.source (module Cstruct_source) in + fun data -> Resource.T (Cstruct_source.create data, ops) -let copy (src : #source) (dst : #sink) = dst#copy src +module String_source = struct + type t = { + s : string; + mutable offset : int; + } -let copy_string s = copy (string_source s) + let single_read t dst = + if t.offset = String.length t.s then raise End_of_file; + let len = min (Cstruct.length dst) (String.length t.s - t.offset) in + Cstruct.blit_from_string t.s t.offset dst 0 len; + t.offset <- t.offset + len; + len -let buffer_sink b = - object - inherit sink - - method copy src = - let buf = Cstruct.create 4096 in - try - while true do - let got = src#read_into buf in - Buffer.add_string b (Cstruct.to_string ~len:got buf) - done - with End_of_file -> () - - method! write bufs = - List.iter (fun buf -> Buffer.add_bytes b (Cstruct.to_bytes buf)) bufs - end + let read_methods = [] -class virtual two_way = object (_ : ) - inherit sink - method read_methods = [] + let create s = { s; offset = 0 } +end - method virtual shutdown : shutdown_command -> unit +let string_source = + let ops = Pi.source (module String_source) in + fun s -> Resource.T (String_source.create s, ops) + +let write (Resource.T (t, ops)) bufs = + let module X = (val (Resource.get ops Sink)) in + X.write t bufs + +let copy src (Resource.T (t, ops)) = + let module X = (val (Resource.get ops Sink)) in + X.copy t ~src + +let copy_string s = copy (string_source s) + +module Buffer_sink = struct + type t = Buffer.t + + let copy t ~src:(Resource.T (src, ops)) = + let module Src = (val (Resource.get ops Source)) in + let buf = Cstruct.create 4096 in + try + while true do + let got = Src.single_read src buf in + Buffer.add_string t (Cstruct.to_string ~len:got buf) + done + with End_of_file -> () + + let write t bufs = + List.iter (fun buf -> Buffer.add_bytes t (Cstruct.to_bytes buf)) bufs end -let shutdown (t : #two_way) = t#shutdown +let buffer_sink = + let ops = Pi.sink (module Buffer_sink) in + fun b -> Resource.T (b, ops) + +type two_way_ty = [source_ty | sink_ty | shutdown_ty] +type 'a two_way = ([> two_way_ty] as 'a) r + +let shutdown (Resource.T (t, ops)) cmd = + let module X = (val (Resource.get ops Shutdown)) in + X.shutdown t cmd diff --git a/lib_eio/flow.mli b/lib_eio/flow.mli index 5576e2916..2be74d076 100644 --- a/lib_eio/flow.mli +++ b/lib_eio/flow.mli @@ -4,24 +4,37 @@ To read structured data (e.g. a line at a time), wrap a source using {!Buf_read}. *) -(** {2 Reading} *) +open Std + +(** {2 Types} *) + +type source_ty = [`R | `Flow] +type 'a source = ([> source_ty] as 'a) r +(** A readable flow provides a stream of bytes. *) + +type sink_ty = [`W | `Flow] +type 'a sink = ([> sink_ty] as 'a) r +(** A writeable flow accepts a stream of bytes. *) -type read_method = .. +type shutdown_ty = [`Shutdown] +type 'a shutdown = ([> shutdown_ty] as 'a) r + +type 'a read_method = .. (** Sources can offer a list of ways to read them, in order of preference. *) -class virtual source : object - inherit Generic.t - method read_methods : read_method list - method virtual read_into : Cstruct.t -> int -end +type shutdown_command = [ + | `Receive (** Indicate that no more reads will be done *) + | `Send (** Indicate that no more writes will be done *) + | `All (** Indicate that no more reads or writes will be done *) +] -val single_read : #source -> Cstruct.t -> int +(** {2 Reading} *) + +val single_read : _ source -> Cstruct.t -> int (** [single_read src buf] reads one or more bytes into [buf]. It returns the number of bytes read (which may be less than the buffer size even if there is more data to be read). - [single_read src] just makes a single call to [src#read_into] - (and asserts that the result is in range). - Use {!read_exact} instead if you want to fill [buf] completely. - Use {!Buf_read.line} to read complete lines. @@ -31,24 +44,18 @@ val single_read : #source -> Cstruct.t -> int @raise End_of_file if there is no more data to read *) -val read_exact : #source -> Cstruct.t -> unit +val read_exact : _ source -> Cstruct.t -> unit (** [read_exact src dst] keeps reading into [dst] until it is full. @raise End_of_file if the buffer could not be filled. *) -val read_methods : #source -> read_method list -(** [read_methods flow] is a list of extra ways of reading from [flow], - with the preferred (most efficient) methods first. - - If no method is suitable, {!read} should be used as the fallback. *) - -val string_source : string -> source +val string_source : string -> source_ty r (** [string_source s] is a source that gives the bytes of [s]. *) -val cstruct_source : Cstruct.t list -> source +val cstruct_source : Cstruct.t list -> source_ty r (** [cstruct_source cs] is a source that gives the bytes of [cs]. *) -type read_method += Read_source_buffer of ((Cstruct.t list -> int) -> unit) -(** If a source offers [Read_source_buffer rsb] then the user can call [rsb fn] +type 't read_method += Read_source_buffer of ('t -> (Cstruct.t list -> int) -> unit) +(** If a source offers [Read_source_buffer rsb] then the user can call [rsb t fn] to borrow a view of the source's buffers. [fn] returns the number of bytes it consumed. [rsb] will raise [End_of_file] if no more data will be produced. @@ -58,16 +65,7 @@ type read_method += Read_source_buffer of ((Cstruct.t list -> int) -> unit) (** {2 Writing} *) -(** Consumer base class. *) -class virtual sink : object - inherit Generic.t - method virtual copy : 'a. (#source as 'a) -> unit - - method write : Cstruct.t list -> unit - (** The default implementation is [copy (cstruct_source ...)], but it can be overridden for speed. *) -end - -val write : #sink -> Cstruct.t list -> unit +val write : _ sink -> Cstruct.t list -> unit (** [write dst bufs] writes all bytes from [bufs]. You should not perform multiple concurrent writes on the same flow @@ -78,33 +76,23 @@ val write : #sink -> Cstruct.t list -> unit - {!Buf_write} to combine multiple small writes. - {!copy} for bulk transfers, as it allows some extra optimizations. *) -val copy : #source -> #sink -> unit +val copy : _ source -> _ sink -> unit (** [copy src dst] copies data from [src] to [dst] until end-of-file. *) -val copy_string : string -> #sink -> unit +val copy_string : string -> _ sink -> unit (** [copy_string s = copy (string_source s)] *) -val buffer_sink : Buffer.t -> sink +val buffer_sink : Buffer.t -> sink_ty r (** [buffer_sink b] is a sink that adds anything sent to it to [b]. To collect data as a cstruct, use {!Buf_read} instead. *) (** {2 Bidirectional streams} *) -type shutdown_command = [ - | `Receive (** Indicate that no more reads will be done *) - | `Send (** Indicate that no more writes will be done *) - | `All (** Indicate that no more reads or writes will be done *) -] - -class virtual two_way : object - inherit source - inherit sink +type two_way_ty = [source_ty | sink_ty | shutdown_ty] +type 'a two_way = ([> two_way_ty] as 'a) r - method virtual shutdown : shutdown_command -> unit -end - -val shutdown : #two_way -> shutdown_command -> unit +val shutdown : _ two_way -> shutdown_command -> unit (** [shutdown t cmd] indicates that the caller has finished reading or writing [t] (depending on [cmd]). @@ -116,7 +104,45 @@ val shutdown : #two_way -> shutdown_command -> unit Flows are usually attached to switches and closed automatically when the switch finishes. However, it can be useful to close them sooner manually in some cases. *) -class type close = Generic.close +val close : [> `Close] r -> unit +(** Alias of {!Resource.close}. *) + +(** {2 Provider Interface} *) + +module Pi : sig + module type SOURCE = sig + type t + val read_methods : t read_method list + val single_read : t -> Cstruct.t -> int + end + + module type SINK = sig + type t + val copy : t -> src:_ source -> unit + val write : t -> Cstruct.t list -> unit + end + + module type SHUTDOWN = sig + type t + val shutdown : t -> shutdown_command -> unit + val close : t -> unit + end + + val source : (module SOURCE with type t = 't) -> ('t, source_ty) Resource.handler + val sink : (module SINK with type t = 't) -> ('t, sink_ty) Resource.handler + val shutdown : (module SHUTDOWN with type t = 't) -> ('t, shutdown_ty) Resource.handler + + module type TWO_WAY = sig + include SHUTDOWN + include SOURCE with type t := t + include SINK with type t := t + end + + val two_way : (module TWO_WAY with type t = 't) -> ('t, two_way_ty) Resource.handler + + type (_, _, _) Resource.pi += + | Source : ('t, (module SOURCE with type t = 't), [> source_ty]) Resource.pi + | Sink : ('t, (module SINK with type t = 't), [> sink_ty]) Resource.pi + | Shutdown : ('t, (module SHUTDOWN with type t = 't), [> shutdown_ty]) Resource.pi +end -val close : #close -> unit -(** Alias of {!Generic.close}. *) diff --git a/lib_eio/fs.ml b/lib_eio/fs.ml index 230583a8f..cb04cb3e5 100644 --- a/lib_eio/fs.ml +++ b/lib_eio/fs.ml @@ -1,5 +1,7 @@ (** Defines types used by file-systems. *) +open Std + type path = string type error = @@ -36,24 +38,32 @@ type create = [ ] (** If a new file is created, the given permissions are used for it. *) +type dir_ty = [`Dir] +type 'a dir = ([> dir_ty] as 'a) r + (** Note: use the functions in {!Path} to access directories. *) -class virtual dir = object (_ : #Generic.t) - method probe _ = None - method virtual open_in : sw:Switch.t -> path -> - method virtual open_out : - sw:Switch.t -> - append:bool -> - create:create -> - path -> - method virtual mkdir : perm:File.Unix_perm.t -> path -> unit - method virtual open_dir : sw:Switch.t -> path -> dir_with_close - method virtual read_dir : path -> string list - method virtual unlink : path -> unit - method virtual rmdir : path -> unit - method virtual rename : path -> dir -> path -> unit - method virtual pp : Format.formatter -> unit -end -and virtual dir_with_close = object (_ : ) - (* This dummy class avoids an "Error: The type < .. > is not an object type" error from the compiler. *) - inherit dir +module Pi = struct + module type DIR = sig + type t + + val open_in : t -> sw:Switch.t -> path -> File.ro_ty r + + val open_out : + t -> + sw:Switch.t -> + append:bool -> + create:create -> + path -> File.rw_ty r + + val mkdir : t -> perm:File.Unix_perm.t -> path -> unit + val open_dir : t -> sw:Switch.t -> path -> [`Close | dir_ty] r + val read_dir : t -> path -> string list + val unlink : t -> path -> unit + val rmdir : t -> path -> unit + val rename : t -> path -> _ dir -> path -> unit + val pp : t Fmt.t + end + + type (_, _, _) Resource.pi += + | Dir : ('t, (module DIR with type t = 't), [> dir_ty]) Resource.pi end diff --git a/lib_eio/generic.ml b/lib_eio/generic.ml deleted file mode 100644 index 24526b4f3..000000000 --- a/lib_eio/generic.ml +++ /dev/null @@ -1,13 +0,0 @@ -type 'a ty = .. - -class type t = object - method probe : 'a. 'a ty -> 'a option -end - -let probe (t : #t) ty = t#probe ty - -class type close = object - method close : unit -end - -let close (t : #close) = t#close diff --git a/lib_eio/generic.mli b/lib_eio/generic.mli deleted file mode 100644 index 5b4b5f61e..000000000 --- a/lib_eio/generic.mli +++ /dev/null @@ -1,30 +0,0 @@ -type 'a ty = .. -(** An ['a ty] is a query for a feature of type ['a]. *) - -class type t = object - method probe : 'a. 'a ty -> 'a option -end - -val probe : #t -> 'a ty -> 'a option -(** [probe t feature] checks whether [t] supports [feature]. - This is mostly for internal use. - For example, {!Eio_unix.FD.peek_opt} uses this to get the underlying Unix file descriptor from a flow. *) - -(** {2 Closing} - - Resources are usually attached to switches and closed automatically when the switch - finishes. However, it can be useful to close them sooner in some cases. *) - -class type close = object - method close : unit -end - -val close : #close -> unit -(** [close t] marks the resource as closed. It can no longer be used after this. - - If [t] is already closed then this does nothing (it does not raise an exception). - - Note: if an operation is currently in progress when this is called then it is not - necessarily cancelled, and any underlying OS resource (such as a file descriptor) - might not be closed immediately if other operations are using it. Closing a resource - only prevents new operations from starting. *) diff --git a/lib_eio/mock/eio_mock.mli b/lib_eio/mock/eio_mock.mli index 28066c18f..c4683ce64 100644 --- a/lib_eio/mock/eio_mock.mli +++ b/lib_eio/mock/eio_mock.mli @@ -34,6 +34,8 @@ ]} *) +open Eio.Std + (** {2 Configuration} *) (** Actions that can be performed by mock handlers. *) @@ -89,14 +91,8 @@ module Flow : sig | `Read_source_buffer (** Use the {!Eio.Flow.Read_source_buffer} optimisation. *) ] - type t = < - Eio.Flow.two_way; - Eio.Flow.close; - on_read : string Handler.t; - on_copy_bytes : int Handler.t; - set_copy_method : copy_method -> unit; - attach_to_switch : Eio.Switch.t -> unit; - > + type ty = [`Generic | `Mock] Eio.Net.stream_socket_ty + type t = ty r val make : ?pp:string Fmt.t -> string -> t (** [make label] is a mock Eio flow. @@ -116,30 +112,20 @@ end (** Mock {!Eio.Net} networks and sockets. *) module Net : sig - type t = < - Eio.Net.t; - on_listen : Eio.Net.listening_socket Handler.t; - on_connect : Eio.Net.stream_socket Handler.t; - on_datagram_socket : Eio.Net.datagram_socket Handler.t; - on_getaddrinfo : Eio.Net.Sockaddr.t list Handler.t; - on_getnameinfo : (string * string) Handler.t; - > - - type listening_socket = < - Eio.Net.listening_socket; - on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t; - > + type t = [`Generic | `Mock] Eio.Net.ty r + + type listening_socket = [`Generic | `Mock] Eio.Net.listening_socket_ty r val make : string -> t (** [make label] is a new mock network. *) - val on_connect : t -> Handler.actions -> unit + val on_connect : t -> _ Eio.Net.stream_socket Handler.actions -> unit (** [on_connect t actions] configures what to do when a client tries to connect somewhere. *) - val on_listen : t -> #Eio.Net.listening_socket Handler.actions -> unit + val on_listen : t -> _ Eio.Net.listening_socket Handler.actions -> unit (** [on_listen t actions] configures what to do when a server starts listening for incoming connections. *) - val on_datagram_socket : t -> Handler.actions -> unit + val on_datagram_socket : t -> _ Eio.Net.datagram_socket Handler.actions -> unit (** [on_datagram_socket t actions] configures how to create datagram sockets. *) val on_getaddrinfo : t -> Eio.Net.Sockaddr.t list Handler.actions -> unit diff --git a/lib_eio/mock/flow.ml b/lib_eio/mock/flow.ml index 50ef67ab6..077970802 100644 --- a/lib_eio/mock/flow.ml +++ b/lib_eio/mock/flow.ml @@ -5,112 +5,132 @@ type copy_method = [ | `Read_source_buffer ] -type t = < - Eio.Flow.two_way; - Eio.Flow.close; - on_read : string Handler.t; - on_copy_bytes : int Handler.t; - set_copy_method : copy_method -> unit; - attach_to_switch : Switch.t -> unit; -> - -let pp_default f s = - let rec aux i = - let nl = - match String.index_from_opt s i '\n' with - | None -> String.length s - | Some x -> x + 1 +module Mock_flow = struct + type tag = [`Generic | `Mock] + + type t = { + label : string; + pp : string Fmt.t; + on_close : (unit -> unit) Queue.t; + on_read : string Handler.t; + on_copy_bytes : int Handler.t; + mutable copy_method : copy_method; + } + + let pp_default f s = + let rec aux i = + let nl = + match String.index_from_opt s i '\n' with + | None -> String.length s + | Some x -> x + 1 + in + Fmt.Dump.string f (String.sub s i (nl - i)); + if nl < String.length s then ( + Fmt.cut f (); + aux nl + ) in - Fmt.Dump.string f (String.sub s i (nl - i)); - if nl < String.length s then ( - Fmt.cut f (); - aux nl - ) - in - aux 0 - -let rec takev len = function - | [] -> [] - | x :: _ when Cstruct.length x >= len -> [Cstruct.sub x 0 len] - | x :: xs -> x :: takev (len - Cstruct.length x) xs - -let make ?(pp=pp_default) label = - let on_read = Handler.make (`Raise End_of_file) in - let on_copy_bytes = Handler.make (`Return 4096) in - let copy_method = ref `Read_into in + aux 0 + + let rec takev len = function + | [] -> [] + | x :: _ when Cstruct.length x >= len -> [Cstruct.sub x 0 len] + | x :: xs -> x :: takev (len - Cstruct.length x) xs + (* Test optimised copying using Read_source_buffer *) - let copy_rsb_iovec src = - let size = Handler.run on_copy_bytes in + let copy_rsb_iovec t src = + let size = Handler.run t.on_copy_bytes in let len = min (Cstruct.lenv src) size in let bufs = takev len src in - traceln "%s: wrote (rsb) @[%a@]" label (Fmt.Dump.list (Fmt.using Cstruct.to_string pp)) bufs; + traceln "%s: wrote (rsb) @[%a@]" t.label (Fmt.Dump.list (Fmt.using Cstruct.to_string t.pp)) bufs; len - in - let copy_rsb rsb = - try while true do rsb copy_rsb_iovec done + + let copy_rsb t rsb = + try while true do rsb (copy_rsb_iovec t) done with End_of_file -> () - in + (* Test fallback copy using buffer. *) - let copy_via_buffer src = + let copy_via_buffer t src = try while true do - let size = Handler.run on_copy_bytes in + let size = Handler.run t.on_copy_bytes in let buf = Cstruct.create size in let n = Eio.Flow.single_read src buf in - traceln "%s: wrote @[%a@]" label pp (Cstruct.to_string (Cstruct.sub buf 0 n)) + traceln "%s: wrote @[%a@]" t.label t.pp (Cstruct.to_string (Cstruct.sub buf 0 n)) done with End_of_file -> () - in - object (self) - inherit Eio.Flow.two_way - - val on_close = Queue.create () - - method on_read = on_read - method on_copy_bytes = on_copy_bytes - - method read_into buf = - let data = Handler.run on_read in - let len = String.length data in - if Cstruct.length buf < len then - Fmt.failwith "%s: read buffer too short for %a!" label pp data; - Cstruct.blit_from_string data 0 buf 0 len; - traceln "%s: read @[%a@]" label pp data; - len - - method copy src = - match !copy_method with - | `Read_into -> copy_via_buffer src - | `Read_source_buffer -> - let try_rsb = function - | Eio.Flow.Read_source_buffer rsb -> copy_rsb rsb; true - | _ -> false - in - if not (List.exists try_rsb (Eio.Flow.read_methods src)) then - Fmt.failwith "Source does not offer Read_source_buffer optimisation" - - method set_copy_method m = - copy_method := m - - method shutdown cmd = - traceln "%s: shutdown %s" label @@ - match cmd with - | `Receive -> "receive" - | `Send -> "send" - | `All -> "all" - - method attach_to_switch sw = - let hook = Switch.on_release_cancellable sw (fun () -> Eio.Flow.close self) in - Queue.add (fun () -> Eio.Switch.remove_hook hook) on_close - - method close = - while not (Queue.is_empty on_close) do - Queue.take on_close () - done; - traceln "%s: closed" label - end - -let on_read (t:t) = Handler.seq t#on_read -let on_copy_bytes (t:t) = Handler.seq t#on_copy_bytes -let set_copy_method (t:t) = t#set_copy_method -let attach_to_switch (t:t) = t#attach_to_switch + + let read_methods = [] + + let single_read t buf = + let data = Handler.run t.on_read in + let len = String.length data in + if Cstruct.length buf < len then + Fmt.failwith "%s: read buffer too short for %a!" t.label t.pp data; + Cstruct.blit_from_string data 0 buf 0 len; + traceln "%s: read @[%a@]" t.label t.pp data; + len + + let copy t ~src = + match t.copy_method with + | `Read_into -> copy_via_buffer t src + | `Read_source_buffer -> + let Eio.Resource.T (src, ops) = src in + let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in + let try_rsb = function + | Eio.Flow.Read_source_buffer rsb -> copy_rsb t (rsb src); true + | _ -> false + in + if not (List.exists try_rsb Src.read_methods) then + Fmt.failwith "Source does not offer Read_source_buffer optimisation" + + let write t bufs = + copy t ~src:(Eio.Flow.cstruct_source bufs) + + let shutdown t cmd = + traceln "%s: shutdown %s" t.label @@ + match cmd with + | `Receive -> "receive" + | `Send -> "send" + | `All -> "all" + + let close t = + while not (Queue.is_empty t.on_close) do + Queue.take t.on_close () + done; + traceln "%s: closed" t.label + + let make ?(pp=pp_default) label = + { + pp; + label; + on_close = Queue.create (); + on_read = Handler.make (`Raise End_of_file); + on_copy_bytes = Handler.make (`Return 4096); + copy_method = `Read_into; + } +end + +type ty = [`Generic | `Mock] Eio.Net.stream_socket_ty + +type t = ty r + +type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> Mock_flow.t, ty) Eio.Resource.pi +let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t + +let attach_to_switch t sw = + let t = raw t in + let hook = Switch.on_release_cancellable sw (fun () -> Mock_flow.close t) in + Queue.add (fun () -> Eio.Switch.remove_hook hook) t.on_close + +let on_read t = Handler.seq (raw t).on_read +let on_copy_bytes t = Handler.seq (raw t).on_copy_bytes +let set_copy_method t v = (raw t).copy_method <- v + +let handler = Eio.Resource.handler ( + H (Type, Fun.id) :: + Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module Mock_flow)) + ) + +let make ?pp label : t = + Eio.Resource.T (Mock_flow.make ?pp label, handler) diff --git a/lib_eio/mock/net.ml b/lib_eio/mock/net.ml index 4104c1c39..730f2f263 100644 --- a/lib_eio/mock/net.ml +++ b/lib_eio/mock/net.ml @@ -1,98 +1,138 @@ open Eio.Std -type t = < - Eio.Net.t; - on_listen : Eio.Net.listening_socket Handler.t; - on_connect : Eio.Net.stream_socket Handler.t; - on_datagram_socket : Eio.Net.datagram_socket Handler.t; - on_getaddrinfo : Eio.Net.Sockaddr.t list Handler.t; - on_getnameinfo : (string * string) Handler.t; -> - -let make label = - let on_listen = Handler.make (`Raise (Failure "Mock listen handler not configured")) in - let on_connect = Handler.make (`Raise (Failure "Mock connect handler not configured")) in - let on_datagram_socket = Handler.make (`Raise (Failure "Mock datagram_socket handler not configured")) in - let on_getaddrinfo = Handler.make (`Raise (Failure "Mock getaddrinfo handler not configured")) in - let on_getnameinfo = Handler.make (`Raise (Failure "Mock getnameinfo handler not configured")) in - object - inherit Eio.Net.t - - method on_listen = on_listen - method on_connect = on_connect - method on_datagram_socket = on_datagram_socket - method on_getaddrinfo = on_getaddrinfo - method on_getnameinfo = on_getnameinfo - - method listen ~reuse_addr:_ ~reuse_port:_ ~backlog:_ ~sw addr = - traceln "%s: listen on %a" label Eio.Net.Sockaddr.pp addr; - let socket = Handler.run on_listen in - Switch.on_release sw (fun () -> Eio.Flow.close socket); - socket - - method connect ~sw addr = - traceln "%s: connect to %a" label Eio.Net.Sockaddr.pp addr; - let socket = Handler.run on_connect in - Switch.on_release sw (fun () -> Eio.Flow.close socket); - socket - - method datagram_socket ~reuse_addr:_ ~reuse_port:_ ~sw addr = - (match addr with - | #Eio.Net.Sockaddr.datagram as saddr -> traceln "%s: datagram_socket %a" label Eio.Net.Sockaddr.pp saddr - | `UdpV4 -> traceln "%s: datagram_socket UDPv4" label - | `UdpV6 -> traceln "%s: datagram_socket UDPv6" label - ); - let socket = Handler.run on_datagram_socket in - Switch.on_release sw (fun () -> Eio.Flow.close socket); - socket - - method getaddrinfo ~service node = - traceln "%s: getaddrinfo ~service:%s %s" label service node; - Handler.run on_getaddrinfo - - method getnameinfo sockaddr = - traceln "%s: getnameinfo %a" label Eio.Net.Sockaddr.pp sockaddr; - Handler.run on_getnameinfo - end +type ty = [`Generic | `Mock] Eio.Net.ty +type t = ty r + +module Impl = struct + type tag = [`Generic] + + type t = { + label : string; + on_listen : tag Eio.Net.listening_socket_ty r Handler.t; + on_connect : tag Eio.Net.stream_socket_ty r Handler.t; + on_datagram_socket : tag Eio.Net.datagram_socket_ty r Handler.t; + on_getaddrinfo : Eio.Net.Sockaddr.t list Handler.t; + on_getnameinfo : (string * string) Handler.t; + } + + let make label = { + label; + on_listen = Handler.make (`Raise (Failure "Mock listen handler not configured")); + on_connect = Handler.make (`Raise (Failure "Mock connect handler not configured")); + on_datagram_socket = Handler.make (`Raise (Failure "Mock datagram_socket handler not configured")); + on_getaddrinfo = Handler.make (`Raise (Failure "Mock getaddrinfo handler not configured")); + on_getnameinfo = Handler.make (`Raise (Failure "Mock getnameinfo handler not configured")); + } + + let on_listen t = t.on_listen + let on_connect t = t.on_connect + let on_datagram_socket t = t.on_datagram_socket + let on_getaddrinfo t = t.on_getaddrinfo + let on_getnameinfo t = t.on_getnameinfo + + let listen t ~reuse_addr:_ ~reuse_port:_ ~backlog:_ ~sw addr = + traceln "%s: listen on %a" t.label Eio.Net.Sockaddr.pp addr; + let socket = Handler.run t.on_listen in + Switch.on_release sw (fun () -> Eio.Resource.close socket); + socket + + let connect t ~sw addr = + traceln "%s: connect to %a" t.label Eio.Net.Sockaddr.pp addr; + let socket = Handler.run t.on_connect in + Switch.on_release sw (fun () -> Eio.Flow.close socket); + socket + + let datagram_socket t ~reuse_addr:_ ~reuse_port:_ ~sw addr = + (match addr with + | #Eio.Net.Sockaddr.datagram as saddr -> traceln "%s: datagram_socket %a" t.label Eio.Net.Sockaddr.pp saddr + | `UdpV4 -> traceln "%s: datagram_socket UDPv4" t.label + | `UdpV6 -> traceln "%s: datagram_socket UDPv6" t.label + ); + let socket = Handler.run t.on_datagram_socket in + Switch.on_release sw (fun () -> Eio.Flow.close socket); + socket + + let getaddrinfo t ~service node = + traceln "%s: getaddrinfo ~service:%s %s" t.label service node; + Handler.run t.on_getaddrinfo + + let getnameinfo t sockaddr = + traceln "%s: getnameinfo %a" t.label Eio.Net.Sockaddr.pp sockaddr; + Handler.run t.on_getnameinfo + + type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, ty) Eio.Resource.pi + let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t +end + +let make : string -> t = + let super = Eio.Net.Pi.network (module Impl) in + let handler = Eio.Resource.handler ( + H (Impl.Raw, Fun.id) :: + Eio.Resource.bindings super + ) in + fun label -> Eio.Resource.T (Impl.make label, handler) let on_connect (t:t) actions = - let as_socket x = (x :> Eio.Net.stream_socket) in - Handler.seq t#on_connect (List.map (Action.map as_socket) actions) + let t = Impl.raw t in + let as_socket x = (x :> [`Generic] Eio.Net.stream_socket_ty r) in + Handler.seq t.on_connect (List.map (Action.map as_socket) actions) let on_listen (t:t) actions = - let as_socket x = (x :> Eio.Net.listening_socket) in - Handler.seq t#on_listen (List.map (Action.map as_socket) actions) + let t = Impl.raw t in + let as_socket x = (x :> [`Generic] Eio.Net.listening_socket_ty r) in + Handler.seq t.on_listen (List.map (Action.map as_socket) actions) -let on_datagram_socket (t:t) actions = - let as_socket x = (x :> Eio.Net.datagram_socket) in - Handler.seq t#on_datagram_socket (List.map (Action.map as_socket) actions) +let on_datagram_socket (t:t) (actions : _ r Handler.actions) = + let t = Impl.raw t in + let as_socket x = (x :> [`Generic] Eio.Net.datagram_socket_ty r) in + Handler.seq t.on_datagram_socket (List.map (Action.map as_socket) actions) -let on_getaddrinfo (t:t) actions = Handler.seq t#on_getaddrinfo actions +let on_getaddrinfo (t:t) actions = Handler.seq (Impl.raw t).on_getaddrinfo actions -let on_getnameinfo (t:t) actions = Handler.seq t#on_getnameinfo actions +let on_getnameinfo (t:t) actions = Handler.seq (Impl.raw t).on_getnameinfo actions -type listening_socket = < - Eio.Net.listening_socket; - on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t; -> +type listening_socket_ty = [`Generic | `Mock] Eio.Net.listening_socket_ty +type listening_socket = listening_socket_ty r -let listening_socket label = - let on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured")) in - object - inherit Eio.Net.listening_socket +module Listening_socket = struct + type t = { + label : string; + on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t; + } - method on_accept = on_accept + type tag = [`Generic] - method accept ~sw = - let socket, addr = Handler.run on_accept in - Flow.attach_to_switch socket sw; - traceln "%s: accepted connection from %a" label Eio.Net.Sockaddr.pp addr; - (socket :> Eio.Net.stream_socket), addr + let make label = + { + label; + on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured")) + } - method close = - traceln "%s: closed" label - end + let on_accept t = t.on_accept -let on_accept (l:listening_socket) actions = + let accept t ~sw = + let socket, addr = Handler.run t.on_accept in + Flow.attach_to_switch (socket : Flow.t) sw; + traceln "%s: accepted connection from %a" t.label Eio.Net.Sockaddr.pp addr; + (socket :> tag Eio.Net.stream_socket_ty r), addr + + let close t = + traceln "%s: closed" t.label + + type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> t, listening_socket_ty) Eio.Resource.pi + let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t +end + +let listening_socket_handler = + Eio.Resource.handler @@ + Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module Listening_socket)) @ [ + H (Listening_socket.Type, Fun.id); + ] + +let listening_socket label : listening_socket = + Eio.Resource.T (Listening_socket.make label, listening_socket_handler) + +let on_accept l actions = + let r = Listening_socket.raw l in let as_accept_pair x = (x :> Flow.t * Eio.Net.Sockaddr.stream) in - Handler.seq l#on_accept (List.map (Action.map as_accept_pair) actions) + Handler.seq r.on_accept (List.map (Action.map as_accept_pair) actions) diff --git a/lib_eio/net.ml b/lib_eio/net.ml index ee9eeee42..87095d63d 100644 --- a/lib_eio/net.ml +++ b/lib_eio/net.ml @@ -1,3 +1,5 @@ +open Std + type connection_failure = | Refused of Exn.Backend.t | No_matching_addresses @@ -157,30 +159,113 @@ module Sockaddr = struct Format.fprintf f "udp:%a:%d" Ipaddr.pp_for_uri addr port end -class virtual socket = object (_ : ) - method probe _ = None -end +type socket_ty = [`Socket | `Close] +type 'a socket = ([> socket_ty] as 'a) r -class virtual stream_socket = object (_ : #socket) - inherit Flow.two_way -end +type 'tag stream_socket_ty = [`Stream | `Platform of 'tag | `Shutdown | socket_ty | Flow.source_ty | Flow.sink_ty] +type 'a stream_socket = 'a r + constraint 'a = [> [> `Generic] stream_socket_ty] -class virtual listening_socket = object (_ : ) - inherit socket - method virtual accept : sw:Switch.t -> stream_socket * Sockaddr.stream -end +type 'tag listening_socket_ty = [ `Accept | `Platform of 'tag | socket_ty] +type 'a listening_socket = 'a r + constraint 'a = [> [> `Generic] listening_socket_ty] + +type 'a connection_handler = 'a stream_socket -> Sockaddr.stream -> unit + +type 'tag datagram_socket_ty = [`Datagram | `Platform of 'tag | `Shutdown | socket_ty] +type 'a datagram_socket = 'a r + constraint 'a = [> [> `Generic] datagram_socket_ty] + +type 'tag ty = [`Network | `Platform of 'tag] +type 'a t = 'a r + constraint 'a = [> [> `Generic] ty] + +module Pi = struct + module type STREAM_SOCKET = sig + type tag + include Flow.Pi.SHUTDOWN + include Flow.Pi.SOURCE with type t := t + include Flow.Pi.SINK with type t := t + end + + let stream_socket (type t tag) (module X : STREAM_SOCKET with type t = t and type tag = tag) = + Resource.handler @@ + Resource.bindings (Flow.Pi.source (module X)) @ + Resource.bindings (Flow.Pi.sink (module X)) @ + Resource.bindings (Flow.Pi.shutdown (module X)) + + module type DATAGRAM_SOCKET = sig + type tag + include Flow.Pi.SHUTDOWN + val send : t -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit + val recv : t -> Cstruct.t -> Sockaddr.datagram * int + end + + type (_, _, _) Resource.pi += + | Datagram_socket : ('t, (module DATAGRAM_SOCKET with type t = 't), [> _ datagram_socket_ty]) Resource.pi -type connection_handler = stream_socket -> Sockaddr.stream -> unit + let datagram_socket (type t tag) (module X : DATAGRAM_SOCKET with type t = t and type tag = tag) = + Resource.handler @@ + Resource.bindings (Flow.Pi.shutdown (module X)) @ [ + H (Datagram_socket, (module X)) + ] -let accept ~sw (t : #listening_socket) = t#accept ~sw + module type LISTENING_SOCKET = sig + type t + type tag -let accept_fork ~sw (t : #listening_socket) ~on_error handle = + val accept : t -> sw:Switch.t -> tag stream_socket_ty r * Sockaddr.stream + + val close : t -> unit + end + + type (_, _, _) Resource.pi += + | Listening_socket : ('t, (module LISTENING_SOCKET with type t = 't and type tag = 'tag), [> 'tag listening_socket_ty]) Resource.pi + + let listening_socket (type t tag) (module X : LISTENING_SOCKET with type t = t and type tag = tag) = + Resource.handler [ + H (Resource.Close, X.close); + H (Listening_socket, (module X)) + ] + + module type NETWORK = sig + type t + type tag + + val listen : t -> reuse_addr:bool -> reuse_port:bool -> backlog:int -> sw:Switch.t -> Sockaddr.stream -> tag listening_socket_ty r + val connect : t -> sw:Switch.t -> Sockaddr.stream -> tag stream_socket_ty r + val datagram_socket : + t + -> reuse_addr:bool + -> reuse_port:bool + -> sw:Switch.t + -> [Sockaddr.datagram | `UdpV4 | `UdpV6] + -> tag datagram_socket_ty r + + val getaddrinfo : t -> service:string -> string -> Sockaddr.t list + val getnameinfo : t -> Sockaddr.t -> (string * string) + end + + type (_, _, _) Resource.pi += + | Network : ('t, (module NETWORK with type t = 't and type tag = 'tag), [> 'tag ty]) Resource.pi + + let network (type t tag) (module X : NETWORK with type t = t and type tag = tag) = + Resource.handler [ + H (Network, (module X)); + ] +end + +let accept ~sw (type tag) (Resource.T (t, ops) : [> tag listening_socket_ty] r) = + let module X = (val (Resource.get ops Pi.Listening_socket)) in + X.accept t ~sw + +let accept_fork ~sw (t : [> 'a listening_socket_ty] r) ~on_error handle = let child_started = ref false in let flow, addr = accept ~sw t in Fun.protect ~finally:(fun () -> if !child_started = false then Flow.close flow) (fun () -> Fiber.fork ~sw (fun () -> - match child_started := true; handle (flow :> stream_socket) addr with + match child_started := true; handle (flow :> 'a stream_socket_ty r) addr with | x -> Flow.close flow; x | exception (Cancel.Cancelled _ as ex) -> Flow.close flow; @@ -191,42 +276,37 @@ let accept_fork ~sw (t : #listening_socket) ~on_error handle = ) ) -class virtual datagram_socket = object - inherit socket - method virtual send : ?dst:Sockaddr.datagram -> Cstruct.t list -> unit - method virtual recv : Cstruct.t -> Sockaddr.datagram * int -end +let send (Resource.T (t, ops)) ?dst bufs = + let module X = (val (Resource.get ops Pi.Datagram_socket)) in + X.send t ?dst bufs -let send (t:#datagram_socket) = t#send -let recv (t:#datagram_socket) = t#recv - -class virtual t = object - method virtual listen : reuse_addr:bool -> reuse_port:bool -> backlog:int -> sw:Switch.t -> Sockaddr.stream -> listening_socket - method virtual connect : sw:Switch.t -> Sockaddr.stream -> stream_socket - method virtual datagram_socket : - reuse_addr:bool - -> reuse_port:bool - -> sw:Switch.t - -> [Sockaddr.datagram | `UdpV4 | `UdpV6] - -> datagram_socket - - method virtual getaddrinfo : service:string -> string -> Sockaddr.t list - method virtual getnameinfo : Sockaddr.t -> (string * string) -end +let recv (Resource.T (t, ops)) buf = + let module X = (val (Resource.get ops Pi.Datagram_socket)) in + X.recv t buf -let listen ?(reuse_addr=false) ?(reuse_port=false) ~backlog ~sw (t:#t) = t#listen ~reuse_addr ~reuse_port ~backlog ~sw +let listen (type tag) ?(reuse_addr=false) ?(reuse_port=false) ~backlog ~sw (t:[> tag ty] r) = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + X.listen t ~reuse_addr ~reuse_port ~backlog ~sw -let connect ~sw (t:#t) addr = - try t#connect ~sw addr +let connect (type tag) ~sw (t:[> tag ty] r) addr = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + try X.connect t ~sw addr with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in Exn.reraise_with_context ex bt "connecting to %a" Sockaddr.pp addr -let datagram_socket ?(reuse_addr=false) ?(reuse_port=false) ~sw (t:#t) addr = +let datagram_socket (type tag) ?(reuse_addr=false) ?(reuse_port=false) ~sw (t:[> tag ty] r) addr = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in let addr = (addr :> [Sockaddr.datagram | `UdpV4 | `UdpV6]) in - t#datagram_socket ~reuse_addr ~reuse_port ~sw addr + X.datagram_socket t ~reuse_addr ~reuse_port ~sw addr -let getaddrinfo ?(service="") (t:#t) hostname = t#getaddrinfo ~service hostname +let getaddrinfo (type tag) ?(service="") (t:[> tag ty] r) hostname = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + X.getaddrinfo t ~service hostname let getaddrinfo_stream ?service t hostname = getaddrinfo ?service t hostname @@ -242,9 +322,12 @@ let getaddrinfo_datagram ?service t hostname = | _ -> None ) -let getnameinfo (t:#t) sockaddr = t#getnameinfo sockaddr +let getnameinfo (type tag) (t:[> tag ty] r) sockaddr = + let (Resource.T (t, ops)) = t in + let module X = (val (Resource.get ops Pi.Network)) in + X.getnameinfo t sockaddr -let close = Generic.close +let close = Resource.close let with_tcp_connect ?(timeout=Time.Timeout.none) ~host ~service t f = Switch.run @@ fun sw -> diff --git a/lib_eio/net.mli b/lib_eio/net.mli index 71f13b542..a1cb71ad3 100644 --- a/lib_eio/net.mli +++ b/lib_eio/net.mli @@ -11,6 +11,8 @@ ]} *) +open Std + type connection_failure = | Refused of Exn.Backend.t | No_matching_addresses @@ -100,45 +102,34 @@ module Sockaddr : sig val pp : Format.formatter -> [< t] -> unit end -(** {2 Provider Interfaces} *) +(** {2 Types} *) -class virtual socket : object () - inherit Generic.t -end +type socket_ty = [`Socket | `Close] +type 'a socket = ([> socket_ty] as 'a) r -class virtual stream_socket : object - inherit socket - inherit Flow.two_way -end +type 'tag stream_socket_ty = [`Stream | `Platform of 'tag | `Shutdown | socket_ty | Flow.source_ty | Flow.sink_ty] +type 'a stream_socket = 'a r + constraint 'a = [> [> `Generic] stream_socket_ty] -class virtual datagram_socket : object - inherit socket - method virtual send : ?dst:Sockaddr.datagram -> Cstruct.t list -> unit - method virtual recv : Cstruct.t -> Sockaddr.datagram * int -end +type 'tag listening_socket_ty = [ `Accept | `Platform of 'tag | socket_ty] +type 'a listening_socket = 'a r + constraint 'a = [> [> `Generic] listening_socket_ty] -class virtual listening_socket : object () - inherit socket - method virtual accept : sw:Switch.t -> stream_socket * Sockaddr.stream -end +type 'a connection_handler = 'a stream_socket -> Sockaddr.stream -> unit +(** A [_ connection_handler] handles incoming connections from a listening socket. *) -class virtual t : object - method virtual listen : reuse_addr:bool -> reuse_port:bool -> backlog:int -> sw:Switch.t -> Sockaddr.stream -> listening_socket - method virtual connect : sw:Switch.t -> Sockaddr.stream -> stream_socket - method virtual datagram_socket : - reuse_addr:bool - -> reuse_port:bool - -> sw:Switch.t - -> [Sockaddr.datagram | `UdpV4 | `UdpV6] - -> datagram_socket - - method virtual getaddrinfo : service:string -> string -> Sockaddr.t list - method virtual getnameinfo : Sockaddr.t -> (string * string) -end +type 'tag datagram_socket_ty = [`Datagram | `Platform of 'tag | `Shutdown | socket_ty] +type 'a datagram_socket = 'a r + constraint 'a = [> [> `Generic] datagram_socket_ty] + +type 'tag ty = [`Network | `Platform of 'tag] + +type 'a t = 'a r + constraint 'a = [> [> `Generic] ty] (** {2 Out-bound Connections} *) -val connect : sw:Switch.t -> #t -> Sockaddr.stream -> stream_socket +val connect : sw:Switch.t -> [> 'tag ty] t -> Sockaddr.stream -> 'tag stream_socket_ty r (** [connect ~sw t addr] is a new socket connected to remote address [addr]. The new socket will be closed when [sw] finishes, unless closed manually first. *) @@ -147,8 +138,8 @@ val with_tcp_connect : ?timeout:Time.Timeout.t -> host:string -> service:string -> - #t -> - (stream_socket -> 'b) -> + [> 'tag ty] r -> + ('tag stream_socket_ty r -> 'b) -> 'b (** [with_tcp_connect ~host ~service t f] creates a tcp connection [conn] to [host] and [service] and executes [f conn]. @@ -169,7 +160,9 @@ val with_tcp_connect : (** {2 Incoming Connections} *) -val listen : ?reuse_addr:bool -> ?reuse_port:bool -> backlog:int -> sw:Switch.t -> #t -> Sockaddr.stream -> listening_socket +val listen : + ?reuse_addr:bool -> ?reuse_port:bool -> backlog:int -> sw:Switch.t -> + [> 'tag ty] r -> Sockaddr.stream -> 'tag listening_socket_ty r (** [listen ~sw ~backlog t addr] is a new listening socket bound to local address [addr]. The new socket will be closed when [sw] finishes, unless closed manually first. @@ -183,21 +176,18 @@ val listen : ?reuse_addr:bool -> ?reuse_port:bool -> backlog:int -> sw:Switch.t val accept : sw:Switch.t -> - #listening_socket -> - stream_socket * Sockaddr.stream + [> 'tag listening_socket_ty] r -> + 'tag stream_socket_ty r * Sockaddr.stream (** [accept ~sw socket] waits until a new connection is ready on [socket] and returns it. The new socket will be closed automatically when [sw] finishes, if not closed earlier. If you want to handle multiple connections, consider using {!accept_fork} instead. *) -type connection_handler = stream_socket -> Sockaddr.stream -> unit -(** [connection_handler] handles incoming connections from a listening socket. *) - val accept_fork : sw:Switch.t -> - #listening_socket -> + [> 'tag listening_socket_ty] r -> on_error:(exn -> unit) -> - connection_handler -> + [< 'tag stream_socket_ty] connection_handler -> unit (** [accept_fork ~sw ~on_error socket fn] accepts a connection and handles it in a new fiber. @@ -222,8 +212,8 @@ val run_server : ?additional_domains:(#Domain_manager.t * int) -> ?stop:'a Promise.t -> on_error:(exn -> unit) -> - #listening_socket -> - connection_handler -> + [> 'tag listening_socket_ty ] r -> + [< 'tag stream_socket_ty] connection_handler -> 'a (** [run_server ~on_error sock connection_handler] establishes a concurrent socket server [s]. @@ -253,9 +243,9 @@ val datagram_socket : ?reuse_addr:bool -> ?reuse_port:bool -> sw:Switch.t - -> #t + -> [> 'tag ty] r -> [< Sockaddr.datagram | `UdpV4 | `UdpV6] - -> datagram_socket + -> 'tag datagram_socket_ty r (** [datagram_socket ~sw t addr] creates a new datagram socket bound to [addr]. The new socket will be closed when [sw] finishes. @@ -267,19 +257,19 @@ val datagram_socket : @param reuse_addr Set the {!Unix.SO_REUSEADDR} socket option. @param reuse_port Set the {!Unix.SO_REUSEPORT} socket option. *) -val send : #datagram_socket -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit +val send : _ datagram_socket -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit (** [send sock buf] sends the data in [buf] using the the datagram socket [sock]. @param dst If [sock] isn't connected, this provides the destination. *) -val recv : #datagram_socket -> Cstruct.t -> Sockaddr.datagram * int +val recv : _ datagram_socket -> Cstruct.t -> Sockaddr.datagram * int (** [recv sock buf] receives data from the socket [sock] putting it in [buf]. The number of bytes received is returned along with the sender address and port. If the [buf] is too small then excess bytes may be discarded depending on the type of the socket the message is received from. *) (** {2 DNS queries} *) -val getaddrinfo: ?service:string -> #t -> string -> Sockaddr.t list +val getaddrinfo: ?service:string -> _ t -> string -> Sockaddr.t list (** [getaddrinfo ?service t node] returns a list of IP addresses for [node]. [node] is either a domain name or an IP address. @@ -288,18 +278,82 @@ val getaddrinfo: ?service:string -> #t -> string -> Sockaddr.t list For a more thorough treatment, see {{:https://man7.org/linux/man-pages/man3/getaddrinfo.3.html} getaddrinfo}. *) -val getaddrinfo_stream: ?service:string -> #t -> string -> Sockaddr.stream list +val getaddrinfo_stream: ?service:string -> _ t -> string -> Sockaddr.stream list (** [getaddrinfo_stream] is like {!getaddrinfo}, but filters out non-stream protocols. *) -val getaddrinfo_datagram: ?service:string -> #t -> string -> Sockaddr.datagram list +val getaddrinfo_datagram: ?service:string -> _ t -> string -> Sockaddr.datagram list (** [getaddrinfo_datagram] is like {!getaddrinfo}, but filters out non-datagram protocols. *) -val getnameinfo : #t -> Sockaddr.t -> (string * string) +val getnameinfo : _ t -> Sockaddr.t -> (string * string) (** [getnameinfo t sockaddr] is [(hostname, service)] corresponding to [sockaddr]. [hostname] is the registered domain name represented by [sockaddr]. [service] is the IANA specified textual name of the port specified in [sockaddr], e.g. 'ftp', 'http', 'https', etc. *) (** {2 Closing} *) -val close : #Generic.close -> unit -(** Alias of {!Generic.close}. *) +val close : [> `Close] r -> unit +(** Alias of {!Resource.close}. *) + +(** {2 Provider Interface} *) + +module Pi : sig + module type STREAM_SOCKET = sig + type tag + include Flow.Pi.SHUTDOWN + include Flow.Pi.SOURCE with type t := t + include Flow.Pi.SINK with type t := t + end + + val stream_socket : + (module STREAM_SOCKET with type t = 't and type tag = 'tag) -> + ('t, 'tag stream_socket_ty) Resource.handler + + module type DATAGRAM_SOCKET = sig + type tag + include Flow.Pi.SHUTDOWN + val send : t -> ?dst:Sockaddr.datagram -> Cstruct.t list -> unit + val recv : t -> Cstruct.t -> Sockaddr.datagram * int + end + + val datagram_socket : + (module DATAGRAM_SOCKET with type t = 't and type tag = 'tag) -> + ('t, 'tag datagram_socket_ty) Resource.handler + + module type LISTENING_SOCKET = sig + type t + type tag + + val accept : t -> sw:Switch.t -> tag stream_socket_ty r * Sockaddr.stream + val close : t -> unit + end + + val listening_socket : + (module LISTENING_SOCKET with type t = 't and type tag = 'tag) -> + ('t, 'tag listening_socket_ty) Resource.handler + + module type NETWORK = sig + type t + type tag + + val listen : + t -> reuse_addr:bool -> reuse_port:bool -> backlog:int -> sw:Switch.t -> + Sockaddr.stream -> tag listening_socket_ty r + + val connect : t -> sw:Switch.t -> Sockaddr.stream -> tag stream_socket_ty r + + val datagram_socket : + t + -> reuse_addr:bool + -> reuse_port:bool + -> sw:Switch.t + -> [Sockaddr.datagram | `UdpV4 | `UdpV6] + -> tag datagram_socket_ty r + + val getaddrinfo : t -> service:string -> string -> Sockaddr.t list + val getnameinfo : t -> Sockaddr.t -> (string * string) + end + + val network : + (module NETWORK with type t = 't and type tag = 'tag) -> + ('t, 'tag ty) Resource.handler +end diff --git a/lib_eio/path.ml b/lib_eio/path.ml index 6f5875d0c..0655d3962 100644 --- a/lib_eio/path.ml +++ b/lib_eio/path.ml @@ -1,4 +1,4 @@ -type 'a t = (#Fs.dir as 'a) * Fs.path +type 'a t = 'a Fs.dir * Fs.path let ( / ) (dir, p1) p2 = match p1, p2 with @@ -7,39 +7,50 @@ let ( / ) (dir, p1) p2 = | ".", p2 -> (dir, p2) | p1, p2 -> (dir, Filename.concat p1 p2) -let pp f ((t:#Fs.dir), p) = - if p = "" then Fmt.pf f "<%t>" t#pp - else Fmt.pf f "<%t:%s>" t#pp (String.escaped p) +let pp f (Resource.T (t, ops), p) = + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + if p = "" then Fmt.pf f "<%a>" X.pp t + else Fmt.pf f "<%a:%s>" X.pp t (String.escaped p) -let open_in ~sw ((t:#Fs.dir), path) = - try t#open_in ~sw path +let open_in ~sw t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.open_in dir ~sw path with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "opening %a" pp (t, path) + Exn.reraise_with_context ex bt "opening %a" pp t -let open_out ~sw ?(append=false) ~create ((t:#Fs.dir), path) = - try t#open_out ~sw ~append ~create path +let open_out ~sw ?(append=false) ~create t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.open_out dir ~sw ~append ~create path with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "opening %a" pp (t, path) + Exn.reraise_with_context ex bt "opening %a" pp t -let open_dir ~sw ((t:#Fs.dir), path) = - try (t#open_dir ~sw path, "") +let open_dir ~sw t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.open_dir dir ~sw path, "" with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "opening directory %a" pp (t, path) + Exn.reraise_with_context ex bt "opening directory %a" pp t -let mkdir ~perm ((t:#Fs.dir), path) = - try t#mkdir ~perm path +let mkdir ~perm t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.mkdir dir ~perm path with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "creating directory %a" pp (t, path) + Exn.reraise_with_context ex bt "creating directory %a" pp t -let read_dir ((t:#Fs.dir), path) = - try List.sort String.compare (t#read_dir path) +let read_dir t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try List.sort String.compare (X.read_dir dir path) with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "reading directory %a" pp (t, path) + Exn.reraise_with_context ex bt "reading directory %a" pp t let with_open_in path fn = Switch.run @@ fun sw -> fn (open_in ~sw path) @@ -77,20 +88,27 @@ let save ?append ~create path data = with_open_out ?append ~create path @@ fun flow -> Flow.copy_string data flow -let unlink ((t:#Fs.dir), path) = - try t#unlink path +let unlink t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.unlink dir path with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "removing file %a" pp (t, path) + Exn.reraise_with_context ex bt "removing file %a" pp t -let rmdir ((t:#Fs.dir), path) = - try t#rmdir path +let rmdir t = + let (Resource.T (dir, ops), path) = t in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.rmdir dir path with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "removing directory %a" pp (t, path) + Exn.reraise_with_context ex bt "removing directory %a" pp t -let rename ((t1:#Fs.dir), old_path) (t2, new_path) = - try t1#rename old_path (t2 :> Fs.dir) new_path +let rename t1 t2 = + let (dir2, new_path) = t2 in + let (Resource.T (dir, ops), old_path) = t1 in + let module X = (val (Resource.get ops Fs.Pi.Dir)) in + try X.rename dir old_path (dir2 :> _ Fs.dir) new_path with Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in - Exn.reraise_with_context ex bt "renaming %a to %a" pp (t1, old_path) pp (t2, new_path) + Exn.reraise_with_context ex bt "renaming %a to %a" pp t1 pp t2 diff --git a/lib_eio/path.mli b/lib_eio/path.mli index 77ac9fd83..0334cc5a0 100644 --- a/lib_eio/path.mli +++ b/lib_eio/path.mli @@ -25,9 +25,10 @@ ]} *) +open Std open Fs -type 'a t = (#Fs.dir as 'a) * path +type 'a t = 'a Fs.dir * path (** An OS directory FD and a path relative to it, for use with e.g. [openat(2)]. *) val ( / ) : 'a t -> string -> 'a t @@ -47,12 +48,12 @@ val load : _ t -> string This is a convenience wrapper around {!with_open_in}. *) -val open_in : sw:Switch.t -> _ t -> +val open_in : sw:Switch.t -> _ t -> File.ro_ty r (** [open_in ~sw t] opens [t] for reading. Note: files are always opened in binary mode. *) -val with_open_in : _ t -> ( -> 'a) -> 'a +val with_open_in : _ t -> (File.ro_ty r -> 'a) -> 'a (** [with_open_in] is like [open_in], but calls [fn flow] with the new flow and closes it automatically when [fn] returns (if it hasn't already been closed by then). *) @@ -72,7 +73,7 @@ val open_out : sw:Switch.t -> ?append:bool -> create:create -> - _ t -> + _ t -> File.rw_ty Resource.t (** [open_out ~sw t] opens [t] for reading and writing. Note: files are always opened in binary mode. @@ -82,7 +83,7 @@ val open_out : val with_open_out : ?append:bool -> create:create -> - _ t -> ( -> 'a) -> 'a + _ t -> (File.rw_ty r -> 'a) -> 'a (** [with_open_out] is like [open_out], but calls [fn flow] with the new flow and closes it automatically when [fn] returns (if it hasn't already been closed by then). *) @@ -91,12 +92,12 @@ val with_open_out : val mkdir : perm:File.Unix_perm.t -> _ t -> unit (** [mkdir ~perm t] creates a new directory [t] with permissions [perm]. *) -val open_dir : sw:Switch.t -> _ t -> t +val open_dir : sw:Switch.t -> _ t -> [`Close | dir_ty] t (** [open_dir ~sw t] opens [t]. This can be passed to functions to grant access only to the subtree [t]. *) -val with_open_dir : _ t -> ( t -> 'a) -> 'a +val with_open_dir : _ t -> ([`Close | dir_ty] t -> 'a) -> 'a (** [with_open_dir] is like [open_dir], but calls [fn dir] with the new directory and closes it automatically when [fn] returns (if it hasn't already been closed by then). *) diff --git a/lib_eio/process.ml b/lib_eio/process.ml index 02267efc8..0a5cd16d9 100644 --- a/lib_eio/process.ml +++ b/lib_eio/process.ml @@ -1,3 +1,5 @@ +open Std + type exit_status = [ | `Exited of int | `Signaled of int @@ -49,14 +51,14 @@ let signal proc = proc#signal class virtual mgr = object method virtual pipe : sw:Switch.t -> - * + [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r method virtual spawn : sw:Switch.t -> - ?cwd:Fs.dir Path.t -> - ?stdin:Flow.source -> - ?stdout:Flow.sink -> - ?stderr:Flow.sink -> + ?cwd:Fs.dir_ty Path.t -> + ?stdin:Flow.source_ty r -> + ?stdout:Flow.sink_ty r -> + ?stderr:Flow.sink_ty r -> ?env:string array -> ?executable:string -> string list -> @@ -77,12 +79,12 @@ let pp_args = Fmt.hbox (Fmt.list ~sep:Fmt.sp pp_arg) let spawn ~sw (t:#mgr) ?cwd ?stdin ?stdout ?stderr ?env ?executable args = t#spawn ~sw - ?cwd:(cwd :> Fs.dir Path.t option) + ?cwd:(cwd :> Fs.dir_ty Path.t option) ?env ?executable args - ?stdin:(stdin :> Flow.source option) - ?stdout:(stdout :> Flow.sink option) - ?stderr:(stderr :> Flow.sink option) + ?stdin:(stdin :> Flow.source_ty r option) + ?stdout:(stdout :> Flow.sink_ty r option) + ?stderr:(stderr :> Flow.sink_ty r option) let run (t:#mgr) ?cwd ?stdin ?stdout ?stderr ?(is_success = Int.equal 0) ?env ?executable args = Switch.run @@ fun sw -> diff --git a/lib_eio/process.mli b/lib_eio/process.mli index 4d6325f77..f6b593037 100644 --- a/lib_eio/process.mli +++ b/lib_eio/process.mli @@ -6,6 +6,8 @@ ]} *) +open Std + (** {2 Status and error types} *) type exit_status = [ @@ -69,14 +71,14 @@ val signal : #t -> int -> unit class virtual mgr : object method virtual pipe : sw:Switch.t -> - * + [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r method virtual spawn : sw:Switch.t -> - ?cwd:Fs.dir Path.t -> - ?stdin:Flow.source -> - ?stdout:Flow.sink -> - ?stderr:Flow.sink -> + ?cwd:Fs.dir_ty Path.t -> + ?stdin:Flow.source_ty r -> + ?stdout:Flow.sink_ty r -> + ?stderr:Flow.sink_ty r -> ?env:string array -> ?executable:string -> string list -> @@ -87,10 +89,10 @@ end val spawn : sw:Switch.t -> #mgr -> - ?cwd:#Fs.dir Path.t -> - ?stdin:#Flow.source -> - ?stdout:#Flow.sink -> - ?stderr:#Flow.sink -> + ?cwd:Fs.dir_ty Path.t -> + ?stdin:_ Flow.source -> + ?stdout:_ Flow.sink -> + ?stderr:_ Flow.sink -> ?env:string array -> ?executable:string -> string list -> t @@ -113,10 +115,10 @@ val spawn : val run : #mgr -> - ?cwd:#Fs.dir Path.t -> - ?stdin:#Flow.source -> - ?stdout:#Flow.sink -> - ?stderr:#Flow.sink -> + ?cwd:_ Path.t -> + ?stdin:_ Flow.source -> + ?stdout:_ Flow.sink -> + ?stderr:_ Flow.sink -> ?is_success:(int -> bool) -> ?env:string array -> ?executable:string -> @@ -132,9 +134,9 @@ val run : val parse_out : #mgr -> 'a Buf_read.parser -> - ?cwd:#Fs.dir Path.t -> - ?stdin:#Flow.source -> - ?stderr:#Flow.sink -> + ?cwd:_ Path.t -> + ?stdin:_ Flow.source -> + ?stderr:_ Flow.sink -> ?is_success:(int -> bool) -> ?env:string array -> ?executable:string -> @@ -152,7 +154,7 @@ val parse_out : (** {2 Pipes} *) -val pipe : sw:Switch.t -> #mgr -> * +val pipe : sw:Switch.t -> #mgr -> [Flow.source_ty | Resource.close_ty] r * [Flow.sink_ty | Resource.close_ty] r (** [pipe ~sw mgr] creates a pipe backed by the OS. The flows can be used by {!spawn} without the need for extra fibers to copy the data. diff --git a/lib_eio/resource.ml b/lib_eio/resource.ml new file mode 100644 index 000000000..94db35b20 --- /dev/null +++ b/lib_eio/resource.ml @@ -0,0 +1,35 @@ +type ('t, 'impl, 'tags) pi = .. +type _ binding = H : ('t, 'impl, 'tags) pi * 'impl -> 't binding +type 't ops = 't binding array +type ('t, 'tags) handler = 't ops +type -'a t = T : ('t * 't ops) -> 'a t + +let not_supported () = failwith "Operation not supported!" + +let handler = Array.of_list +let bindings = Array.to_list + +let get : 't ops -> ('t, 'impl, 'tags) pi -> 'impl = fun ops op -> + let rec aux i = + if i = Array.length ops then not_supported (); + let H (k, v) = ops.(i) in + if Obj.repr k == Obj.repr op then Obj.magic v + else aux (i + 1) + in + aux 0 + +let get_opt : 't ops -> ('t, 'impl, 'tags) pi -> 'impl option = fun ops op -> + let rec aux i = + if i = Array.length ops then None + else ( + let H (k, v) = ops.(i) in + if Obj.repr k == Obj.repr op then Some (Obj.magic v) + else aux (i + 1) + ) + in + aux 0 + +type close_ty = [`Close] +type (_, _, _) pi += Close : ('t, 't -> unit, [> close_ty]) pi + +let close (T (t, ops)) = get ops Close t diff --git a/lib_eio/resource.mli b/lib_eio/resource.mli new file mode 100644 index 000000000..545737e41 --- /dev/null +++ b/lib_eio/resource.mli @@ -0,0 +1,114 @@ +(** Resources are typically operating-system provided resources such as open files + and network sockets. However, they can also be pure OCaml resources (such as mocks) + or wrappers (such as an encrypted flow that wraps an unencrypted OS flow). + + A resource's type shows which interfaces it supports. For example, a + [[source | sink] t] is a resource that can be used as a source or a sink. + + If you are familiar with object types, this is roughly equivalent to the + type []. We avoid using object types here as some OCaml + programmers find them confusing. *) + +(** {2 Types} *) + +type ('t, -'tags) handler +(** A [('t, 'tags) handler] can be used to look up the implementation for a type ['t]. + + ['tags] is a phantom type to record which interfaces are supported. + + Internally, a handler is a set of {!type-binding}s. *) + +type -'tags t = T : ('t * ('t, 'tags) handler) -> 'tags t (** *) +(** A resource is a pair of a value and a handler for it. + + Normally there will be convenience functions provided for using resources + and you will not need to match on [T] yourself except when defining a new interface. *) + +(** {2 Defining new interfaces} + + These types and functions can be used to define new interfaces that others + can implement. + + When defining a new interface, you will typically provide: + + - The tags that indicate that the interface is supported (e.g. {!Flow.source_ty}). + - A convenience type to match all sub-types easily (e.g. {!Flow.source}). + - Functions allowing users to call the interface (e.g. {!Flow.single_read}). + - A module to let providers implement the interface (e.g. {!Flow.Pi}). +*) + +type ('t, 'iface, 'tag) pi = .. +(** A provider interface describes an interface that a resource can implement. + + - ['t] is the type of the resource itself. + - ['iface] is the API that can be requested. + - ['tag] is the tag (or tags) indicating that the interface is supported. + + For example, the value {!Close} (of type [(fd, fd -> unit, [> `Close]) pi]) can be + used with a resource backed by an [fd], and which offers at least the + [`Close] tag, to request its close function. + Often, the API requested will be a module type, but it can be a single function + as in this example. +*) + +type _ binding = H : ('t, 'impl, 'tags) pi * 'impl -> 't binding (** *) +(** A binding [H (pi, impl)] says to use [impl] to implement [pi]. + + For example: [H (Close, M.close)]. *) + +val handler : 't binding list -> ('t, _) handler +(** [handler ops] is a handler that looks up interfaces using the assoc list [ops]. + + For example [shutdown (module Foo)] is a handler that handles the [Close] and [Shutdown] + interfaces for resources of type [Foo.t] by using the [Foo] module: + + {[ + let shutdown (type t) (module X : SHUTDOWN with type t = t) : (t, shutdown_ty) handler = + handler [ + H (Close, X.close); + H (Shutdown, (module X)); + ] + ]} + + Be sure to give the return type explicitly, as this cannot be inferred. +*) + +val bindings : ('t, _) handler -> 't binding list +(** [bindings (handler ops) = ops]. + + This is useful if you want to extend an interface + and you already have a handler for that interface. *) + +val get : ('t, 'tags) handler -> ('t, 'impl, 'tags) pi -> 'impl +(** [get handler iface] uses [handler] to get the implementation of [iface]. + + For example: + {[ + let write (Resource.T (t, ops)) bufs = + let module X = (val (Resource.get ops Sink)) in + X.write t bufs + ]} +*) + +val get_opt : ('t, _) handler -> ('t, 'impl, _) pi -> 'impl option +(** [get_opt] is like {!get}, but the handler need not have a compatible type. + Instead, this performs a check at runtime and returns [None] if the interface + is not supported. *) + +(** {2 Closing} + + Resources are usually attached to switches and closed automatically when the switch + finishes. However, it can be useful to close them sooner in some cases. *) + +type close_ty = [`Close] +type (_, _, _) pi += Close : ('t, 't -> unit, [> close_ty]) pi + +val close : [> close_ty] t -> unit +(** [close t] marks the resource as closed. It can no longer be used after this. + + If [t] is already closed then this does nothing (it does not raise an exception). + + Note: if an operation is currently in progress when this is called then it is not + necessarily cancelled, and any underlying OS resource (such as a file descriptor) + might not be closed immediately if other operations are using it. Closing a resource + only prevents new operations from starting. *) diff --git a/lib_eio/std.ml b/lib_eio/std.ml new file mode 100644 index 000000000..84fff968f --- /dev/null +++ b/lib_eio/std.ml @@ -0,0 +1,5 @@ +module Promise = Eio__core.Promise +module Fiber = Eio__core.Fiber +module Switch = Eio__core.Switch +type 'a r = 'a Resource.t +let traceln = Debug.traceln diff --git a/lib_eio/std.mli b/lib_eio/std.mli new file mode 100644 index 000000000..4c7478e8d --- /dev/null +++ b/lib_eio/std.mli @@ -0,0 +1,10 @@ +module Promise = Eio__core.Promise +module Fiber = Eio__core.Fiber +module Switch = Eio__core.Switch + +type 'a r = 'a Resource.t + +val traceln : + ?__POS__:string * int * int * int -> + ('a, Format.formatter, unit, unit) format4 -> 'a + (** Same as {!Eio.traceln}. *) diff --git a/lib_eio/unix/eio_unix.ml b/lib_eio/unix/eio_unix.ml index 472eade08..710df5aad 100644 --- a/lib_eio/unix/eio_unix.ml +++ b/lib_eio/unix/eio_unix.ml @@ -1,11 +1,12 @@ [@@@alert "-unstable"] +open Eio.Std + module Fd = Fd module Resource = Resource module Private = Private include Types -type socket = Net.stream_socket let await_readable = Private.await_readable let await_writable = Private.await_writable @@ -32,17 +33,17 @@ module Net = Net module Stdenv = struct type base = < - stdin : source; - stdout : sink; - stderr : sink; - net : Eio.Net.t; + stdin : source_ty r; + stdout : sink_ty r; + stderr : sink_ty r; + net : [`Unix | `Generic] Eio.Net.ty r; domain_mgr : Eio.Domain_manager.t; process_mgr : Process.mgr; clock : Eio.Time.clock; mono_clock : Eio.Time.Mono.t; - fs : Eio.Fs.dir Eio.Path.t; - cwd : Eio.Fs.dir Eio.Path.t; - secure_random : Eio.Flow.source; + fs : Eio.Fs.dir_ty Eio.Path.t; + cwd : Eio.Fs.dir_ty Eio.Path.t; + secure_random : Eio.Flow.source_ty r; debug : Eio.Debug.t; backend_id: string; > diff --git a/lib_eio/unix/eio_unix.mli b/lib_eio/unix/eio_unix.mli index 8f83b284b..4490a0353 100644 --- a/lib_eio/unix/eio_unix.mli +++ b/lib_eio/unix/eio_unix.mli @@ -16,27 +16,58 @@ module Fd = Fd (** Eio resources backed by an OS file descriptor. *) module Resource : sig - type t = < fd : Fd.t > - (** Resources that have FDs are sub-types of [t]. *) + type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t + (** Resources that have FDs are tagged with [`Unix_fd]. *) - val fd : -> Fd.t - (** [fd t] returns the FD being wrapped by a resource. *) + type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi - type _ Eio.Generic.ty += FD : Fd.t Eio.Generic.ty - (** Resources that wrap FDs can handle this in their [probe] method to expose the FD. *) + val fd : _ t -> Fd.t + (** [fd t] returns the FD being wrapped by a resource. *) - val fd_opt : #Eio.Generic.t -> Fd.t option + val fd_opt : _ Eio.Resource.t -> Fd.t option (** [fd_opt t] returns the FD being wrapped by a generic resource, if any. This just probes [t] using {!extension-FD}. *) + + module type FLOW = sig + include Eio.Net.Pi.STREAM_SOCKET + include Eio.File.Pi.WRITE with type t := t + + val fd : t -> Fd.t + end + + val flow_handler : + (module FLOW with type t = 't and type tag = 'tag) -> + ('t, [`Unix_fd | 'tag Eio.Net.stream_socket_ty | Eio.File.rw_ty]) Eio.Resource.handler + + module type DATAGRAM_SOCKET = sig + include Eio.Net.Pi.DATAGRAM_SOCKET + + val fd : t -> Fd.t + end + + val datagram_handler : + (module DATAGRAM_SOCKET with type t = 't and type tag = 'tag) -> + ('t, [`Unix_fd | 'tag Eio.Net.datagram_socket_ty]) Eio.Resource.handler + + module type LISTENING_SOCKET = sig + include Eio.Net.Pi.LISTENING_SOCKET + + val fd : t -> Fd.t + end + + val listening_socket_handler : + (module LISTENING_SOCKET with type t = 't and type tag = 'tag) -> + ('t, [`Unix_fd | 'tag Eio.Net.listening_socket_ty]) Eio.Resource.handler end module Net = Net (** Extended network API with support for file descriptors. *) -type source = < Eio.Flow.source; Resource.t; Eio.Flow.close > -type sink = < Eio.Flow.sink; Resource.t; Eio.Flow.close > -type socket = Net.stream_socket +type source_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.source_ty] +type sink_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.sink_ty] +type 'a source = ([> source_ty] as 'a) r +type 'a sink = ([> sink_ty] as 'a) r val await_readable : Unix.file_descr -> unit (** [await_readable fd] blocks until [fd] is readable (or has an error). *) @@ -54,7 +85,7 @@ val run_in_systhread : (unit -> 'a) -> 'a (** [run_in_systhread fn] runs the function [fn] in a newly created system thread (a {! Thread.t}). This allows blocking calls to be made non-blocking. *) -val pipe : Switch.t -> source * sink +val pipe : Switch.t -> source_ty r * sink_ty r (** [pipe sw] returns a connected pair of flows [src] and [sink]. Data written to [sink] can be read from [src]. Note that, like all FDs created by Eio, they are both marked as close-on-exec by default. *) @@ -65,17 +96,17 @@ module Process = Process (** The set of resources provided to a process on a Unix-compatible system. *) module Stdenv : sig type base = < - stdin : source; - stdout : sink; - stderr : sink; - net : Eio.Net.t; + stdin : source_ty r; + stdout : sink_ty r; + stderr : sink_ty r; + net : [`Unix | `Generic] Eio.Net.ty r; domain_mgr : Eio.Domain_manager.t; process_mgr : Process.mgr; clock : Eio.Time.clock; mono_clock : Eio.Time.Mono.t; - fs : Eio.Fs.dir Eio.Path.t; - cwd : Eio.Fs.dir Eio.Path.t; - secure_random : Eio.Flow.source; + fs : Eio.Fs.dir_ty Eio.Path.t; + cwd : Eio.Fs.dir_ty Eio.Path.t; + secure_random : Eio.Flow.source_ty r; debug : Eio.Debug.t; backend_id : string; > @@ -90,7 +121,7 @@ module Private : sig | Await_readable : Unix.file_descr -> unit Effect.t (** See {!await_readable} *) | Await_writable : Unix.file_descr -> unit Effect.t (** See {!await_writable} *) | Get_monotonic_clock : Eio.Time.Mono.t Effect.t - | Pipe : Eio.Switch.t -> (source * sink) Effect.t (** See {!pipe} *) + | Pipe : Eio.Switch.t -> (source_ty r * sink_ty r) Effect.t (** See {!pipe} *) module Rcfd = Rcfd diff --git a/lib_eio/unix/net.ml b/lib_eio/unix/net.ml index 95dcb8d48..a70fecf12 100644 --- a/lib_eio/unix/net.ml +++ b/lib_eio/unix/net.ml @@ -1,5 +1,12 @@ open Eio.Std +type stream_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.stream_socket_ty] +type datagram_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.datagram_socket_ty] +type listening_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.listening_socket_ty] +type 'a stream_socket = ([> stream_socket_ty] as 'a) r +type 'a datagram_socket = ([> datagram_socket_ty] as 'a) r +type 'a listening_socket = ([> listening_socket_ty] as 'a) r + module Ipaddr = struct let to_unix : _ Eio.Net.Ipaddr.t -> Unix.inet_addr = Obj.magic let of_unix : Unix.inet_addr -> _ Eio.Net.Ipaddr.t = Obj.magic @@ -23,14 +30,6 @@ let sockaddr_of_unix_datagram = function let host = Ipaddr.of_unix host in `Udp (host, port) -class virtual stream_socket = object (_ : ) - inherit Eio.Net.stream_socket -end - -class virtual datagram_socket = object (_ : ) - inherit Eio.Net.datagram_socket -end - let getnameinfo (sockaddr : Eio.Net.Sockaddr.t) = let options = match sockaddr with @@ -42,28 +41,30 @@ let getnameinfo (sockaddr : Eio.Net.Sockaddr.t) = let Unix.{ni_hostname; ni_service} = Unix.getnameinfo sockaddr options in (ni_hostname, ni_service)) -class virtual t = object - inherit Eio.Net.t - - method getnameinfo = getnameinfo -end +type t = [`Generic | `Unix] Eio.Net.ty r [@@@alert "-unstable"] type _ Effect.t += - | Import_socket_stream : Switch.t * bool * Unix.file_descr -> stream_socket Effect.t - | Import_socket_datagram : Switch.t * bool * Unix.file_descr -> datagram_socket Effect.t + | Import_socket_stream : Switch.t * bool * Unix.file_descr -> stream_socket_ty r Effect.t + | Import_socket_datagram : Switch.t * bool * Unix.file_descr -> datagram_socket_ty r Effect.t | Socketpair_stream : Switch.t * Unix.socket_domain * int -> - (stream_socket * stream_socket) Effect.t + (stream_socket_ty r * stream_socket_ty r) Effect.t | Socketpair_datagram : Switch.t * Unix.socket_domain * int -> - (datagram_socket * datagram_socket) Effect.t + (datagram_socket_ty r * datagram_socket_ty r) Effect.t + +let open_stream s = (s : _ stream_socket :> [< stream_socket_ty] r) +let open_datagram s = (s : _ datagram_socket :> [< datagram_socket_ty] r) -let import_socket_stream ~sw ~close_unix fd = Effect.perform (Import_socket_stream (sw, close_unix, fd)) +let import_socket_stream ~sw ~close_unix fd = + open_stream @@ Effect.perform (Import_socket_stream (sw, close_unix, fd)) -let import_socket_datagram ~sw ~close_unix fd = Effect.perform (Import_socket_datagram (sw, close_unix, fd)) +let import_socket_datagram ~sw ~close_unix fd = + open_datagram @@ Effect.perform (Import_socket_datagram (sw, close_unix, fd)) let socketpair_stream ~sw ?(domain=Unix.PF_UNIX) ?(protocol=0) () = - Effect.perform (Socketpair_stream (sw, domain, protocol)) + let a, b = Effect.perform (Socketpair_stream (sw, domain, protocol)) in + (open_stream a, open_stream b) let socketpair_datagram ~sw ?(domain=Unix.PF_UNIX) ?(protocol=0) () = Effect.perform (Socketpair_datagram (sw, domain, protocol)) diff --git a/lib_eio/unix/net.mli b/lib_eio/unix/net.mli index 4b53c58c6..ad4d4796c 100644 --- a/lib_eio/unix/net.mli +++ b/lib_eio/unix/net.mli @@ -4,19 +4,14 @@ open Eio.Std These extend the types in {!Eio.Net} with support for file descriptors. *) -class virtual stream_socket : object () - inherit Eio.Net.stream_socket -end - -class virtual datagram_socket : object () - inherit Eio.Net.datagram_socket -end +type stream_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.stream_socket_ty] +type datagram_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.datagram_socket_ty] +type listening_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.listening_socket_ty] +type 'a stream_socket = ([> stream_socket_ty] as 'a) r +type 'a datagram_socket = ([> datagram_socket_ty] as 'a) r +type 'a listening_socket = ([> listening_socket_ty] as 'a) r -class virtual t : object - inherit Eio.Net.t - - method getnameinfo : Eio.Net.Sockaddr.t -> (string * string) -end +type t = [`Generic | `Unix] Eio.Net.ty r (** {2 Unix address conversions} @@ -39,7 +34,7 @@ end (** {2 Creating or importing sockets} *) -val import_socket_stream : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> stream_socket +val import_socket_stream : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> stream_socket_ty r (** [import_socket_stream ~sw ~close_unix:true fd] is an Eio flow that uses [fd]. It can be cast to e.g. {!source} for a one-way flow. @@ -47,7 +42,7 @@ val import_socket_stream : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> The [close_unix] and [sw] arguments are passed to {!Fd.of_unix}. *) -val import_socket_datagram : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> datagram_socket +val import_socket_datagram : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> datagram_socket_ty r (** [import_socket_datagram ~sw ~close_unix:true fd] is an Eio datagram socket that uses [fd]. The socket object will be closed when [sw] finishes. @@ -59,7 +54,7 @@ val socketpair_stream : ?domain:Unix.socket_domain -> ?protocol:int -> unit -> - stream_socket * stream_socket + stream_socket_ty r * stream_socket_ty r (** [socketpair_stream ~sw ()] returns a connected pair of flows, such that writes to one can be read by the other. This creates OS-level resources using [socketpair(2)]. @@ -70,7 +65,7 @@ val socketpair_datagram : ?domain:Unix.socket_domain -> ?protocol:int -> unit -> - datagram_socket * datagram_socket + datagram_socket_ty r * datagram_socket_ty r (** [socketpair_datagram ~sw ()] returns a connected pair of flows, such that writes to one can be read by the other. This creates OS-level resources using [socketpair(2)]. @@ -83,11 +78,11 @@ val getnameinfo : Eio.Net.Sockaddr.t -> (string * string) type _ Effect.t += | Import_socket_stream : - Switch.t * bool * Unix.file_descr -> stream_socket Effect.t (** See {!import_socket_stream} *) + Switch.t * bool * Unix.file_descr -> stream_socket_ty r Effect.t (** See {!import_socket_stream} *) | Import_socket_datagram : - Switch.t * bool * Unix.file_descr -> datagram_socket Effect.t (** See {!import_socket_datagram} *) + Switch.t * bool * Unix.file_descr -> datagram_socket_ty r Effect.t (** See {!import_socket_datagram} *) | Socketpair_stream : Eio.Switch.t * Unix.socket_domain * int -> - (stream_socket * stream_socket) Effect.t (** See {!socketpair_stream} *) + (stream_socket_ty r * stream_socket_ty r) Effect.t (** See {!socketpair_stream} *) | Socketpair_datagram : Eio.Switch.t * Unix.socket_domain * int -> - (datagram_socket * datagram_socket) Effect.t (** See {!socketpair_datagram} *) + (datagram_socket_ty r * datagram_socket_ty r) Effect.t (** See {!socketpair_datagram} *) [@@alert "-unstable"] diff --git a/lib_eio/unix/private.ml b/lib_eio/unix/private.ml index 39764205b..ada01bc88 100644 --- a/lib_eio/unix/private.ml +++ b/lib_eio/unix/private.ml @@ -7,7 +7,7 @@ type _ Effect.t += | Await_readable : Unix.file_descr -> unit Effect.t | Await_writable : Unix.file_descr -> unit Effect.t | Get_monotonic_clock : Eio.Time.Mono.t Effect.t - | Pipe : Switch.t -> (source * sink) Effect.t + | Pipe : Switch.t -> (source_ty r * sink_ty r) Effect.t let await_readable fd = Effect.perform (Await_readable fd) let await_writable fd = Effect.perform (Await_writable fd) diff --git a/lib_eio/unix/process.ml b/lib_eio/unix/process.ml index 800104b22..38e0abc6b 100644 --- a/lib_eio/unix/process.ml +++ b/lib_eio/unix/process.ml @@ -72,11 +72,13 @@ let get_env = function class virtual mgr = object (self) inherit Eio.Process.mgr - method pipe ~sw = (Private.pipe sw :> * ) + method pipe ~sw = + (Private.pipe sw :> ([Eio.Resource.close_ty | Eio.Flow.source_ty] r * + [Eio.Resource.close_ty | Eio.Flow.sink_ty] r)) method virtual spawn_unix : sw:Switch.t -> - ?cwd:Eio.Fs.dir Eio.Path.t -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> env:string array -> fds:(int * Fd.t * Fork_action.blocking) list -> executable:string -> diff --git a/lib_eio/unix/process.mli b/lib_eio/unix/process.mli index bc92bc89e..5ec42e9c4 100644 --- a/lib_eio/unix/process.mli +++ b/lib_eio/unix/process.mli @@ -7,11 +7,11 @@ class virtual mgr : object method pipe : sw:Switch.t -> - * + [Eio.Flow.source_ty | Eio.Resource.close_ty] r * [Eio.Flow.sink_ty | Eio.Resource.close_ty] r method virtual spawn_unix : sw:Switch.t -> - ?cwd:Eio.Fs.dir Eio.Path.t -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> env:string array -> fds:(int * Fd.t * Fork_action.blocking) list -> executable:string -> @@ -20,10 +20,10 @@ class virtual mgr : object method spawn : sw:Switch.t -> - ?cwd:Eio.Fs.dir Eio.Path.t -> - ?stdin:Eio.Flow.source -> - ?stdout:Eio.Flow.sink -> - ?stderr:Eio.Flow.sink -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> + ?stdin:Eio.Flow.source_ty r -> + ?stdout:Eio.Flow.sink_ty r -> + ?stderr:Eio.Flow.sink_ty r -> ?env:string array -> ?executable:string -> string list -> @@ -34,7 +34,7 @@ end val spawn_unix : sw:Switch.t -> #mgr -> - ?cwd:Eio.Fs.dir Eio.Path.t -> + ?cwd:Eio.Fs.dir_ty Eio.Path.t -> fds:(int * Fd.t * Fork_action.blocking) list -> ?env:string array -> ?executable:string -> diff --git a/lib_eio/unix/resource.ml b/lib_eio/unix/resource.ml index 1839596f6..74d2eeacd 100644 --- a/lib_eio/unix/resource.ml +++ b/lib_eio/unix/resource.ml @@ -1,6 +1,48 @@ -type t = < fd : Fd.t > +type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t -type _ Eio.Generic.ty += FD : Fd.t Eio.Generic.ty +type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi +let fd (Eio.Resource.T (t, ops)) = Eio.Resource.get ops T t -let fd t = t#fd -let fd_opt t = Eio.Generic.probe t FD +let fd_opt (Eio.Resource.T (t, ops)) = + match Eio.Resource.get_opt ops T with + | Some f -> Some (f t) + | None -> None + +module type FLOW = sig + include Eio.Net.Pi.STREAM_SOCKET + include Eio.File.Pi.WRITE with type t := t + + val fd : t -> Fd.t +end + +let flow_handler (type t tag) (module X : FLOW with type t = t and type tag = tag) : (t, _) Eio.Resource.handler = + Eio.Resource.handler @@ + Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module X)) @ + Eio.Resource.bindings (Eio.File.Pi.rw (module X)) @ [ + H (T, X.fd); + ] + +module type DATAGRAM_SOCKET = sig + include Eio.Net.Pi.DATAGRAM_SOCKET + + val fd : t -> Fd.t +end + +let datagram_handler (type t tag) (module X : DATAGRAM_SOCKET with type t = t and type tag = tag) : (t, _) Eio.Resource.handler = + Eio.Resource.handler @@ + Eio.Resource.bindings (Eio.Net.Pi.datagram_socket (module X)) @ [ + H (T, X.fd); + ] + +module type LISTENING_SOCKET = sig + include Eio.Net.Pi.LISTENING_SOCKET + + val fd : t -> Fd.t +end + +let listening_socket_handler (type t tag) (module X : LISTENING_SOCKET with type t = t and type tag = tag) + : (t, _) Eio.Resource.handler = + Eio.Resource.handler @@ + Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module X)) @ [ + H (T, X.fd); + ] diff --git a/lib_eio/unix/types.ml b/lib_eio/unix/types.ml index bf9276290..4ed2cd602 100644 --- a/lib_eio/unix/types.ml +++ b/lib_eio/unix/types.ml @@ -1,2 +1,4 @@ -type source = < Eio.Flow.source; Resource.t; Eio.Flow.close > -type sink = < Eio.Flow.sink; Resource.t; Eio.Flow.close > +type source_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.source_ty] +type sink_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.sink_ty] +type 'a source = ([> source_ty] as 'a) Eio.Resource.t +type 'a sink = ([> sink_ty] as 'a) Eio.Resource.t diff --git a/lib_eio_linux/eio_linux.ml b/lib_eio_linux/eio_linux.ml index fcab8996c..b3e1ec2d2 100644 --- a/lib_eio_linux/eio_linux.ml +++ b/lib_eio_linux/eio_linux.ml @@ -29,11 +29,14 @@ module Lf_queue = Eio_utils.Lf_queue module Low_level = Low_level -type _ Eio.Generic.ty += Dir_fd : Low_level.dir_fd Eio.Generic.ty -let get_dir_fd_opt t = Eio.Generic.probe t Dir_fd +(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check + that the new location is within its sandbox. *) +type ('t, _, _) Eio.Resource.pi += Dir_fd : ('t, 't -> Low_level.dir_fd, [> `Dir_fd]) Eio.Resource.pi -type source = Eio_unix.source -type sink = Eio_unix.sink +let get_dir_fd_opt (Eio.Resource.T (t, ops)) = + match Eio.Resource.get_opt ops Dir_fd with + | Some f -> Some (f t) + | None -> None (* When copying between a source with an FD and a sink with an FD, we can share the chunk and avoid copying. *) @@ -83,13 +86,13 @@ let copy_with_rsb rsb dst = (* Copy by allocating a chunk from the pre-shared buffer and asking the source to write into it. This used when the other methods aren't available. *) -let fallback_copy src dst = +let fallback_copy (type src) (module Src : Eio.Flow.Pi.SOURCE with type t = src) src dst = let fallback () = (* No chunks available. Use regular memory instead. *) let buf = Cstruct.create 4096 in try while true do - let got = Eio.Flow.single_read src buf in + let got = Src.single_read src buf in Low_level.writev dst [Cstruct.sub buf 0 got] done with End_of_file -> () @@ -98,99 +101,127 @@ let fallback_copy src dst = let chunk_cs = Uring.Region.to_cstruct chunk in try while true do - let got = Eio.Flow.single_read src chunk_cs in + let got = Src.single_read src chunk_cs in Low_level.write dst chunk got done with End_of_file -> () -let datagram_socket sock = object - inherit Eio.Net.datagram_socket +module Datagram_socket = struct + type tag = [`Generic | `Unix] - method fd = sock + type t = Eio_unix.Fd.t - method close = Fd.close sock + let fd t = t - method send ?dst buf = + let close = Eio_unix.Fd.close + + let send t ?dst buf = let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in - let sent = Low_level.send_msg sock ?dst buf in + let sent = Low_level.send_msg t ?dst buf in assert (sent = Cstruct.lenv buf) - method recv buf = - let addr, recv = Low_level.recv_msg sock [buf] in + let recv t buf = + let addr, recv = Low_level.recv_msg t [buf] in Eio_unix.Net.sockaddr_of_unix_datagram (Uring.Sockaddr.get addr), recv + + let shutdown t cmd = + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL end -let flow fd = - let is_tty = Fd.use_exn "isatty" fd Unix.isatty in - object (_ : ) - method fd = fd - method close = Fd.close fd +let datagram_handler = Eio_unix.Resource.datagram_handler (module Datagram_socket) - method stat = Low_level.fstat fd +let datagram_socket fd = + Eio.Resource.T (fd, datagram_handler) - method probe : type a. a Eio.Generic.ty -> a option = function - | Eio_unix.Resource.FD -> Some fd - | _ -> None +module Flow = struct + type tag = [`Generic | `Unix] - method read_into buf = - if is_tty then ( - (* Work-around for https://github.com/axboe/liburing/issues/354 - (should be fixed in Linux 5.14) *) - Low_level.await_readable fd - ); - Low_level.readv fd [buf] - - method pread ~file_offset bufs = - Low_level.readv ~file_offset fd bufs - - method pwrite ~file_offset bufs = - Low_level.writev_single ~file_offset fd bufs - - method read_methods = [] - - method write bufs = Low_level.writev fd bufs - - method copy src = - match Eio_unix.Resource.fd_opt src with - | Some src -> fast_copy_try_splice src fd - | None -> - let rec aux = function - | Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb rsb fd - | _ :: xs -> aux xs - | [] -> fallback_copy src fd - in - aux (Eio.Flow.read_methods src) - - method shutdown cmd = - Low_level.shutdown fd @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL - end + type t = Eio_unix.Fd.t + + let fd t = t + + let close = Eio_unix.Fd.close -let source fd = (flow fd :> source) -let sink fd = (flow fd :> sink) + let is_tty t = Fd.use_exn "isatty" t Unix.isatty + + let stat = Low_level.fstat + + let single_read t buf = + if is_tty t then ( + (* Work-around for https://github.com/axboe/liburing/issues/354 + (should be fixed in Linux 5.14) *) + Low_level.await_readable t + ); + Low_level.readv t [buf] + + let pread t ~file_offset bufs = + Low_level.readv ~file_offset t bufs + + let pwrite t ~file_offset bufs = + Low_level.writev_single ~file_offset t bufs + + let read_methods = [] + + let write t bufs = Low_level.writev t bufs + + let copy t ~src = + match Eio_unix.Resource.fd_opt src with + | Some src -> fast_copy_try_splice src t + | None -> + let Eio.Resource.T (src, ops) = src in + let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in + let rec aux = function + | Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb (rsb src) t + | _ :: xs -> aux xs + | [] -> fallback_copy (module Src) src t + in + aux Src.read_methods + + let shutdown t cmd = + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL +end + +let flow_handler = Eio_unix.Resource.flow_handler (module Flow) + +let flow fd = + let r = Eio.Resource.T (fd, flow_handler) in + (r : [Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> + [< Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) -let listening_socket fd = object - inherit Eio.Net.listening_socket +let source fd = (flow fd :> _ Eio_unix.source) +let sink fd = (flow fd :> _ Eio_unix.sink) - method close = Fd.close fd +module Listening_socket = struct + type t = Fd.t - method accept ~sw = + type tag = [`Generic | `Unix] + + let fd t = t + + let close = Fd.close + + let accept t ~sw = Switch.check sw; - let client, client_addr = Low_level.accept ~sw fd in + let client, client_addr = Low_level.accept ~sw t in let client_addr = match client_addr with | Unix.ADDR_UNIX path -> `Unix path | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) in - let flow = (flow client :> Eio.Net.stream_socket) in + let flow = (flow client :> _ Eio.Net.stream_socket) in flow, client_addr - - method! probe : type a. a Eio.Generic.ty -> a option = function - | Eio_unix.Resource.FD -> Some fd - | _ -> None end +let listening_handler = Eio_unix.Resource.listening_socket_handler (module Listening_socket) + +let listening_socket fd = + Eio.Resource.T (fd, listening_handler) + let socket_domain_of = function | `Unix _ -> Unix.PF_UNIX | `UdpV4 -> Unix.PF_INET @@ -206,12 +237,13 @@ let connect ~sw connect_addr = let sock_unix = Unix.socket ~cloexec:true (socket_domain_of connect_addr) Unix.SOCK_STREAM 0 in let sock = Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in Low_level.connect sock addr; - (flow sock :> Eio.Net.stream_socket) + (flow sock :> _ Eio_unix.Net.stream_socket) -let net = object - inherit Eio_unix.Net.t +module Impl = struct + type t = unit + type tag = [`Unix | `Generic] - method listen ~reuse_addr ~reuse_port ~backlog ~sw listen_addr = + let listen () ~reuse_addr ~reuse_port ~backlog ~sw listen_addr = if reuse_addr then ( match listen_addr with | `Tcp _ -> () @@ -238,11 +270,11 @@ let net = object Unix.setsockopt sock_unix Unix.SO_REUSEPORT true; Unix.bind sock_unix addr; Unix.listen sock_unix backlog; - listening_socket sock + (listening_socket sock :> _ Eio.Net.listening_socket_ty r) - method connect = connect + let connect () ~sw addr = (connect ~sw addr :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) - method datagram_socket ~reuse_addr ~reuse_port ~sw saddr = + let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = if reuse_addr then ( match saddr with | `Udp _ | `UdpV4 | `UdpV6 -> () @@ -265,11 +297,16 @@ let net = object Unix.bind sock_unix addr | `UdpV4 | `UdpV6 -> () end; - (datagram_socket sock :> Eio.Net.datagram_socket) + (datagram_socket sock :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) - method getaddrinfo = Low_level.getaddrinfo + let getaddrinfo () = Low_level.getaddrinfo + let getnameinfo () = Eio_unix.Net.getnameinfo end +let net = + let handler = Eio.Net.Pi.network (module Impl) in + Eio.Resource.T ((), handler) + type stdenv = Eio_unix.Stdenv.base module Process = Low_level.Process @@ -377,22 +414,31 @@ let clock = object Eio.Time.Mono.sleep mono_clock d end -class dir ~label (fd : Low_level.dir_fd) = object - inherit Eio.Fs.dir +module rec Dir : sig + include Eio.Fs.Pi.DIR - method! probe : type a. a Eio.Generic.ty -> a option = function - | Dir_fd -> Some fd - | _ -> None + val v : label:string -> Low_level.dir_fd -> t - method open_in ~sw path = - let fd = Low_level.openat ~sw fd path + val close : t -> unit + + val fd : t -> Low_level.dir_fd +end = struct + type t = { + fd : Low_level.dir_fd; + label : string; + } + + let v ~label fd = { fd; label } + + let open_in t ~sw path = + let fd = Low_level.openat ~sw t.fd path ~access:`R ~flags:Uring.Open_flags.cloexec ~perm:0 in - (flow fd :> ) + (flow fd :> Eio.File.ro_ty r) - method open_out ~sw ~append ~create path = + let open_out t ~sw ~append ~create path = let perm, flags = match create with | `Never -> 0, Uring.Open_flags.empty @@ -401,56 +447,75 @@ class dir ~label (fd : Low_level.dir_fd) = object | `Exclusive perm -> perm, Uring.Open_flags.(creat + excl) in let flags = if append then Uring.Open_flags.(flags + append) else flags in - let fd = Low_level.openat ~sw fd path + let fd = Low_level.openat ~sw t.fd path ~access:`RW ~flags:Uring.Open_flags.(cloexec + flags) ~perm in - (flow fd :> ) + (flow fd :> Eio.File.rw_ty r) - method open_dir ~sw path = - let fd = Low_level.openat ~sw ~seekable:false fd (if path = "" then "." else path) + let open_dir t ~sw path = + let fd = Low_level.openat ~sw ~seekable:false t.fd (if path = "" then "." else path) ~access:`R ~flags:Uring.Open_flags.(cloexec + path + directory) ~perm:0 in let label = Filename.basename path in - (new dir ~label (Low_level.FD fd) :> ) + let d = v ~label (Low_level.FD fd) in + Eio.Resource.T (d, Dir_handler.v) - method mkdir ~perm path = Low_level.mkdir_beneath ~perm fd path + let mkdir t ~perm path = Low_level.mkdir_beneath ~perm t.fd path - method read_dir path = + let read_dir t path = Switch.run @@ fun sw -> - let fd = Low_level.open_dir ~sw fd (if path = "" then "." else path) in + let fd = Low_level.open_dir ~sw t.fd (if path = "" then "." else path) in Low_level.read_dir fd - method close = - match fd with + let close t = + match t.fd with | FD x -> Fd.close x | Cwd | Fs -> failwith "Can't close non-FD directory!" - method unlink path = Low_level.unlink ~rmdir:false fd path - method rmdir path = Low_level.unlink ~rmdir:true fd path + let unlink t path = Low_level.unlink ~rmdir:false t.fd path + let rmdir t path = Low_level.unlink ~rmdir:true t.fd path - method rename old_path t2 new_path = + let rename t old_path t2 new_path = match get_dir_fd_opt t2 with - | Some fd2 -> Low_level.rename fd old_path fd2 new_path + | Some fd2 -> Low_level.rename t.fd old_path fd2 new_path | None -> raise (Unix.Unix_error (Unix.EXDEV, "rename-dst", new_path)) - method pp f = Fmt.string f (String.escaped label) + let pp f t = Fmt.string f (String.escaped t.label) + + let fd t = t.fd end +and Dir_handler : sig + val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler +end = struct + let v = Eio.Resource.handler [ + H (Eio.Fs.Pi.Dir, (module Dir)); + H (Eio.Resource.Close, Dir.close); + H (Dir_fd, Dir.fd); + ] +end + +let dir ~label fd = Eio.Resource.T (Dir.v ~label fd, Dir_handler.v) -let secure_random = object - inherit Eio.Flow.source - method read_into buf = Low_level.getrandom buf; Cstruct.length buf +module Secure_random = struct + type t = unit + let single_read () buf = Low_level.getrandom buf; Cstruct.length buf + let read_methods = [] end +let secure_random = + let ops = Eio.Flow.Pi.source (module Secure_random) in + Eio.Resource.T ((), ops) + let stdenv ~run_event_loop = let stdin = source Eio_unix.Fd.stdin in let stdout = sink Eio_unix.Fd.stdout in let stderr = sink Eio_unix.Fd.stderr in - let fs = (new dir ~label:"fs" Fs, "") in - let cwd = (new dir ~label:"cwd" Cwd, "") in + let fs = (dir ~label:"fs" Fs, "") in + let cwd = (dir ~label:"cwd" Cwd, "") in object (_ : stdenv) method stdin = stdin method stdout = stdout @@ -460,8 +525,8 @@ let stdenv ~run_event_loop = method domain_mgr = domain_mgr ~run_event_loop method clock = clock method mono_clock = mono_clock - method fs = (fs :> Eio.Fs.dir Eio.Path.t) - method cwd = (cwd :> Eio.Fs.dir Eio.Path.t) + method fs = (fs :> Eio.Fs.dir_ty Eio.Path.t) + method cwd = (cwd :> Eio.Fs.dir_ty Eio.Path.t) method secure_random = secure_random method debug = Eio.Private.Debug.v method backend_id = "linux" @@ -476,7 +541,7 @@ let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a = | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k mono_clock) | Eio_unix.Net.Import_socket_stream (sw, close_unix, fd) -> Some (fun k -> let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in - continue k (flow fd :> Eio_unix.Net.stream_socket) + continue k (flow fd :> _ Eio_unix.Net.stream_socket) ) | Eio_unix.Net.Import_socket_datagram (sw, close_unix, fd) -> Some (fun k -> let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in @@ -487,7 +552,7 @@ let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a = let a, b = Unix.socketpair ~cloexec:true domain Unix.SOCK_STREAM protocol in let a = Fd.of_unix ~sw ~seekable:false ~close_unix:true a |> flow in let b = Fd.of_unix ~sw ~seekable:false ~close_unix:true b |> flow in - ((a :> Eio_unix.Net.stream_socket), (b :> Eio_unix.Net.stream_socket)) + ((a :> _ Eio_unix.Net.stream_socket), (b :> _ Eio_unix.Net.stream_socket)) with | r -> continue k r | exception Unix.Unix_error (code, name, arg) -> @@ -498,7 +563,7 @@ let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a = let a, b = Unix.socketpair ~cloexec:true domain Unix.SOCK_DGRAM protocol in let a = Fd.of_unix ~sw ~seekable:false ~close_unix:true a |> datagram_socket in let b = Fd.of_unix ~sw ~seekable:false ~close_unix:true b |> datagram_socket in - ((a :> Eio_unix.Net.datagram_socket), (b :> Eio_unix.Net.datagram_socket)) + ((a :> _ Eio_unix.Net.datagram_socket), (b :> _ Eio_unix.Net.datagram_socket)) with | r -> continue k r | exception Unix.Unix_error (code, name, arg) -> @@ -507,8 +572,8 @@ let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a = | Eio_unix.Private.Pipe sw -> Some (fun k -> match let r, w = Low_level.pipe ~sw in - let r = (flow r :> Eio_unix.source) in - let w = (flow w :> Eio_unix.sink) in + let r = (flow r :> _ Eio_unix.source) in + let w = (flow w :> _ Eio_unix.sink) in (r, w) with | r -> continue k r diff --git a/lib_eio_linux/eio_linux.mli b/lib_eio_linux/eio_linux.mli index f9cff07c0..4f352f432 100644 --- a/lib_eio_linux/eio_linux.mli +++ b/lib_eio_linux/eio_linux.mli @@ -25,15 +25,10 @@ open Eio.Std type fd := Eio_unix.Fd.t -(** {1 Eio API} *) - -type source = Eio_unix.source -type sink = Eio_unix.sink +(** {1 Main Loop} *) type stdenv = Eio_unix.Stdenv.base -(** {1 Main Loop} *) - val run : ?queue_depth:int -> ?n_blocks:int -> diff --git a/lib_eio_posix/domain_mgr.ml b/lib_eio_posix/domain_mgr.ml index ec1c71afd..3b8c86ee7 100644 --- a/lib_eio_posix/domain_mgr.ml +++ b/lib_eio_posix/domain_mgr.ml @@ -20,7 +20,7 @@ open Eio.Std module Fd = Eio_unix.Fd -let socketpair k ~sw ~domain ~ty ~protocol ~wrap = +let socketpair k ~sw ~domain ~ty ~protocol wrap_a wrap_b = let open Effect.Deep in match let unix_a, unix_b = Unix.socketpair ~cloexec:true domain ty protocol in @@ -28,7 +28,7 @@ let socketpair k ~sw ~domain ~ty ~protocol ~wrap = let b = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_b in Unix.set_nonblock unix_a; Unix.set_nonblock unix_b; - (wrap a, wrap b) + (wrap_a a, wrap_b b) with | r -> continue k r | exception Unix.Unix_error (code, name, arg) -> @@ -45,7 +45,7 @@ let run_event_loop fn x = | Eio_unix.Net.Import_socket_stream (sw, close_unix, unix_fd) -> Some (fun k -> let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in Unix.set_nonblock unix_fd; - continue k (Flow.of_fd fd :> Eio_unix.Net.stream_socket) + continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) ) | Eio_unix.Net.Import_socket_datagram (sw, close_unix, unix_fd) -> Some (fun k -> let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in @@ -53,18 +53,18 @@ let run_event_loop fn x = continue k (Net.datagram_socket fd) ) | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k -> - socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM - ~wrap:(fun fd -> (Flow.of_fd fd :> Eio_unix.Net.stream_socket)) + let wrap fd = (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) in + socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM wrap wrap ) | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k -> - socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM - ~wrap:(fun fd -> Net.datagram_socket fd) + let wrap fd = Net.datagram_socket fd in + socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM wrap wrap ) | Eio_unix.Private.Pipe sw -> Some (fun k -> match let r, w = Low_level.pipe ~sw in - let source = (Flow.of_fd r :> Eio_unix.source) in - let sink = (Flow.of_fd w :> Eio_unix.sink) in + let source = Flow.of_fd r in + let sink = Flow.of_fd w in (source, sink) with | r -> continue k r diff --git a/lib_eio_posix/eio_posix.ml b/lib_eio_posix/eio_posix.ml index ce0b4edea..e257accd2 100644 --- a/lib_eio_posix/eio_posix.ml +++ b/lib_eio_posix/eio_posix.ml @@ -22,9 +22,9 @@ let run main = (* SIGPIPE makes no sense in a modern application. *) Sys.(set_signal sigpipe Signal_ignore); Eio_unix.Process.install_sigchld_handler (); - let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> Eio_unix.source) in - let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> Eio_unix.sink) in - let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> Eio_unix.sink) in + let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in + let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in + let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in Domain_mgr.run_event_loop main @@ object (_ : stdenv) method stdin = stdin method stdout = stdout @@ -35,8 +35,8 @@ let run main = method net = Net.v method process_mgr = Process.v method domain_mgr = Domain_mgr.v - method cwd = ((Fs.cwd, "") :> Eio.Fs.dir Eio.Path.t) - method fs = ((Fs.fs, "") :> Eio.Fs.dir Eio.Path.t) + method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t) + method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t) method secure_random = Flow.secure_random method backend_id = "posix" end diff --git a/lib_eio_posix/flow.ml b/lib_eio_posix/flow.ml index dd1f3eb25..84564576b 100644 --- a/lib_eio_posix/flow.ml +++ b/lib_eio_posix/flow.ml @@ -1,98 +1,108 @@ +open Eio.Std + module Fd = Eio_unix.Fd -let fstat fd = - try - let ust = Low_level.fstat fd in - let st_kind : Eio.File.Stat.kind = - match ust.st_kind with - | Unix.S_REG -> `Regular_file - | Unix.S_DIR -> `Directory - | Unix.S_CHR -> `Character_special - | Unix.S_BLK -> `Block_device - | Unix.S_LNK -> `Symbolic_link - | Unix.S_FIFO -> `Fifo - | Unix.S_SOCK -> `Socket - in - Eio.File.Stat.{ - dev = ust.st_dev |> Int64.of_int; - ino = ust.st_ino |> Int64.of_int; - kind = st_kind; - perm = ust.st_perm; - nlink = ust.st_nlink |> Int64.of_int; - uid = ust.st_uid |> Int64.of_int; - gid = ust.st_gid |> Int64.of_int; - rdev = ust.st_rdev |> Int64.of_int; - size = ust.st_size |> Optint.Int63.of_int64; - atime = ust.st_atime; - mtime = ust.st_mtime; - ctime = ust.st_ctime; - } - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - -let write_bufs fd bufs = - try - let rec loop = function - | [] -> () - | bufs -> - let wrote = Low_level.writev fd (Array.of_list bufs) in - loop (Cstruct.shiftv bufs wrote) - in - loop bufs - with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - -let copy src dst = - let buf = Cstruct.create 4096 in - try - while true do - let got = Eio.Flow.single_read src buf in - write_bufs dst [Cstruct.sub buf 0 got] - done - with End_of_file -> () - -let read fd buf = - match Low_level.readv fd [| buf |] with - | 0 -> raise End_of_file - | got -> got - | exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg) - -let shutdown fd cmd = - try - Low_level.shutdown fd @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL - with - | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () - | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - -let of_fd fd = object (_ : ) - method fd = fd - - method read_methods = [] - method copy src = copy src fd - - method pread ~file_offset bufs = - let got = Low_level.preadv ~file_offset fd (Array.of_list bufs) in +module Impl = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t + + let stat t = + try + let ust = Low_level.fstat t in + let st_kind : Eio.File.Stat.kind = + match ust.st_kind with + | Unix.S_REG -> `Regular_file + | Unix.S_DIR -> `Directory + | Unix.S_CHR -> `Character_special + | Unix.S_BLK -> `Block_device + | Unix.S_LNK -> `Symbolic_link + | Unix.S_FIFO -> `Fifo + | Unix.S_SOCK -> `Socket + in + Eio.File.Stat.{ + dev = ust.st_dev |> Int64.of_int; + ino = ust.st_ino |> Int64.of_int; + kind = st_kind; + perm = ust.st_perm; + nlink = ust.st_nlink |> Int64.of_int; + uid = ust.st_uid |> Int64.of_int; + gid = ust.st_gid |> Int64.of_int; + rdev = ust.st_rdev |> Int64.of_int; + size = ust.st_size |> Optint.Int63.of_int64; + atime = ust.st_atime; + mtime = ust.st_mtime; + ctime = ust.st_ctime; + } + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + + let write t bufs = + try + let rec loop = function + | [] -> () + | bufs -> + let wrote = Low_level.writev t (Array.of_list bufs) in + loop (Cstruct.shiftv bufs wrote) + in + loop bufs + with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + + let copy dst ~src = + let buf = Cstruct.create 4096 in + try + while true do + let got = Eio.Flow.single_read src buf in + write dst [Cstruct.sub buf 0 got] + done + with End_of_file -> () + + let single_read t buf = + match Low_level.readv t [| buf |] with + | 0 -> raise End_of_file + | got -> got + | exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg) + + let shutdown t cmd = + try + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + + let read_methods = [] + + let pread t ~file_offset bufs = + let got = Low_level.preadv ~file_offset t (Array.of_list bufs) in if got = 0 then raise End_of_file else got - method pwrite ~file_offset bufs = Low_level.pwritev ~file_offset fd (Array.of_list bufs) + let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (Array.of_list bufs) - method stat = fstat fd - method read_into buf = read fd buf - method write bufs = write_bufs fd bufs - method shutdown cmd = shutdown fd cmd - method close = Fd.close fd + let fd t = t - method probe : type a. a Eio.Generic.ty -> a option = function - | Eio_unix.Resource.FD -> Some fd - | _ -> None + let close = Eio_unix.Fd.close end -let secure_random = object - inherit Eio.Flow.source +let handler = Eio_unix.Resource.flow_handler (module Impl) + +let of_fd fd = + let r = Eio.Resource.T (fd, handler) in + (r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> + [< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) - method read_into buf = +module Secure_random = struct + type t = unit + + let single_read () buf = Low_level.getrandom buf; Cstruct.length buf + + let read_methods = [] end + +let secure_random = + let ops = Eio.Flow.Pi.source (module Secure_random) in + Eio.Resource.T ((), ops) diff --git a/lib_eio_posix/fs.ml b/lib_eio_posix/fs.ml index 97a97b338..633ad3729 100644 --- a/lib_eio_posix/fs.ml +++ b/lib_eio_posix/fs.ml @@ -26,43 +26,77 @@ open Eio.Std module Fd = Eio_unix.Fd -class virtual posix_dir = object - inherit Eio.Fs.dir +module rec Dir : sig + include Eio.Fs.Pi.DIR - val virtual opt_nofollow : Low_level.Open_flags.t - (** Extra flags for open operations. Sandboxes will add [O_NOFOLLOW] here. *) + val v : label:string -> sandbox:bool -> string -> t - method virtual private resolve : string -> string - (** [resolve path] returns the real path that should be used to access [path]. + val resolve : t -> string -> string + (** [resolve t path] returns the real path that should be used to access [path]. For sandboxes, this is [realpath path] (and it checks that it is within the sandbox). - For unrestricted access, this is the identity function. *) + For unrestricted access, this returns [path] unchanged. + @raise Eio.Fs.Permission_denied if sandboxed and [path] is outside of [dir_path]. *) - method virtual with_parent_dir : 'a. (string -> (Fd.t option -> string -> 'a) -> 'a) - (** [with_parent_dir path fn] runs [fn dir_fd rel_path], + val with_parent_dir : t -> string -> (Fd.t option -> string -> 'a) -> 'a + (** [with_parent_dir t path fn] runs [fn dir_fd rel_path], where [rel_path] accessed relative to [dir_fd] gives access to [path]. For unrestricted access, this just runs [fn None path]. For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *) -end - -(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check - that the new location is within its sandbox. *) -type _ Eio.Generic.ty += Posix_dir : posix_dir Eio.Generic.ty -let as_posix_dir x = Eio.Generic.probe x Posix_dir - -class virtual dir ~label = object (self) - inherit posix_dir - - val mutable closed = false - - method! probe : type a. a Eio.Generic.ty -> a option = function - | Posix_dir -> Some (self :> posix_dir) - | _ -> None - - method open_in ~sw path = - let fd = Err.run (Low_level.openat ~mode:0 ~sw (self#resolve path)) Low_level.Open_flags.(opt_nofollow + rdonly) in - (Flow.of_fd fd :> ) - - method open_out ~sw ~append ~create path = +end = struct + type t = { + dir_path : string; + sandbox : bool; + label : string; + mutable closed : bool; + } + + let resolve t path = + if t.sandbox then ( + if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; + if Filename.is_relative path then ( + let dir_path = Err.run Low_level.realpath t.dir_path in + let full = Err.run Low_level.realpath (Filename.concat dir_path path) in + let prefix_len = String.length dir_path + 1 in + if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then + full + else if full = dir_path then + full + else + raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) + ) else ( + raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path) + ) + ) else path + + let with_parent_dir t path fn = + if t.sandbox then ( + if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; + let dir, leaf = Filename.dirname path, Filename.basename path in + if leaf = ".." then ( + (* We could be smarter here and normalise the path first, but '..' + doesn't make sense for any of the current uses of [with_parent_dir] + anyway. *) + raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf))) + ) else ( + let dir = resolve t dir in + Switch.run @@ fun sw -> + let dirfd = Low_level.openat ~sw ~mode:0 dir Low_level.Open_flags.(directory + rdonly + nofollow) in + fn (Some dirfd) leaf + ) + ) else fn None path + + let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false } + + (* Sandboxes use [O_NOFOLLOW] when opening files ([resolve] already removed any symlinks). + This avoids a race where symlink might be added after [realpath] returns. *) + let opt_nofollow t = + if t.sandbox then Low_level.Open_flags.nofollow else Low_level.Open_flags.empty + + let open_in t ~sw path = + let fd = Err.run (Low_level.openat ~mode:0 ~sw (resolve t path)) Low_level.Open_flags.(opt_nofollow t + rdonly) in + (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) + + let rec open_out t ~sw ~append ~create path = let mode, flags = match create with | `Never -> 0, Low_level.Open_flags.empty @@ -71,12 +105,12 @@ class virtual dir ~label = object (self) | `Exclusive perm -> perm, Low_level.Open_flags.(creat + excl) in let flags = if append then Low_level.Open_flags.(flags + append) else flags in - let flags = Low_level.Open_flags.(flags + rdwr + opt_nofollow) in + let flags = Low_level.Open_flags.(flags + rdwr + opt_nofollow t) in match - self#with_parent_dir path @@ fun dirfd path -> + with_parent_dir t path @@ fun dirfd path -> Low_level.openat ?dirfd ~sw ~mode path flags with - | fd -> (Flow.of_fd fd :> ) + | fd -> (Flow.of_fd fd :> Eio.File.rw_ty r) | exception Unix.Unix_error (ELOOP, _, _) -> (* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that). A leaf symlink might be OK, but we need to check it's still in the sandbox. @@ -87,96 +121,67 @@ class virtual dir ~label = object (self) Filename.concat (Filename.dirname path) target else target in - self#open_out ~sw ~append ~create full_target + open_out t ~sw ~append ~create full_target | exception Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - method mkdir ~perm path = - self#with_parent_dir path @@ fun dirfd path -> + let mkdir t ~perm path = + with_parent_dir t path @@ fun dirfd path -> Err.run (Low_level.mkdir ?dirfd ~mode:perm) path - method unlink path = - self#with_parent_dir path @@ fun dirfd path -> + let unlink t path = + with_parent_dir t path @@ fun dirfd path -> Err.run (Low_level.unlink ?dirfd ~dir:false) path - method rmdir path = - self#with_parent_dir path @@ fun dirfd path -> + let rmdir t path = + with_parent_dir t path @@ fun dirfd path -> Err.run (Low_level.unlink ?dirfd ~dir:true) path - method read_dir path = + let read_dir t path = (* todo: need fdopendir here to avoid races *) - let path = self#resolve path in + let path = resolve t path in Err.run Low_level.readdir path |> Array.to_list - method rename old_path new_dir new_path = - match as_posix_dir new_dir with + let rename t old_path new_dir new_path = + match Handler.as_posix_dir new_dir with | None -> invalid_arg "Target is not an eio_posix directory!" | Some new_dir -> - self#with_parent_dir old_path @@ fun old_dir old_path -> - new_dir#with_parent_dir new_path @@ fun new_dir new_path -> + with_parent_dir t old_path @@ fun old_dir old_path -> + with_parent_dir new_dir new_path @@ fun new_dir new_path -> Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path - method open_dir ~sw path = + let close t = t.closed <- true + + let open_dir t ~sw path = Switch.check sw; let label = Filename.basename path in - let d = new sandbox ~label (self#resolve path) in - Switch.on_release sw (fun () -> d#close); - (d :> Eio.Fs.dir_with_close) - - method close = closed <- true + let d = v ~label (resolve t path) ~sandbox:true in + Switch.on_release sw (fun () -> close d); + Eio.Resource.T (d, Handler.v) - method pp f = Fmt.string f (String.escaped label) + let pp f t = Fmt.string f (String.escaped t.label) end - -and sandbox ~label dir_path = object (self) - inherit dir ~label - - val opt_nofollow = Low_level.Open_flags.nofollow - - (* Resolve a relative path to an absolute one, with no symlinks. - @raise Eio.Fs.Permission_denied if it's outside of [dir_path]. *) - method private resolve path = - if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path; - if Filename.is_relative path then ( - let dir_path = Err.run Low_level.realpath dir_path in - let full = Err.run Low_level.realpath (Filename.concat dir_path path) in - let prefix_len = String.length dir_path + 1 in - if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then - full - else if full = dir_path then - full - else - raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) - ) else ( - raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path) - ) - - method with_parent_dir path fn = - if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path; - let dir, leaf = Filename.dirname path, Filename.basename path in - if leaf = ".." then ( - (* We could be smarter here and normalise the path first, but '..' - doesn't make sense for any of the current uses of [with_parent_dir] - anyway. *) - raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf))) - ) else ( - let dir = self#resolve dir in - Switch.run @@ fun sw -> - let dirfd = Low_level.openat ~sw ~mode:0 dir Low_level.Open_flags.(directory + rdonly + nofollow) in - fn (Some dirfd) leaf - ) +and Handler : sig + val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler + + val as_posix_dir : [> `Dir] r -> Dir.t option +end = struct + (* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check + that the new location is within its sandbox. *) + type (_, _, _) Eio.Resource.pi += Posix_dir : ('t, 't -> Dir.t, [> `Posix_dir]) Eio.Resource.pi + + let as_posix_dir (Eio.Resource.T (t, ops)) = + match Eio.Resource.get_opt ops Posix_dir with + | None -> None + | Some fn -> Some (fn t) + + let v = Eio.Resource.handler [ + H (Eio.Fs.Pi.Dir, (module Dir)); + H (Posix_dir, Fun.id); + ] end (* Full access to the filesystem. *) -let fs = object - inherit dir ~label:"fs" - - val opt_nofollow = Low_level.Open_flags.empty - - (* No checks *) - method private resolve path = path - method private with_parent_dir path fn = fn None path -end - -let cwd = new sandbox ~label:"cwd" "." +let fs = Eio.Resource.T (Dir.v ~label:"fs" ~sandbox:false ".", Handler.v) +let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~sandbox:true ".", Handler.v) diff --git a/lib_eio_posix/net.ml b/lib_eio_posix/net.ml index 747fc772a..929947aa6 100644 --- a/lib_eio_posix/net.ml +++ b/lib_eio_posix/net.ml @@ -12,44 +12,71 @@ let socket_domain_of = function ~v4:(fun _ -> Unix.PF_INET) ~v6:(fun _ -> Unix.PF_INET6) -let listening_socket ~hook fd = object - inherit Eio.Net.listening_socket +module Listening_socket = struct + type t = { + hook : Switch.hook; + fd : Fd.t; + } - method close = - Switch.remove_hook hook; - Fd.close fd + type tag = [`Generic | `Unix] - method accept ~sw = - let client, client_addr = Err.run (Low_level.accept ~sw) fd in + let make ~hook fd = { hook; fd } + + let fd t = t.fd + + let close t = + Switch.remove_hook t.hook; + Fd.close t.fd + + let accept t ~sw = + let client, client_addr = Err.run (Low_level.accept ~sw) t.fd in let client_addr = match client_addr with | Unix.ADDR_UNIX path -> `Unix path | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) in - let flow = (Flow.of_fd client :> Eio.Net.stream_socket) in + let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in flow, client_addr - - method! probe : type a. a Eio.Generic.ty -> a option = function - | Eio_unix.Resource.FD -> Some fd - | _ -> None end -let datagram_socket sock = object - inherit Eio_unix.Net.datagram_socket +let listening_handler = Eio_unix.Resource.listening_socket_handler (module Listening_socket) + +let listening_socket ~hook fd = + Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler) + +module Datagram_socket = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t - method close = Fd.close sock + let close = Fd.close - method fd = sock + let fd t = t - method send ?dst buf = + let send t ?dst buf = let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in - let sent = Err.run (Low_level.send_msg sock ?dst) (Array.of_list buf) in + let sent = Err.run (Low_level.send_msg t ?dst) (Array.of_list buf) in assert (sent = Cstruct.lenv buf) - method recv buf = - let addr, recv = Err.run (Low_level.recv_msg sock) [| buf |] in + let recv t buf = + let addr, recv = Err.run (Low_level.recv_msg t) [| buf |] in Eio_unix.Net.sockaddr_of_unix_datagram addr, recv + + let shutdown t cmd = + try + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) end +let datagram_handler = Eio_unix.Resource.datagram_handler (module Datagram_socket) + +let datagram_socket fd = + Eio.Resource.T (fd, datagram_handler) + (* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *) let getaddrinfo ~service node = let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } = @@ -105,7 +132,7 @@ let listen ~reuse_addr ~reuse_port ~backlog ~sw (listen_addr : Eio.Net.Sockaddr. Unix.bind fd addr; Unix.listen fd backlog; ); - listening_socket ~hook sock + (listening_socket ~hook sock :> _ Eio.Net.listening_socket_ty r) let connect ~sw connect_addr = let socket_type, addr = @@ -118,7 +145,7 @@ let connect ~sw connect_addr = let sock = Low_level.socket ~sw (socket_domain_of connect_addr) socket_type 0 in try Low_level.connect sock addr; - (Flow.of_fd sock :> Eio.Net.stream_socket) + (Flow.of_fd sock :> _ Eio_unix.Net.stream_socket) with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr = @@ -135,13 +162,26 @@ let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr = ) | `UdpV4 | `UdpV6 -> () end; - (datagram_socket sock :> Eio.Net.datagram_socket) + datagram_socket sock -let v = object - inherit Eio_unix.Net.t +module Impl = struct + type t = unit + type tag = [`Generic | `Unix] - method listen = listen - method connect = connect - method datagram_socket = create_datagram_socket - method getaddrinfo = getaddrinfo + let listen () = listen + + let connect () ~sw addr = + let socket = connect ~sw addr in + (socket :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) + + let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = + let socket = create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr in + (socket :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) + + let getaddrinfo () = getaddrinfo + let getnameinfo () = Eio_unix.Net.getnameinfo end + +let v : Impl.tag Eio.Net.ty r = + let handler = Eio.Net.Pi.network (module Impl) in + Eio.Resource.T ((), handler) diff --git a/lib_eio_posix/process.ml b/lib_eio_posix/process.ml index 94150731c..596894de8 100644 --- a/lib_eio_posix/process.ml +++ b/lib_eio_posix/process.ml @@ -24,11 +24,11 @@ let v = object ] in let with_actions cwd fn = match cwd with | None -> fn actions - | Some ((dir, path) : Eio.Fs.dir Eio.Path.t) -> - match Eio.Generic.probe dir Fs.Posix_dir with + | Some ((dir, path) : Eio.Fs.dir_ty Eio.Path.t) -> + match Fs.Handler.as_posix_dir dir with | None -> Fmt.invalid_arg "cwd is not an OS directory!" | Some posix -> - posix#with_parent_dir path @@ fun dirfd s -> + Fs.Dir.with_parent_dir posix path @@ fun dirfd s -> Switch.run @@ fun launch_sw -> let cwd = Low_level.openat ?dirfd ~sw:launch_sw ~mode:0 s Low_level.Open_flags.(rdonly + directory) in fn (Process.Fork_action.fchdir cwd :: actions) diff --git a/lib_eio_windows/domain_mgr.ml b/lib_eio_windows/domain_mgr.ml index dd7794a29..a68175c60 100755 --- a/lib_eio_windows/domain_mgr.ml +++ b/lib_eio_windows/domain_mgr.ml @@ -20,7 +20,7 @@ open Eio.Std module Fd = Eio_unix.Fd -let socketpair k ~sw ~domain ~ty ~protocol ~wrap = +let socketpair k ~sw ~domain ~ty ~protocol wrap_a wrap_b = let open Effect.Deep in match let unix_a, unix_b = Unix.socketpair ~cloexec:true domain ty protocol in @@ -28,7 +28,7 @@ let socketpair k ~sw ~domain ~ty ~protocol ~wrap = let b = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_b in Unix.set_nonblock unix_a; Unix.set_nonblock unix_b; - (wrap a, wrap b) + (wrap_a a, wrap_b b) with | r -> continue k r | exception Unix.Unix_error (code, name, arg) -> @@ -46,7 +46,7 @@ let run_event_loop fn x = let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in (* TODO: On Windows, if the FD from Unix.pipe () is passed this will fail *) (try Unix.set_nonblock unix_fd with Unix.Unix_error (Unix.ENOTSOCK, _, _) -> ()); - continue k (Flow.of_fd fd :> Eio_unix.Net.stream_socket) + continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) ) | Eio_unix.Net.Import_socket_datagram (sw, close_unix, unix_fd) -> Some (fun k -> let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in @@ -54,18 +54,18 @@ let run_event_loop fn x = continue k (Net.datagram_socket fd) ) | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k -> - socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM - ~wrap:(fun fd -> (Flow.of_fd fd :> Eio_unix.Net.stream_socket)) + let wrap fd = (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) in + socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM wrap wrap ) | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k -> - socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM - ~wrap:(fun fd -> Net.datagram_socket fd) + let wrap fd = Net.datagram_socket fd in + socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM wrap wrap ) | Eio_unix.Private.Pipe sw -> Some (fun k -> match let r, w = Low_level.pipe ~sw in - let source = (Flow.of_fd r :> Eio_unix.source) in - let sink = (Flow.of_fd w :> Eio_unix.sink) in + let source = Flow.of_fd r in + let sink = Flow.of_fd w in (source, sink) with | r -> continue k r diff --git a/lib_eio_windows/eio_windows.ml b/lib_eio_windows/eio_windows.ml index ecee2a528..254668efd 100755 --- a/lib_eio_windows/eio_windows.ml +++ b/lib_eio_windows/eio_windows.ml @@ -19,9 +19,9 @@ module Low_level = Low_level type stdenv = Eio_unix.Stdenv.base let run main = - let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> Eio_unix.source) in - let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> Eio_unix.sink) in - let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> Eio_unix.sink) in + let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in + let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in + let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in Domain_mgr.run_event_loop main @@ object (_ : stdenv) method stdin = stdin method stdout = stdout @@ -31,8 +31,8 @@ let run main = method mono_clock = Time.mono_clock method net = Net.v method domain_mgr = Domain_mgr.v - method cwd = ((Fs.cwd, "") :> Eio.Fs.dir Eio.Path.t) - method fs = ((Fs.fs, "") :> Eio.Fs.dir Eio.Path.t) + method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t) + method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t) method process_mgr = failwith "process operations not supported on Windows yet" method secure_random = Flow.secure_random method backend_id = "windows" diff --git a/lib_eio_windows/flow.ml b/lib_eio_windows/flow.ml index dccf0aafa..61414bce6 100755 --- a/lib_eio_windows/flow.ml +++ b/lib_eio_windows/flow.ml @@ -1,92 +1,101 @@ +open Eio.Std + module Fd = Eio_unix.Fd -let fstat fd = - try - let ust = Low_level.fstat fd in - let st_kind : Eio.File.Stat.kind = - match ust.st_kind with - | Unix.S_REG -> `Regular_file - | Unix.S_DIR -> `Directory - | Unix.S_CHR -> `Character_special - | Unix.S_BLK -> `Block_device - | Unix.S_LNK -> `Symbolic_link - | Unix.S_FIFO -> `Fifo - | Unix.S_SOCK -> `Socket - in - Eio.File.Stat.{ - dev = ust.st_dev |> Int64.of_int; - ino = ust.st_ino |> Int64.of_int; - kind = st_kind; - perm = ust.st_perm; - nlink = ust.st_nlink |> Int64.of_int; - uid = ust.st_uid |> Int64.of_int; - gid = ust.st_gid |> Int64.of_int; - rdev = ust.st_rdev |> Int64.of_int; - size = ust.st_size |> Optint.Int63.of_int64; - atime = ust.st_atime; - mtime = ust.st_mtime; - ctime = ust.st_ctime; - } - with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg - -let write_bufs fd bufs = - try - Low_level.writev fd bufs - with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - -let copy src dst = - let buf = Cstruct.create 4096 in - try - while true do - let got = Eio.Flow.single_read src buf in - write_bufs dst [Cstruct.sub buf 0 got] - done - with End_of_file -> () - -let read fd buf = - match Low_level.read_cstruct fd buf with - | 0 -> raise End_of_file - | got -> got - | exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg) - -let shutdown fd cmd = - try - Low_level.shutdown fd @@ match cmd with - | `Receive -> Unix.SHUTDOWN_RECEIVE - | `Send -> Unix.SHUTDOWN_SEND - | `All -> Unix.SHUTDOWN_ALL - with - | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () - | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - -let of_fd fd = object (_ : ) - method fd = fd - - method read_methods = [] - method copy src = copy src fd - - method pread ~file_offset bufs = - let got = Low_level.preadv ~file_offset fd (Array.of_list bufs) in +module Impl = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t + + let stat t = + try + let ust = Low_level.fstat t in + let st_kind : Eio.File.Stat.kind = + match ust.st_kind with + | Unix.S_REG -> `Regular_file + | Unix.S_DIR -> `Directory + | Unix.S_CHR -> `Character_special + | Unix.S_BLK -> `Block_device + | Unix.S_LNK -> `Symbolic_link + | Unix.S_FIFO -> `Fifo + | Unix.S_SOCK -> `Socket + in + Eio.File.Stat.{ + dev = ust.st_dev |> Int64.of_int; + ino = ust.st_ino |> Int64.of_int; + kind = st_kind; + perm = ust.st_perm; + nlink = ust.st_nlink |> Int64.of_int; + uid = ust.st_uid |> Int64.of_int; + gid = ust.st_gid |> Int64.of_int; + rdev = ust.st_rdev |> Int64.of_int; + size = ust.st_size |> Optint.Int63.of_int64; + atime = ust.st_atime; + mtime = ust.st_mtime; + ctime = ust.st_ctime; + } + with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg + + let write t bufs = + try Low_level.writev t bufs + with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + + let copy dst ~src = + let buf = Cstruct.create 4096 in + try + while true do + let got = Eio.Flow.single_read src buf in + write dst [Cstruct.sub buf 0 got] + done + with End_of_file -> () + + let single_read t buf = + match Low_level.read_cstruct t buf with + | 0 -> raise End_of_file + | got -> got + | exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg) + + let shutdown t cmd = + try + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) + + let read_methods = [] + + let pread t ~file_offset bufs = + let got = Low_level.preadv ~file_offset t (Array.of_list bufs) in if got = 0 then raise End_of_file else got - method pwrite ~file_offset bufs = Low_level.pwritev ~file_offset fd (Array.of_list bufs) + let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (Array.of_list bufs) - method stat = fstat fd - method read_into buf = read fd buf - method write bufs = write_bufs fd bufs - method shutdown cmd = shutdown fd cmd - method close = Fd.close fd + let fd t = t - method probe : type a. a Eio.Generic.ty -> a option = function - | Eio_unix.Resource.FD -> Some fd - | _ -> None + let close = Eio_unix.Fd.close end -let secure_random = object - inherit Eio.Flow.source +let handler = Eio_unix.Resource.flow_handler (module Impl) + +let of_fd fd = + let r = Eio.Resource.T (fd, handler) in + (r : [Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :> + [< Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r) - method read_into buf = +module Secure_random = struct + type t = unit + + let single_read () buf = Low_level.getrandom buf; Cstruct.length buf + + let read_methods = [] end + +let secure_random = + let ops = Eio.Flow.Pi.source (module Secure_random) in + Eio.Resource.T ((), ops) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 475c01f2c..4336788c1 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -26,44 +26,80 @@ open Eio.Std module Fd = Eio_unix.Fd -class virtual posix_dir = object - inherit Eio.Fs.dir +module rec Dir : sig + include Eio.Fs.Pi.DIR - val virtual opt_nofollow : bool - (** Emulate [O_NOFOLLOW] here. *) + val v : label:string -> sandbox:bool -> string -> t - method virtual private resolve : string -> string - (** [resolve path] returns the real path that should be used to access [path]. + val resolve : t -> string -> string + (** [resolve t path] returns the real path that should be used to access [path]. For sandboxes, this is [realpath path] (and it checks that it is within the sandbox). - For unrestricted access, this is the identity function. *) + For unrestricted access, this returns [path] unchanged. + @raise Eio.Fs.Permission_denied if sandboxed and [path] is outside of [dir_path]. *) - method virtual with_parent_dir : 'a. (string -> (Fd.t option -> string -> 'a) -> 'a) - (** [with_parent_dir path fn] runs [fn dir_fd rel_path], + val with_parent_dir : t -> string -> (Fd.t option -> string -> 'a) -> 'a + (** [with_parent_dir t path fn] runs [fn dir_fd rel_path], where [rel_path] accessed relative to [dir_fd] gives access to [path]. For unrestricted access, this just runs [fn None path]. For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *) -end - -(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check - that the new location is within its sandbox. *) -type _ Eio.Generic.ty += Posix_dir : posix_dir Eio.Generic.ty -let as_posix_dir x = Eio.Generic.probe x Posix_dir - -class virtual dir ~label = object (self) - inherit posix_dir - - val mutable closed = false - - method! probe : type a. a Eio.Generic.ty -> a option = function - | Posix_dir -> Some (self :> posix_dir) - | _ -> None - - method open_in ~sw path = +end = struct + type t = { + dir_path : string; + sandbox : bool; + label : string; + mutable closed : bool; + } + + let resolve t path = + if t.sandbox then ( + if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; + if Filename.is_relative path then ( + let dir_path = Err.run Low_level.realpath t.dir_path in + let full = Err.run Low_level.realpath (Filename.concat dir_path path) in + let prefix_len = String.length dir_path + 1 in + (* \\??\\ Is necessary with NtCreateFile. *) + if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then begin + "\\??\\" ^ full + end else if full = dir_path then + "\\??\\" ^ full + else + raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) + ) else ( + raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path) + ) + ) else path + + let with_parent_dir t path fn = + if t.sandbox then ( + if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; + let dir, leaf = Filename.dirname path, Filename.basename path in + if leaf = ".." then ( + (* We could be smarter here and normalise the path first, but '..' + doesn't make sense for any of the current uses of [with_parent_dir] + anyway. *) + raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf))) + ) else ( + let dir = resolve t dir in + Switch.run @@ fun sw -> + let open Low_level in + let dirfd = Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(directory) in + fn (Some dirfd) leaf + ) + ) else fn None path + + let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false } + + (* Sandboxes use [O_NOFOLLOW] when opening files ([resolve] already removed any symlinks). + This avoids a race where symlink might be added after [realpath] returns. + TODO: Emulate [O_NOFOLLOW] here. *) + let opt_nofollow t = t.sandbox + + let open_in t ~sw path = let open Low_level in - let fd = Err.run (Low_level.openat ~sw ~nofollow:opt_nofollow (self#resolve path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in - (Flow.of_fd fd :> ) + let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in + (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) - method open_out ~sw ~append ~create path = + let rec open_out t ~sw ~append ~create path = let open Low_level in let _mode, disp = match create with @@ -72,12 +108,15 @@ class virtual dir ~label = object (self) | `Or_truncate perm -> perm, Low_level.Flags.Disposition.overwrite_if | `Exclusive perm -> perm, Low_level.Flags.Disposition.create in - let flags = if append then Low_level.Flags.Open.(synchronise + append) else Low_level.Flags.Open.(generic_write + synchronise) in + let flags = + if append then Low_level.Flags.Open.(synchronise + append) + else Low_level.Flags.Open.(generic_write + synchronise) + in match - self#with_parent_dir path @@ fun dirfd path -> - Low_level.openat ?dirfd ~nofollow:opt_nofollow ~sw path flags disp Flags.Create.(non_directory) + with_parent_dir t path @@ fun dirfd path -> + Low_level.openat ?dirfd ~nofollow:(opt_nofollow t) ~sw path flags disp Flags.Create.(non_directory) with - | fd -> (Flow.of_fd fd :> ) + | fd -> (Flow.of_fd fd :> Eio.File.rw_ty r) (* This is the result of raising [caml_unix_error(ELOOP,...)] *) | exception Unix.Unix_error (EUNKNOWNERR 114, _, _) -> print_endline "UNKNOWN"; @@ -90,98 +129,67 @@ class virtual dir ~label = object (self) Filename.concat (Filename.dirname path) target else target in - self#open_out ~sw ~append ~create full_target + open_out t ~sw ~append ~create full_target | exception Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) - method mkdir ~perm path = - self#with_parent_dir path @@ fun dirfd path -> + let mkdir t ~perm path = + with_parent_dir t path @@ fun dirfd path -> Err.run (Low_level.mkdir ?dirfd ~mode:perm) path - method unlink path = - self#with_parent_dir path @@ fun dirfd path -> + let unlink t path = + with_parent_dir t path @@ fun dirfd path -> Err.run (Low_level.unlink ?dirfd ~dir:false) path - method rmdir path = - self#with_parent_dir path @@ fun dirfd path -> + let rmdir t path = + with_parent_dir t path @@ fun dirfd path -> Err.run (Low_level.unlink ?dirfd ~dir:true) path - method read_dir path = + let read_dir t path = (* todo: need fdopendir here to avoid races *) - let path = self#resolve path in + let path = resolve t path in Err.run Low_level.readdir path |> Array.to_list - method rename old_path new_dir new_path = - match as_posix_dir new_dir with + let rename t old_path new_dir new_path = + match Handler.as_posix_dir new_dir with | None -> invalid_arg "Target is not an eio_posix directory!" | Some new_dir -> - self#with_parent_dir old_path @@ fun old_dir old_path -> - new_dir#with_parent_dir new_path @@ fun new_dir new_path -> + with_parent_dir t old_path @@ fun old_dir old_path -> + with_parent_dir new_dir new_path @@ fun new_dir new_path -> Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path - method open_dir ~sw path = + let close t = t.closed <- true + + let open_dir t ~sw path = Switch.check sw; let label = Filename.basename path in - let d = new sandbox ~label (self#resolve path) in - Switch.on_release sw (fun () -> d#close); - (d :> Eio.Fs.dir_with_close) - - method close = closed <- true + let d = v ~label (resolve t path) ~sandbox:true in + Switch.on_release sw (fun () -> close d); + Eio.Resource.T (d, Handler.v) - method pp f = Fmt.string f (String.escaped label) + let pp f t = Fmt.string f (String.escaped t.label) end - -and sandbox ~label dir_path = object (self) - inherit dir ~label - - val opt_nofollow = true - - (* Resolve a relative path to an absolute one, with no symlinks. - @raise Eio.Fs.Permission_denied if it's outside of [dir_path]. *) - method private resolve path = - if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path; - if Filename.is_relative path then ( - let dir_path = Err.run Low_level.realpath dir_path in - let full = Err.run Low_level.realpath (Filename.concat dir_path path) in - let prefix_len = String.length dir_path + 1 in - (* \\??\\ Is necessary with NtCreateFile. *) - if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then begin - "\\??\\" ^ full - end else if full = dir_path then - "\\??\\" ^ full - else - raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) - ) else ( - raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path) - ) - - method with_parent_dir path fn = - if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path; - let dir, leaf = Filename.dirname path, Filename.basename path in - if leaf = ".." then ( - (* We could be smarter here and normalise the path first, but '..' - doesn't make sense for any of the current uses of [with_parent_dir] - anyway. *) - raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf))) - ) else ( - let dir = self#resolve dir in - Switch.run @@ fun sw -> - let open Low_level in - let dirfd = Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(directory) in - fn (Some dirfd) leaf - ) +and Handler : sig + val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler + + val as_posix_dir : [> `Dir] r -> Dir.t option +end = struct + (* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check + that the new location is within its sandbox. *) + type (_, _, _) Eio.Resource.pi += Posix_dir : ('t, 't -> Dir.t, [> `Posix_dir]) Eio.Resource.pi + + let as_posix_dir (Eio.Resource.T (t, ops)) = + match Eio.Resource.get_opt ops Posix_dir with + | None -> None + | Some fn -> Some (fn t) + + let v = Eio.Resource.handler [ + H (Eio.Fs.Pi.Dir, (module Dir)); + H (Posix_dir, Fun.id); + ] end (* Full access to the filesystem. *) -let fs = object - inherit dir ~label:"fs" - - val opt_nofollow = false - - (* No checks *) - method private resolve path = path - method private with_parent_dir path fn = fn None path -end - -let cwd = new sandbox ~label:"cwd" "." +let fs = Eio.Resource.T (Dir.v ~label:"fs" ~sandbox:false ".", Handler.v) +let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~sandbox:true ".", Handler.v) diff --git a/lib_eio_windows/net.ml b/lib_eio_windows/net.ml index 659eacdac..df90a82ee 100755 --- a/lib_eio_windows/net.ml +++ b/lib_eio_windows/net.ml @@ -12,47 +12,73 @@ let socket_domain_of = function ~v4:(fun _ -> Unix.PF_INET) ~v6:(fun _ -> Unix.PF_INET6) -let listening_socket ~hook fd = object - inherit Eio.Net.listening_socket +module Listening_socket = struct + type t = { + hook : Switch.hook; + fd : Fd.t; + } - method close = - Switch.remove_hook hook; - Fd.close fd + type tag = [`Generic | `Unix] - method accept ~sw = - let client, client_addr = Err.run (Low_level.accept ~sw) fd in + let make ~hook fd = { hook; fd } + + let fd t = t.fd + + let close t = + Switch.remove_hook t.hook; + Fd.close t.fd + + let accept t ~sw = + let client, client_addr = Err.run (Low_level.accept ~sw) t.fd in let client_addr = match client_addr with | Unix.ADDR_UNIX path -> `Unix path | Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port) in - let flow = (Flow.of_fd client :> Eio.Net.stream_socket) in + let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in flow, client_addr - - method! probe : type a. a Eio.Generic.ty -> a option = function - | Eio_unix.Resource.FD -> Some fd - | _ -> None end -(* todo: would be nice to avoid copying between bytes and cstructs here *) -let datagram_socket sock = object - inherit Eio_unix.Net.datagram_socket +let listening_handler = Eio_unix.Resource.listening_socket_handler (module Listening_socket) + +let listening_socket ~hook fd = + Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler) + +module Datagram_socket = struct + type tag = [`Generic | `Unix] + + type t = Eio_unix.Fd.t - method close = Fd.close sock + let close = Fd.close - method fd = sock + let fd t = t - method send ?dst buf = + let send t ?dst buf = let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in - let sent = Err.run (Low_level.send_msg sock ?dst) (Bytes.unsafe_of_string (Cstruct.copyv buf)) in + let sent = Err.run (Low_level.send_msg t ?dst) (Bytes.unsafe_of_string (Cstruct.copyv buf)) in assert (sent = Cstruct.lenv buf) - method recv buf = + let recv t buf = let b = Bytes.create (Cstruct.length buf) in - let recv, addr = Err.run (Low_level.recv_msg sock) b in + let recv, addr = Err.run (Low_level.recv_msg t) b in Cstruct.blit_from_bytes b 0 buf 0 recv; Eio_unix.Net.sockaddr_of_unix_datagram addr, recv + + let shutdown t cmd = + try + Low_level.shutdown t @@ match cmd with + | `Receive -> Unix.SHUTDOWN_RECEIVE + | `Send -> Unix.SHUTDOWN_SEND + | `All -> Unix.SHUTDOWN_ALL + with + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> () + | Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) end +let datagram_handler = Eio_unix.Resource.datagram_handler (module Datagram_socket) + +let datagram_socket fd = + Eio.Resource.T (fd, datagram_handler) + (* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *) let getaddrinfo ~service node = let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } = @@ -110,7 +136,7 @@ let listen ~reuse_addr ~reuse_port ~backlog ~sw (listen_addr : Eio.Net.Sockaddr. Unix.bind fd addr; Unix.listen fd backlog ); - listening_socket ~hook sock + (listening_socket ~hook sock :> _ Eio.Net.listening_socket_ty r) let connect ~sw connect_addr = let socket_type, addr = @@ -123,7 +149,7 @@ let connect ~sw connect_addr = let sock = Low_level.socket ~sw (socket_domain_of connect_addr) socket_type 0 in try Low_level.connect sock addr; - (Flow.of_fd sock :> Eio.Net.stream_socket) + (Flow.of_fd sock :> _ Eio_unix.Net.stream_socket) with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg) let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr = @@ -140,13 +166,26 @@ let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr = ) | `UdpV4 | `UdpV6 -> () end; - (datagram_socket sock :> Eio.Net.datagram_socket) + datagram_socket sock -let v = object - inherit Eio_unix.Net.t +module Impl = struct + type t = unit + type tag = [`Generic | `Unix] - method listen = listen - method connect = connect - method datagram_socket = create_datagram_socket - method getaddrinfo = getaddrinfo + let listen () = listen + + let connect () ~sw addr = + let socket = connect ~sw addr in + (socket :> [`Generic | `Unix] Eio.Net.stream_socket_ty r) + + let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr = + let socket = create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr in + (socket :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r) + + let getaddrinfo () = getaddrinfo + let getnameinfo () = Eio_unix.Net.getnameinfo end + +let v : Impl.tag Eio.Net.ty r = + let handler = Eio.Net.Pi.network (module Impl) in + Eio.Resource.T ((), handler) diff --git a/lib_eio_windows/test/test_net.ml b/lib_eio_windows/test/test_net.ml index 7dd8b85b1..835cce6f5 100755 --- a/lib_eio_windows/test/test_net.ml +++ b/lib_eio_windows/test/test_net.ml @@ -85,8 +85,8 @@ let test_wrap_socket pipe_or_socketpair () = | `Pipe -> Unix.pipe () | `Socketpair -> Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - let source = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true r :> Eio.Flow.source) in - let sink = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true w :> Eio.Flow.sink) in + let source = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true r :> Eio.Flow.source_ty r) in + let sink = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true w :> Eio.Flow.sink_ty r) in let msg = "Hello" in Fiber.both (fun () -> Eio.Flow.copy_string (msg ^ "\n") sink) diff --git a/tests/buf_reader.md b/tests/buf_reader.md index 2ae33309c..29e32686d 100644 --- a/tests/buf_reader.md +++ b/tests/buf_reader.md @@ -19,24 +19,27 @@ let ensure t n = (* The next data to be returned by `mock_flow`. `[]` to raise `End_of_file`: *) let next = ref [] -let mock_flow = object - inherit Eio.Flow.source - - method read_methods = [] - - method read_into buf = - match !next with - | [] -> - traceln "mock_flow returning Eof"; - raise End_of_file - | x :: xs -> - let len = min (Cstruct.length buf) (String.length x) in - traceln "mock_flow returning %d bytes" len; - Cstruct.blit_from_string x 0 buf 0 len; - let x' = String.sub x len (String.length x - len) in - next := (if x' = "" then xs else x' :: xs); - len -end +let mock_flow = + let module X = struct + type t = unit + + let read_methods = [] + + let single_read () buf = + match !next with + | [] -> + traceln "mock_flow returning Eof"; + raise End_of_file + | x :: xs -> + let len = min (Cstruct.length buf) (String.length x) in + traceln "mock_flow returning %d bytes" len; + Cstruct.blit_from_string x 0 buf 0 len; + let x' = String.sub x len (String.length x - len) in + next := (if x' = "" then xs else x' :: xs); + len + end in + let ops = Eio.Flow.Pi.source (module X) in + Eio.Resource.T ((), ops) let read flow n = let buf = Cstruct.create n in @@ -238,7 +241,7 @@ Exception: End_of_file. ```ocaml # let bflow = R.of_flow mock_flow ~max_size:100 |> R.as_flow;; -val bflow : Eio.Flow.source = +val bflow : Eio.Flow.source_ty Eio.Std.r = Eio__.Resource.T (, ) # next := ["foo"; "bar"]; read bflow 2;; +mock_flow returning 3 bytes +Read "fo" diff --git a/tests/buf_write.md b/tests/buf_write.md index 06e265ad8..a793368a1 100644 --- a/tests/buf_write.md +++ b/tests/buf_write.md @@ -216,9 +216,10 @@ the whole batch to be flushed. Check flush waits for the write to succeed: ```ocaml -let slow_writer = object - inherit Eio.Flow.sink - method copy src = +module Slow_writer = struct + type t = unit + + let copy t ~src = let buf = Cstruct.create 10 in try while true do @@ -227,7 +228,12 @@ let slow_writer = object traceln "Write %S" (Cstruct.to_string buf ~len) done with End_of_file -> () + + let write t bufs = copy t ~src:(Eio.Flow.cstruct_source bufs) end +let slow_writer = + let ops = Eio.Flow.Pi.sink (module Slow_writer) in + Eio.Resource.T ((), ops) ``` ```ocaml diff --git a/tests/flow.md b/tests/flow.md index 8b128eb83..960785525 100644 --- a/tests/flow.md +++ b/tests/flow.md @@ -12,23 +12,23 @@ let run fn = Eio_main.run @@ fun _ -> fn () -let mock_source items = - object - inherit Eio.Flow.source +let mock_source = + let module X = struct + type t = Cstruct.t list ref - val mutable items = items + let read_methods = [] - method read_methods = [] - - method read_into buf = - match items with + let single_read t buf = + match !t with | [] -> raise End_of_file | x :: xs -> let len = min (Cstruct.length buf) (Cstruct.length x) in Cstruct.blit x 0 buf 0 len; - items <- Cstruct.shiftv (x :: xs) len; + t := Cstruct.shiftv (x :: xs) len; len - end + end in + let ops = Eio.Flow.Pi.source (module X) in + fun items -> Eio.Resource.T (ref items, ops) ``` ## read_exact diff --git a/tests/network.md b/tests/network.md index f1b66a358..59a372e7c 100644 --- a/tests/network.md +++ b/tests/network.md @@ -8,7 +8,7 @@ ```ocaml open Eio.Std -let run (fn : net:#Eio.Net.t -> Switch.t -> unit) = +let run (fn : net:_ Eio.Net.t -> Switch.t -> unit) = Eio_main.run @@ fun env -> let net = Eio.Stdenv.net env in Switch.run (fn ~net) @@ -361,8 +361,8 @@ Wrapping a Unix FD as an Eio stream socket: # Eio_main.run @@ fun _ -> Switch.run @@ fun sw -> let r, w = Unix.pipe () in - let source = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true r :> Eio.Flow.source) in - let sink = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true w :> Eio.Flow.sink) in + let source = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true r :> _ Eio.Flow.source) in + let sink = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true w :> _ Eio.Flow.sink) in Fiber.both (fun () -> Eio.Flow.copy_string "Hello\n!" sink) (fun () -> @@ -998,3 +998,18 @@ Limiting to 2 concurrent connections: +flow3: closed - : unit = () ``` + +We keep the polymorphism when using a Unix network: + +```ocaml +let _check_types ~(net:Eio_unix.Net.t) = + Switch.run @@ fun sw -> + let addr = `Unix "/socket" in + let server : [`Generic | `Unix] Eio.Net.listening_socket_ty r = + Eio.Net.listen ~sw net addr ~backlog:5 + in + Eio.Net.accept_fork ~sw ~on_error:raise server + (fun (_flow : [`Generic | `Unix] Eio.Net.stream_socket_ty r) _addr -> assert false); + let _client : [`Generic | `Unix] Eio.Net.stream_socket_ty r = Eio.Net.connect ~sw net addr in + ();; +```