Compare commits

..

2 Commits

Author SHA1 Message Date
Thomas Leonard
bb474070bb
Merge pull request #553 from talex5/variants
Replace objects with variants
2023-08-10 14:58:45 +01:00
Thomas Leonard
95c91c061c Use variant types in many places
Jane Street have requested that Eio not use objects. This commit
switches to an alternative scheme for representing OS resources using
variants instead. The changes for users of the library are minimal -
only the types change. The exception to this is if you want to provide
your own implementations of resources, in which case you now provide a
module rather than a class. The (small) changes to the README give a
good idea of the user-facing effect.
2023-08-10 09:50:58 +01:00
56 changed files with 2159 additions and 1373 deletions

View File

@ -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 `<type; ..>` works on all object types.
### Passing env
The `env` value you get from `Eio_main.run` is a powerful capability,

View File

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

View File

@ -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:
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.
- 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.
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

View File

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

View File

@ -1,10 +1,12 @@
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 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 =
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
end
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)

View File

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

View File

@ -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].

View File

@ -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 : <stdin : #Flow.source; ..>) = t#stdin
let stdout (t : <stdout : #Flow.sink; ..>) = t#stdout
let stderr (t : <stderr : #Flow.sink; ..>) = t#stderr
let net (t : <net : #Net.t; ..>) = t#net
let stdin (t : <stdin : _ Flow.source; ..>) = t#stdin
let stdout (t : <stdout : _ Flow.sink; ..>) = t#stdout
let stderr (t : <stderr : _ Flow.sink; ..>) = t#stderr
let net (t : <net : _ Net.t; ..>) = t#net
let process_mgr (t : <process_mgr : #Process.mgr; ..>) = t#process_mgr
let domain_mgr (t : <domain_mgr : #Domain_manager.t; ..>) = t#domain_mgr
let clock (t : <clock : #Time.clock; ..>) = t#clock
let mono_clock (t : <mono_clock : #Time.Mono.t; ..>) = t#mono_clock
let secure_random (t: <secure_random : #Flow.source; ..>) = t#secure_random
let fs (t : <fs : #Fs.dir Path.t; ..>) = t#fs
let cwd (t : <cwd : #Fs.dir Path.t; ..>) = t#cwd
let secure_random (t: <secure_random : _ Flow.source; ..>) = t#secure_random
let fs (t : <fs : _ Path.t; ..>) = t#fs
let cwd (t : <cwd : _ Path.t; ..>) = t#cwd
let debug (t : <debug : 'a; ..>) = t#debug
let backend_id (t: <backend_id : string; ..>) = t#backend_id
end

View File

@ -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 : <stdin : #Flow.source as 'a; ..> -> 'a
val stdout : <stdout : #Flow.sink as 'a; ..> -> 'a
val stderr : <stderr : #Flow.sink as 'a; ..> -> 'a
val stdin : <stdin : _ Flow.source as 'a; ..> -> 'a
val stdout : <stdout : _ Flow.sink as 'a; ..> -> 'a
val stderr : <stderr : _ Flow.sink as 'a; ..> -> 'a
(** {1 File-system access}
@ -201,7 +189,7 @@ module Stdenv : sig
To use this, see {!Net}.
*)
val net : <net : #Net.t as 'a; ..> -> 'a
val net : <net : _ Net.t as 'a; ..> -> '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 : <secure_random : #Flow.source as 'a; ..> -> 'a
val secure_random : <secure_random : _ Flow.source as 'a; ..> -> 'a
(** [secure_random t] is an infinite source of random bytes suitable for cryptographic purposes. *)
(** {1 Debugging} *)

View File

@ -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 (_ : <Generic.t; Flow.source; ..>)
method probe _ = None
method read_methods = []
method virtual pread : file_offset:Optint.Int63.t -> Cstruct.t list -> int
method virtual stat : Stat.t
type ro_ty = [`File | Flow.source_ty | Resource.close_ty]
type 'a ro = ([> ro_ty] as 'a) r
type rw_ty = [ro_ty | Flow.sink_ty]
type 'a rw = ([> rw_ty] as 'a) r
module Pi = struct
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
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
(** A file opened for reading and writing. *)
class virtual rw = object (_ : <Generic.t; Flow.source; Flow.sink; ..>)
inherit ro
method virtual pwrite : file_offset:Optint.Int63.t -> Cstruct.t list -> int
end
let stat (Resource.T (t, ops)) =
let module X = (val (Resource.get ops Pi.Read)) in
X.stat t
(** [stat t] returns the {!Stat.t} record associated with [t]. *)
let stat (t : #ro) = t#stat
(** [size t] returns the size of [t]. *)
let size t = (stat t).size
(** [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. *)
let pread (t : #ro) ~file_offset bufs =
let got = t#pread ~file_offset bufs in
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
(** [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. *)
let rec pread_exact (t : #ro) ~file_offset bufs =
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 = t#pread ~file_offset bufs in
let got = X.pread t ~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)
aux ~file_offset (Cstruct.shiftv bufs got)
)
in
aux ~file_offset bufs
(** [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. *)
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 =
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 = t#pwrite ~file_offset bufs in
let got = X.pwrite t ~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)
aux ~file_offset (Cstruct.shiftv bufs got)
)
in
aux ~file_offset bufs

104
lib_eio/file.mli Normal file
View File

@ -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]. *)

View File

@ -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)
class type close = Generic.close
let close = Generic.close
type source_ty = [`R | `Flow]
type 'a source = ([> source_ty] as 'a) r
class virtual source = object (_ : <Generic.t; ..>)
method probe _ = None
method read_methods : read_method list = []
method virtual read_into : Cstruct.t -> int
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
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
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
module Cstruct_source = struct
type t = Cstruct.t list ref
inherit source
let create data = ref data
method private read_source_buffer fn =
let read_source_buffer t fn =
let rec aux () =
match data with
match !t with
| [] -> raise End_of_file
| x :: xs when Cstruct.length x = 0 -> data <- xs; aux ()
| x :: xs when Cstruct.length x = 0 -> t := xs; aux ()
| xs ->
let n = fn xs in
data <- Cstruct.shiftv xs n
t := Cstruct.shiftv xs n
in
aux ()
method! read_methods =
[ Read_source_buffer self#read_source_buffer ]
let read_methods =
[ Read_source_buffer read_source_buffer ]
method read_into dst =
let avail, src = Cstruct.fillv ~dst ~src:data in
let single_read t dst =
let avail, src = Cstruct.fillv ~dst ~src:!t in
if avail = 0 then raise End_of_file;
data <- src;
t := src;
avail
end
let string_source s : source =
object
val mutable offset = 0
inherit source
method read_into dst =
if offset = String.length s then raise End_of_file;
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
class virtual sink = object (self : <Generic.t; ..>)
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 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 read_methods = []
let create s = { s; offset = 0 }
end
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)
let buffer_sink b =
object
inherit sink
module Buffer_sink = struct
type t = Buffer.t
method copy src =
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#read_into buf in
Buffer.add_string b (Cstruct.to_string ~len:got buf)
let got = Src.single_read src buf in
Buffer.add_string t (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
class virtual two_way = object (_ : <source; sink; ..>)
inherit sink
method read_methods = []
method virtual shutdown : shutdown_command -> unit
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

View File

@ -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
type read_method = ..
(** {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 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 *)
]
type two_way_ty = [source_ty | sink_ty | shutdown_ty]
type 'a two_way = ([> two_way_ty] as 'a) r
class virtual two_way : object
inherit source
inherit sink
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}. *)

View File

@ -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 -> <File.ro; Flow.close>
method virtual open_out :
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; Flow.close>
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 (_ : <Generic.close; ..>)
(* This dummy class avoids an "Error: The type < .. > is not an object type" error from the compiler. *)
inherit dir
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

View File

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

View File

@ -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. *)

View File

@ -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 t = [`Generic | `Mock] Eio.Net.ty r
type listening_socket = <
Eio.Net.listening_socket;
on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t;
>
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 -> <Eio.Net.stream_socket; ..> 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 -> <Eio.Net.datagram_socket; ..> 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

View File

@ -5,16 +5,19 @@ type copy_method = [
| `Read_source_buffer
]
type t = <
Eio.Flow.two_way;
Eio.Flow.close;
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;
set_copy_method : copy_method -> unit;
attach_to_switch : Switch.t -> unit;
>
mutable copy_method : copy_method;
}
let pp_default f s =
let pp_default f s =
let rec aux i =
let nl =
match String.index_from_opt s i '\n' with
@ -29,88 +32,105 @@ let pp_default f s =
in
aux 0
let rec takev len = function
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
(* 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) @[<v>%a@]" label (Fmt.Dump.list (Fmt.using Cstruct.to_string pp)) bufs;
traceln "%s: wrote (rsb) @[<v>%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 @[<v>%a@]" label pp (Cstruct.to_string (Cstruct.sub buf 0 n))
traceln "%s: wrote @[<v>%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 ()
let read_methods = []
method on_read = on_read
method on_copy_bytes = on_copy_bytes
method read_into buf =
let data = Handler.run on_read in
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!" label pp data;
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 @[<v>%a@]" label pp data;
traceln "%s: read @[<v>%a@]" t.label t.pp data;
len
method copy src =
match !copy_method with
| `Read_into -> copy_via_buffer src
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 rsb; true
| Eio.Flow.Read_source_buffer rsb -> copy_rsb t (rsb src); true
| _ -> false
in
if not (List.exists try_rsb (Eio.Flow.read_methods src)) then
if not (List.exists try_rsb Src.read_methods) then
Fmt.failwith "Source does not offer Read_source_buffer optimisation"
method set_copy_method m =
copy_method := m
let write t bufs =
copy t ~src:(Eio.Flow.cstruct_source bufs)
method shutdown cmd =
traceln "%s: shutdown %s" label @@
let shutdown t cmd =
traceln "%s: shutdown %s" t.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 ()
let close t =
while not (Queue.is_empty t.on_close) do
Queue.take t.on_close ()
done;
traceln "%s: closed" label
end
traceln "%s: closed" t.label
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 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)

View File

@ -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;
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 =
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
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"));
}
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
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
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
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
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 =
let datagram_socket t ~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
| #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 on_datagram_socket in
let socket = Handler.run t.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
let getaddrinfo t ~service node =
traceln "%s: getaddrinfo ~service:%s %s" t.label service node;
Handler.run t.on_getaddrinfo
method getnameinfo sockaddr =
traceln "%s: getnameinfo %a" label Eio.Net.Sockaddr.pp sockaddr;
Handler.run on_getnameinfo
end
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;
type listening_socket_ty = [`Generic | `Mock] Eio.Net.listening_socket_ty
type listening_socket = listening_socket_ty r
module Listening_socket = struct
type t = {
label : string;
on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t;
>
}
let listening_socket label =
let on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured")) in
object
inherit Eio.Net.listening_socket
type tag = [`Generic]
method on_accept = on_accept
let make label =
{
label;
on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured"))
}
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 on_accept t = t.on_accept
method close =
traceln "%s: closed" label
end
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 on_accept (l:listening_socket) actions =
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)

View File

@ -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 (_ : <Generic.t; Generic.close; ..>)
method probe _ = None
type socket_ty = [`Socket | `Close]
type 'a socket = ([> socket_ty] as 'a) r
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]
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 (_, _, _) Resource.pi +=
| Datagram_socket : ('t, (module DATAGRAM_SOCKET with type t = 't), [> _ datagram_socket_ty]) Resource.pi
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)
]
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
class virtual stream_socket = object (_ : #socket)
inherit Flow.two_way
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
class virtual listening_socket = object (_ : <Generic.close; ..>)
inherit socket
method virtual accept : sw:Switch.t -> stream_socket * Sockaddr.stream
end
type connection_handler = stream_socket -> Sockaddr.stream -> unit
let accept ~sw (t : #listening_socket) = t#accept ~sw
let accept_fork ~sw (t : #listening_socket) ~on_error handle =
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
let recv (Resource.T (t, ops)) buf =
let module X = (val (Resource.get ops Pi.Datagram_socket)) in
X.recv t buf
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
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
method virtual getaddrinfo : service:string -> string -> Sockaddr.t list
method virtual getnameinfo : Sockaddr.t -> (string * string)
end
let listen ?(reuse_addr=false) ?(reuse_port=false) ~backlog ~sw (t:#t) = t#listen ~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 ->

View File

@ -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 (<Generic.close; ..>)
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 (<Generic.close; ..>)
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
type 'tag datagram_socket_ty = [`Datagram | `Platform of 'tag | `Shutdown | socket_ty]
type 'a datagram_socket = 'a r
constraint 'a = [> [> `Generic] datagram_socket_ty]
method virtual getaddrinfo : service:string -> string -> Sockaddr.t list
method virtual getnameinfo : Sockaddr.t -> (string * string)
end
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

View File

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

View File

@ -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 -> <File.ro; Flow.close>
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 -> (<File.ro; Flow.close> -> '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 -> <File.rw; Flow.close>
_ 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 -> (<File.rw; Flow.close> -> '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 -> <dir; Flow.close> 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 -> (<dir; Flow.close> 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). *)

View File

@ -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; Flow.close> * <Flow.sink; Flow.close>
[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 ->

View File

@ -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; Flow.close> * <Flow.sink; Flow.close>
[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 -> <Flow.source; Flow.close> * <Flow.sink; Flow.close>
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.

35
lib_eio/resource.ml Normal file
View File

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

114
lib_eio/resource.mli Normal file
View File

@ -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 [<source; sink>]. 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. *)

5
lib_eio/std.ml Normal file
View File

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

10
lib_eio/std.mli Normal file
View File

@ -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}. *)

View File

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

View File

@ -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 : <t;..> -> Fd.t
type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi
val fd : _ t -> Fd.t
(** [fd t] returns the FD being wrapped by a resource. *)
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_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

View File

@ -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 (_ : <Resource.t; ..>)
inherit Eio.Net.stream_socket
end
class virtual datagram_socket = object (_ : <Resource.t; ..>)
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 import_socket_stream ~sw ~close_unix fd = Effect.perform (Import_socket_stream (sw, close_unix, fd))
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_datagram ~sw ~close_unix fd = Effect.perform (Import_socket_datagram (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 =
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))

View File

@ -4,19 +4,14 @@ open Eio.Std
These extend the types in {!Eio.Net} with support for file descriptors. *)
class virtual stream_socket : object (<Resource.t; ..>)
inherit Eio.Net.stream_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 datagram_socket : object (<Resource.t; ..>)
inherit Eio.Net.datagram_socket
end
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"]

View File

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

View File

@ -72,11 +72,13 @@ let get_env = function
class virtual mgr = object (self)
inherit Eio.Process.mgr
method pipe ~sw = (Private.pipe sw :> <Eio.Flow.source; Eio.Flow.close> * <Eio.Flow.sink; Eio.Flow.close>)
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 ->

View File

@ -7,11 +7,11 @@ class virtual mgr : object
method pipe :
sw:Switch.t ->
<Eio.Flow.source; Eio.Flow.close> * <Eio.Flow.sink; Eio.Flow.close>
[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 ->

View File

@ -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);
]

View File

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

View File

@ -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
end
let flow fd =
let is_tty = Fd.use_exn "isatty" fd Unix.isatty in
object (_ : <source; sink; ..>)
method fd = fd
method close = Fd.close fd
method stat = Low_level.fstat fd
method probe : type a. a Eio.Generic.ty -> a option = function
| Eio_unix.Resource.FD -> Some fd
| _ -> None
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
let shutdown t cmd =
Low_level.shutdown t @@ match cmd with
| `Receive -> Unix.SHUTDOWN_RECEIVE
| `Send -> Unix.SHUTDOWN_SEND
| `All -> Unix.SHUTDOWN_ALL
end
end
let source fd = (flow fd :> source)
let sink fd = (flow fd :> sink)
let datagram_handler = Eio_unix.Resource.datagram_handler (module Datagram_socket)
let listening_socket fd = object
inherit Eio.Net.listening_socket
let datagram_socket fd =
Eio.Resource.T (fd, datagram_handler)
method close = Fd.close fd
module Flow = struct
type tag = [`Generic | `Unix]
method accept ~sw =
type t = Eio_unix.Fd.t
let fd t = t
let close = Eio_unix.Fd.close
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 source fd = (flow fd :> _ Eio_unix.source)
let sink fd = (flow fd :> _ Eio_unix.sink)
module Listening_socket = struct
type t = Fd.t
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 :> <Eio.File.ro; Eio.Flow.close>)
(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 :> <Eio.File.rw; Eio.Flow.close>)
(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) :> <Eio.Fs.dir; Eio.Flow.close>)
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 secure_random = object
inherit Eio.Flow.source
method read_into buf = Low_level.getrandom buf; Cstruct.length buf
let dir ~label fd = Eio.Resource.T (Dir.v ~label fd, Dir_handler.v)
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

View File

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

View File

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

View File

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

View File

@ -1,8 +1,15 @@
open Eio.Std
module Fd = Eio_unix.Fd
let fstat fd =
module Impl = struct
type tag = [`Generic | `Unix]
type t = Eio_unix.Fd.t
let stat t =
try
let ust = Low_level.fstat fd in
let ust = Low_level.fstat t in
let st_kind : Eio.File.Stat.kind =
match ust.st_kind with
| Unix.S_REG -> `Regular_file
@ -29,35 +36,35 @@ let fstat fd =
}
with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg
let write_bufs fd bufs =
let write t bufs =
try
let rec loop = function
| [] -> ()
| bufs ->
let wrote = Low_level.writev fd (Array.of_list bufs) in
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 src dst =
let copy dst ~src =
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]
write dst [Cstruct.sub buf 0 got]
done
with End_of_file -> ()
let read fd buf =
match Low_level.readv fd [| buf |] with
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 fd cmd =
let shutdown t cmd =
try
Low_level.shutdown fd @@ match cmd with
Low_level.shutdown t @@ match cmd with
| `Receive -> Unix.SHUTDOWN_RECEIVE
| `Send -> Unix.SHUTDOWN_SEND
| `All -> Unix.SHUTDOWN_ALL
@ -65,34 +72,37 @@ let shutdown fd cmd =
| Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
| Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
let of_fd fd = object (_ : <Eio_unix.Net.stream_socket; Eio.File.rw>)
method fd = fd
let read_methods = []
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
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)
method read_into buf =
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)
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)

View File

@ -26,120 +26,35 @@ 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
end = struct
type t = {
dir_path : string;
sandbox : bool;
label : string;
mutable closed : bool;
}
(* 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 :> <Eio.File.ro; Eio.Flow.close>)
method open_out ~sw ~append ~create path =
let mode, flags =
match create with
| `Never -> 0, Low_level.Open_flags.empty
| `If_missing perm -> perm, Low_level.Open_flags.creat
| `Or_truncate perm -> perm, Low_level.Open_flags.(creat + trunc)
| `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
match
self#with_parent_dir path @@ fun dirfd path ->
Low_level.openat ?dirfd ~sw ~mode path flags
with
| fd -> (Flow.of_fd fd :> <Eio.File.rw; Eio.Flow.close>)
| 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.
todo: possibly we should limit the number of redirections here, like the kernel does. *)
let target = Unix.readlink path in
let full_target =
if Filename.is_relative target then
Filename.concat (Filename.dirname path) target
else target
in
self#open_out ~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 ->
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
method unlink path =
self#with_parent_dir path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:false) path
method rmdir path =
self#with_parent_dir path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:true) path
method read_dir path =
(* todo: need fdopendir here to avoid races *)
let path = self#resolve 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
| 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 ->
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
method open_dir ~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
method pp f = Fmt.string f (String.escaped 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;
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 dir_path in
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
@ -151,9 +66,11 @@ and sandbox ~label dir_path = object (self)
) else (
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
)
) else path
method with_parent_dir path fn =
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_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 '..'
@ -161,22 +78,110 @@ and sandbox ~label dir_path = object (self)
anyway. *)
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
) else (
let dir = self#resolve dir in
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
| `If_missing perm -> perm, Low_level.Open_flags.creat
| `Or_truncate perm -> perm, Low_level.Open_flags.(creat + trunc)
| `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 t) in
match
with_parent_dir t path @@ fun dirfd path ->
Low_level.openat ?dirfd ~sw ~mode path flags
with
| 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.
todo: possibly we should limit the number of redirections here, like the kernel does. *)
let target = Unix.readlink path in
let full_target =
if Filename.is_relative target then
Filename.concat (Filename.dirname path) target
else target
in
open_out t ~sw ~append ~create full_target
| exception Unix.Unix_error (code, name, arg) ->
raise (Err.wrap code name arg)
let mkdir t ~perm path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
let unlink t path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:false) path
let rmdir t path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:true) path
let read_dir t path =
(* todo: need fdopendir here to avoid races *)
let path = resolve t path in
Err.run Low_level.readdir path
|> Array.to_list
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 ->
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
let close t = t.closed <- true
let open_dir t ~sw path =
Switch.check sw;
let label = Filename.basename path in
let d = v ~label (resolve t path) ~sandbox:true in
Switch.on_release sw (fun () -> close d);
Eio.Resource.T (d, Handler.v)
let pp f t = Fmt.string f (String.escaped t.label)
end
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)

