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..f35fb037d 100644 --- a/lib_eio/flow.ml +++ b/lib_eio/flow.ml @@ -1,106 +1,169 @@ +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 + 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 (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..14ca43f60 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,44 @@ 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 + 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..342232f14 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,114 @@ 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 + val close : t -> unit + end + + let stream_socket (type t tag) (module X : STREAM_SOCKET with type t = t and type tag = tag) = + Resource.handler @@ + H (Resource.Close, X.close) :: + Resource.bindings (Flow.Pi.two_way (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 + val close : t -> unit + end -type connection_handler = stream_socket -> Sockaddr.stream -> unit + type (_, _, _) Resource.pi += + | Datagram_socket : ('t, (module DATAGRAM_SOCKET with type t = 't), [> _ datagram_socket_ty]) Resource.pi -let accept ~sw (t : #listening_socket) = t#accept ~sw + 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)); + H (Resource.Close, X.close) + ] -let accept_fork ~sw (t : #listening_socket) ~on_error handle = + 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 + + 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 +277,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 +323,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..4e31ae4cd 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,84 @@ 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 + val close : t -> unit + 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 + val close : t -> unit + 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 + ();; +```