View File

@ -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)
method close = Fd.close sock
let listening_socket ~hook fd =
Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler)
method fd = sock
module Datagram_socket = struct
type tag = [`Generic | `Unix]
method send ?dst buf =
type t = Eio_unix.Fd.t
let close = Fd.close
let fd t = t
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)

View File

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

View File

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

View File

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

View File

@ -1,8 +1,15 @@
open Eio.Std
module Fd = Eio_unix.Fd
let fstat fd =
module Impl = struct
type tag = [`Generic | `Unix]
type t = Eio_unix.Fd.t
let stat t =
try
let ust = Low_level.fstat fd in
let ust = Low_level.fstat t in
let st_kind : Eio.File.Stat.kind =
match ust.st_kind with
| Unix.S_REG -> `Regular_file
@ -29,29 +36,28 @@ let fstat fd =
}
with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg
let write_bufs fd bufs =
try
Low_level.writev fd bufs
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 src dst =
let copy dst ~src =
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]
write dst [Cstruct.sub buf 0 got]
done
with End_of_file -> ()
let read fd buf =
match Low_level.read_cstruct fd buf with
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 fd cmd =
let shutdown t cmd =
try
Low_level.shutdown fd @@ match cmd with
Low_level.shutdown t @@ match cmd with
| `Receive -> Unix.SHUTDOWN_RECEIVE
| `Send -> Unix.SHUTDOWN_SEND
| `All -> Unix.SHUTDOWN_ALL
@ -59,34 +65,37 @@ let shutdown fd cmd =
| Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
| Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
let of_fd fd = object (_ : <Eio_unix.Net.stream_socket; Eio.File.rw>)
method fd = fd
let read_methods = []
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
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)
method read_into buf =
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)
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)

View File

@ -26,123 +26,35 @@ 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
end = struct
type t = {
dir_path : string;
sandbox : bool;
label : string;
mutable closed : bool;
}
(* 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 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 :> <Eio.File.ro; Eio.Flow.close>)
method open_out ~sw ~append ~create path =
let open Low_level in
let _mode, disp =
match create with
| `Never -> 0, Low_level.Flags.Disposition.open_
| `If_missing perm -> perm, Low_level.Flags.Disposition.open_if
| `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
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
| fd -> (Flow.of_fd fd :> <Eio.File.rw; Eio.Flow.close>)
(* This is the result of raising [caml_unix_error(ELOOP,...)] *)
| exception Unix.Unix_error (EUNKNOWNERR 114, _, _) ->
print_endline "UNKNOWN";
(* 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.
todo: possibly we should limit the number of redirections here, like the kernel does. *)
let target = Unix.readlink path in
let full_target =
if Filename.is_relative target then
Filename.concat (Filename.dirname path) target
else target
in
self#open_out ~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 ->
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
method unlink path =
self#with_parent_dir path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:false) path
method rmdir path =
self#with_parent_dir path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:true) path
method read_dir path =
(* todo: need fdopendir here to avoid races *)
let path = self#resolve 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
| 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 ->
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
method open_dir ~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
method pp f = Fmt.string f (String.escaped 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;
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 dir_path in
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. *)
@ -155,9 +67,11 @@ and sandbox ~label dir_path = object (self)
) else (
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
)
) else path
method with_parent_dir path fn =
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_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 '..'
@ -165,23 +79,117 @@ and sandbox ~label dir_path = object (self)
anyway. *)
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
) else (
let dir = self#resolve dir in
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 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)
let rec open_out t ~sw ~append ~create path =
let open Low_level in
let _mode, disp =
match create with
| `Never -> 0, Low_level.Flags.Disposition.open_
| `If_missing perm -> perm, Low_level.Flags.Disposition.open_if
| `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
match
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 :> Eio.File.rw_ty r)
(* This is the result of raising [caml_unix_error(ELOOP,...)] *)
| exception Unix.Unix_error (EUNKNOWNERR 114, _, _) ->
print_endline "UNKNOWN";
(* 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.
todo: possibly we should limit the number of redirections here, like the kernel does. *)
let target = Unix.readlink path in
let full_target =
if Filename.is_relative target then
Filename.concat (Filename.dirname path) target
else target
in
open_out t ~sw ~append ~create full_target
| exception Unix.Unix_error (code, name, arg) ->
raise (Err.wrap code name arg)
let mkdir t ~perm path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
let unlink t path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:false) path
let rmdir t path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:true) path
let read_dir t path =
(* todo: need fdopendir here to avoid races *)
let path = resolve t path in
Err.run Low_level.readdir path
|> Array.to_list
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 ->
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
let close t = t.closed <- true
let open_dir t ~sw path =
Switch.check sw;
let label = Filename.basename path in
let d = v ~label (resolve t path) ~sandbox:true in
Switch.on_release sw (fun () -> close d);
Eio.Resource.T (d, Handler.v)
let pp f t = Fmt.string f (String.escaped t.label)
end
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)

View File

@ -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)
method close = Fd.close sock
let listening_socket ~hook fd =
Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler)
method fd = sock
module Datagram_socket = struct
type tag = [`Generic | `Unix]
method send ?dst buf =
type t = Eio_unix.Fd.t
let close = Fd.close
let fd t = t
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)

View File

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

View File

@ -19,12 +19,13 @@ 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
let mock_flow =
let module X = struct
type t = unit
method read_methods = []
let read_methods = []
method read_into buf =
let single_read () buf =
match !next with
| [] ->
traceln "mock_flow returning Eof";
@ -36,7 +37,9 @@ let mock_flow = object
let x' = String.sub x len (String.length x - len) in
next := (if x' = "" then xs else x' :: xs);
len
end
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 = <obj>
val bflow : Eio.Flow.source_ty Eio.Std.r = Eio__.Resource.T (<poly>, <abstr>)
# next := ["foo"; "bar"]; read bflow 2;;
+mock_flow returning 3 bytes
+Read "fo"

View File

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

View File

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

View File

@ -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
();;
```