Compare commits

..

12 Commits

Author SHA1 Message Date
Vesa Karvonen
9b86081a31 Skip tests by os_type 2023-08-11 16:11:21 +03:00
Vesa Karvonen
8221bd8610 Get MDX tests working on Windows 2023-08-11 16:11:21 +03:00
Thomas Leonard
24571692f1
Merge pull request #597 from talex5/windows-fixes
Fix some MDX problems on Windows
2023-08-11 11:38:20 +01:00
Vesa Karvonen
f81880d293 Fix some MDX problems on Windows
- The `c_library_flags` are required to allow the stubs to be loaded dynamically by MDX.
- Fixed `dune` file to use `-cclib` as the `-l` options are for the linker rather than the compiler.
2023-08-11 09:57:24 +01:00
Thomas Leonard
b755d9e41f
Merge pull request #522 from talex5/fd-passing
Eio_unix: add FD passing
2023-08-11 09:53:35 +01:00
Thomas Leonard
90af8f755a Remove Unix_fd from unix network socket types
The normal ways of getting a socket don't include it anyway, and we can
infer it from something being a Unix socket.
2023-08-11 09:42:25 +01:00
Thomas Leonard
57d08881dc Add FD passing 2023-08-10 18:16:39 +01:00
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
Thomas Leonard
47f4d2034c
Merge pull request #593 from talex5/fork-alloc
Fork actions must not allocate
2023-07-28 10:15:43 +01:00
Thomas Leonard
5d8a48c20d Fork actions must not allocate
The `execve` action allocated the arrays in the forked child process.
However, in a multi-threaded program we might have forked while another
thread had the malloc lock. In that case, the child would wait forever
because it inherited the locked mutex but not the thread that would
unlock it. e.g.

    #0  futex_wait (private=0, expected=2, futex_word=0xffff9509cb10 <main_arena>) at ../sysdeps/nptl/futex-internal.h:146
    #1  __GI___lll_lock_wait_private (futex=futex@entry=0xffff9509cb10 <main_arena>) at ./nptl/lowlevellock.c:34
    #2  0x0000ffff94f8e780 in __libc_calloc (n=<optimized out>, elem_size=<optimized out>) at ./malloc/malloc.c:3650
    #3  0x0000aaaac67cfa68 in make_string_array (errors=errors@entry=37, v_array=281472912006504) at fork_action.c:47
    #4  0x0000aaaac67cfaf4 in action_execve (errors=37, v_config=281472912003024) at fork_action.c:61
    #5  0x0000aaaac67cf93c in eio_unix_run_fork_actions (errors=errors@entry=37, v_actions=281472912002960) at fork_action.c:19
2023-07-28 09:56:03 +01:00
Thomas Leonard
95a58dc711 Fix compiler warning 2023-07-28 09:56:03 +01:00
71 changed files with 2501 additions and 1460 deletions

View File

@ -1534,19 +1534,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:
@ -1559,34 +1566,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`.
@ -1739,9 +1718,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:
@ -1751,13 +1729,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
```
@ -1766,20 +1744,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,11 +1,13 @@
exception Buffer_limit_exceeded
open Std
type t = {
mutable buf : Cstruct.buffer;
mutable pos : int;
mutable len : int;
mutable flow : Flow.source option; (* None if we've seen eof *)
mutable consumed : int; (* Total bytes consumed so far *)
mutable flow : Flow.source_ty r option; (* None if we've seen eof *)
mutable consumed : int; (* Total bytes consumed so far *)
max_size : int;
}
@ -45,7 +47,7 @@ open Syntax
let capacity t = Bigarray.Array1.dim t.buf
let of_flow ?initial_size ~max_size flow =
let flow = (flow :> Flow.source) in
let flow = (flow :> Flow.source_ty r) in
if max_size <= 0 then Fmt.invalid_arg "Max size %d should be positive!" max_size;
let initial_size = Option.value initial_size ~default:(min 4096 max_size) in
let buf = Bigarray.(Array1.create char c_layout initial_size) in
@ -128,17 +130,22 @@ let ensure_slow_path t n =
let ensure t n =
if t.len < n then ensure_slow_path t n
let as_flow t =
object
inherit Flow.source
module F = struct
type nonrec t = t
method read_into dst =
ensure t 1;
let len = min (buffered_bytes t) (Cstruct.length dst) in
Cstruct.blit (peek t) 0 dst 0 len;
consume t len;
len
end
let single_read t dst =
ensure t 1;
let len = min (buffered_bytes t) (Cstruct.length dst) in
Cstruct.blit (peek t) 0 dst 0 len;
consume t len;
len
let read_methods = []
end
let as_flow =
let ops = Flow.Pi.source (module F) in
fun t -> Resource.T (t, ops)
let get t i =
Bigarray.Array1.get t.buf (t.pos + i)

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.
let pread_exact (Resource.T (t, ops)) ~file_offset bufs =
let module X = (val (Resource.get ops Pi.Read)) in
let rec aux ~file_offset bufs =
if Cstruct.lenv bufs > 0 then (
let got = X.pread t ~file_offset bufs in
let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in
aux ~file_offset (Cstruct.shiftv bufs got)
)
in
aux ~file_offset bufs
@raise End_of_file if the buffer could not be filled. *)
let rec pread_exact (t : #ro) ~file_offset bufs =
if Cstruct.lenv bufs > 0 then (
let got = t#pread ~file_offset bufs in
let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in
pread_exact t ~file_offset (Cstruct.shiftv bufs got)
)
(** [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 =
if Cstruct.lenv bufs > 0 then (
let got = t#pwrite ~file_offset bufs in
let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in
pwrite_all t ~file_offset (Cstruct.shiftv bufs got)
)
let pwrite_all (Resource.T (t, ops)) ~file_offset bufs =
let module X = (val (Resource.get ops Pi.Write)) in
let rec aux ~file_offset bufs =
if Cstruct.lenv bufs > 0 then (
let got = X.pwrite t ~file_offset bufs in
let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in
aux ~file_offset (Cstruct.shiftv bufs got)
)
in
aux ~file_offset bufs

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 rec aux () =
match data with
| [] -> raise End_of_file
| x :: xs when Cstruct.length x = 0 -> data <- xs; aux ()
| xs ->
let n = fn xs in
data <- Cstruct.shiftv xs n
in
aux ()
let read_source_buffer t fn =
let rec aux () =
match !t with
| [] -> raise End_of_file
| x :: xs when Cstruct.length x = 0 -> t := xs; aux ()
| xs ->
let n = fn xs in
t := Cstruct.shiftv xs n
in
aux ()
method! read_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
if avail = 0 then raise End_of_file;
data <- src;
avail
end
let single_read t dst =
let avail, src = Cstruct.fillv ~dst ~src:!t in
if avail = 0 then raise End_of_file;
t := src;
avail
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 buf = Cstruct.create 4096 in
try
while true do
let got = src#read_into buf in
Buffer.add_string b (Cstruct.to_string ~len:got buf)
done
with End_of_file -> ()
let copy t ~src:(Resource.T (src, ops)) =
let module Src = (val (Resource.get ops Source)) in
let buf = Cstruct.create 4096 in
try
while true do
let got = Src.single_read src buf in
Buffer.add_string t (Cstruct.to_string ~len:got buf)
done
with End_of_file -> ()
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 :
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
module Pi = struct
module type DIR = sig
type t
val open_in : t -> sw:Switch.t -> path -> File.ro_ty r
val open_out :
t ->
sw:Switch.t ->
append:bool ->
create:create ->
path -> File.rw_ty r
val mkdir : t -> perm:File.Unix_perm.t -> path -> unit
val open_dir : t -> sw:Switch.t -> path -> [`Close | dir_ty] r
val read_dir : t -> path -> string list
val unlink : t -> path -> unit
val rmdir : t -> path -> unit
val rename : t -> path -> _ dir -> path -> unit
val pp : t Fmt.t
end
type (_, _, _) Resource.pi +=
| Dir : ('t, (module DIR with type t = 't), [> dir_ty]) Resource.pi
end

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,112 +5,132 @@ type copy_method = [
| `Read_source_buffer
]
type t = <
Eio.Flow.two_way;
Eio.Flow.close;
on_read : string Handler.t;
on_copy_bytes : int Handler.t;
set_copy_method : copy_method -> unit;
attach_to_switch : Switch.t -> unit;
>
module Mock_flow = struct
type tag = [`Generic | `Mock]
let pp_default f s =
let rec aux i =
let nl =
match String.index_from_opt s i '\n' with
| None -> String.length s
| Some x -> x + 1
type t = {
label : string;
pp : string Fmt.t;
on_close : (unit -> unit) Queue.t;
on_read : string Handler.t;
on_copy_bytes : int Handler.t;
mutable copy_method : copy_method;
}
let pp_default f s =
let rec aux i =
let nl =
match String.index_from_opt s i '\n' with
| None -> String.length s
| Some x -> x + 1
in
Fmt.Dump.string f (String.sub s i (nl - i));
if nl < String.length s then (
Fmt.cut f ();
aux nl
)
in
Fmt.Dump.string f (String.sub s i (nl - i));
if nl < String.length s then (
Fmt.cut f ();
aux nl
)
in
aux 0
aux 0
let rec takev len = function
| [] -> []
| x :: _ when Cstruct.length x >= len -> [Cstruct.sub x 0 len]
| x :: xs -> x :: takev (len - Cstruct.length x) xs
let 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
let single_read t buf =
let data = Handler.run t.on_read in
let len = String.length data in
if Cstruct.length buf < len then
Fmt.failwith "%s: read buffer too short for %a!" t.label t.pp data;
Cstruct.blit_from_string data 0 buf 0 len;
traceln "%s: read @[<v>%a@]" t.label t.pp data;
len
method read_into buf =
let data = Handler.run on_read in
let len = String.length data in
if Cstruct.length buf < len then
Fmt.failwith "%s: read buffer too short for %a!" label pp data;
Cstruct.blit_from_string data 0 buf 0 len;
traceln "%s: read @[<v>%a@]" label pp data;
len
let copy t ~src =
match t.copy_method with
| `Read_into -> copy_via_buffer t src
| `Read_source_buffer ->
let Eio.Resource.T (src, ops) = src in
let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in
let try_rsb = function
| Eio.Flow.Read_source_buffer rsb -> copy_rsb t (rsb src); true
| _ -> false
in
if not (List.exists try_rsb Src.read_methods) then
Fmt.failwith "Source does not offer Read_source_buffer optimisation"
method copy src =
match !copy_method with
| `Read_into -> copy_via_buffer src
| `Read_source_buffer ->
let try_rsb = function
| Eio.Flow.Read_source_buffer rsb -> copy_rsb rsb; true
| _ -> false
in
if not (List.exists try_rsb (Eio.Flow.read_methods src)) then
Fmt.failwith "Source does not offer Read_source_buffer optimisation"
let write t bufs =
copy t ~src:(Eio.Flow.cstruct_source bufs)
method set_copy_method m =
copy_method := m
let shutdown t cmd =
traceln "%s: shutdown %s" t.label @@
match cmd with
| `Receive -> "receive"
| `Send -> "send"
| `All -> "all"
method shutdown cmd =
traceln "%s: shutdown %s" label @@
match cmd with
| `Receive -> "receive"
| `Send -> "send"
| `All -> "all"
let close t =
while not (Queue.is_empty t.on_close) do
Queue.take t.on_close ()
done;
traceln "%s: closed" t.label
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
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
method close =
while not (Queue.is_empty on_close) do
Queue.take on_close ()
done;
traceln "%s: closed" label
end
type ty = [`Generic | `Mock] Eio.Net.stream_socket_ty
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
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;
on_getaddrinfo : Eio.Net.Sockaddr.t list Handler.t;
on_getnameinfo : (string * string) Handler.t;
>
type ty = [`Generic | `Mock] Eio.Net.ty
type t = ty r
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
module Impl = struct
type tag = [`Generic]
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
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;
}
method listen ~reuse_addr:_ ~reuse_port:_ ~backlog:_ ~sw addr =
traceln "%s: listen on %a" label Eio.Net.Sockaddr.pp addr;
let socket = Handler.run on_listen in
Switch.on_release sw (fun () -> Eio.Flow.close socket);
socket
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 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
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 datagram_socket ~reuse_addr:_ ~reuse_port:_ ~sw addr =
(match addr with
| #Eio.Net.Sockaddr.datagram as saddr -> traceln "%s: datagram_socket %a" label Eio.Net.Sockaddr.pp saddr
| `UdpV4 -> traceln "%s: datagram_socket UDPv4" label
| `UdpV6 -> traceln "%s: datagram_socket UDPv6" label
);
let socket = Handler.run on_datagram_socket in
Switch.on_release sw (fun () -> Eio.Flow.close socket);
socket
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
method getaddrinfo ~service node =
traceln "%s: getaddrinfo ~service:%s %s" label service node;
Handler.run on_getaddrinfo
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 getnameinfo sockaddr =
traceln "%s: getnameinfo %a" label Eio.Net.Sockaddr.pp sockaddr;
Handler.run on_getnameinfo
end
let datagram_socket t ~reuse_addr:_ ~reuse_port:_ ~sw addr =
(match addr with
| #Eio.Net.Sockaddr.datagram as saddr -> traceln "%s: datagram_socket %a" t.label Eio.Net.Sockaddr.pp saddr
| `UdpV4 -> traceln "%s: datagram_socket UDPv4" t.label
| `UdpV6 -> traceln "%s: datagram_socket UDPv6" t.label
);
let socket = Handler.run t.on_datagram_socket in
Switch.on_release sw (fun () -> Eio.Flow.close socket);
socket
let getaddrinfo t ~service node =
traceln "%s: getaddrinfo ~service:%s %s" t.label service node;
Handler.run t.on_getaddrinfo
let getnameinfo t sockaddr =
traceln "%s: getnameinfo %a" t.label Eio.Net.Sockaddr.pp sockaddr;
Handler.run t.on_getnameinfo
type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, ty) Eio.Resource.pi
let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t
end
let make : string -> t =
let super = Eio.Net.Pi.network (module Impl) in
let handler = Eio.Resource.handler (
H (Impl.Raw, Fun.id) ::
Eio.Resource.bindings super
) in
fun label -> Eio.Resource.T (Impl.make label, handler)
let on_connect (t:t) actions =
let as_socket x = (x :> Eio.Net.stream_socket) in
Handler.seq t#on_connect (List.map (Action.map as_socket) actions)
let t = Impl.raw t in
let as_socket x = (x :> [`Generic] Eio.Net.stream_socket_ty r) in
Handler.seq t.on_connect (List.map (Action.map as_socket) actions)
let on_listen (t:t) actions =
let as_socket x = (x :> Eio.Net.listening_socket) in
Handler.seq t#on_listen (List.map (Action.map as_socket) actions)
let t = Impl.raw t in
let as_socket x = (x :> [`Generic] Eio.Net.listening_socket_ty r) in
Handler.seq t.on_listen (List.map (Action.map as_socket) actions)
let on_datagram_socket (t:t) actions =
let as_socket x = (x :> Eio.Net.datagram_socket) in
Handler.seq t#on_datagram_socket (List.map (Action.map as_socket) actions)
let on_datagram_socket (t:t) (actions : _ r Handler.actions) =
let t = Impl.raw t in
let as_socket x = (x :> [`Generic] Eio.Net.datagram_socket_ty r) in
Handler.seq t.on_datagram_socket (List.map (Action.map as_socket) actions)
let on_getaddrinfo (t:t) actions = Handler.seq t#on_getaddrinfo actions
let on_getaddrinfo (t:t) actions = Handler.seq (Impl.raw t).on_getaddrinfo actions
let on_getnameinfo (t:t) actions = Handler.seq t#on_getnameinfo actions
let on_getnameinfo (t:t) actions = Handler.seq (Impl.raw t).on_getnameinfo actions
type listening_socket = <
Eio.Net.listening_socket;
on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t;
>
type listening_socket_ty = [`Generic | `Mock] Eio.Net.listening_socket_ty
type listening_socket = listening_socket_ty r
let listening_socket label =
let on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured")) in
object
inherit Eio.Net.listening_socket
module Listening_socket = struct
type t = {
label : string;
on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t;
}
method on_accept = on_accept
type tag = [`Generic]
method accept ~sw =
let socket, addr = Handler.run on_accept in
Flow.attach_to_switch socket sw;
traceln "%s: accepted connection from %a" label Eio.Net.Sockaddr.pp addr;
(socket :> Eio.Net.stream_socket), addr
let make label =
{
label;
on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured"))
}
method close =
traceln "%s: closed" label
end
let on_accept t = t.on_accept
let on_accept (l:listening_socket) actions =
let accept t ~sw =
let socket, addr = Handler.run t.on_accept in
Flow.attach_to_switch (socket : Flow.t) sw;
traceln "%s: accepted connection from %a" t.label Eio.Net.Sockaddr.pp addr;
(socket :> tag Eio.Net.stream_socket_ty r), addr
let close t =
traceln "%s: closed" t.label
type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> t, listening_socket_ty) Eio.Resource.pi
let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t
end
let listening_socket_handler =
Eio.Resource.handler @@
Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module Listening_socket)) @ [
H (Listening_socket.Type, Fun.id);
]
let listening_socket label : listening_socket =
Eio.Resource.T (Listening_socket.make label, listening_socket_handler)
let on_accept l actions =
let r = Listening_socket.raw l in
let as_accept_pair x = (x :> Flow.t * Eio.Net.Sockaddr.stream) in
Handler.seq l#on_accept (List.map (Action.map as_accept_pair) actions)
Handler.seq r.on_accept (List.map (Action.map as_accept_pair) actions)

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
@ -29,20 +30,21 @@ module Ctf = Ctf_unix
module Process = Process
module Net = Net
module Pi = Pi
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,16 +16,15 @@ 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}. *)
@ -34,9 +33,10 @@ 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 +54,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 +65,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 +90,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
@ -98,3 +98,5 @@ module Private : sig
end
module Ctf = Ctf_unix
module Pi = Pi

View File

@ -46,6 +46,11 @@ let of_unix ~sw ?blocking ?seekable ~close_unix fd =
t.release_hook <- Switch.on_release_cancellable sw (fun () -> close t);
t
let of_unix_list ~sw fds =
match Switch.get_error sw with
| Some e -> List.iter Unix.close fds; raise e
| None -> List.map (of_unix ~sw ~close_unix:true) fds
external eio_is_blocking : Unix.file_descr -> bool = "eio_unix_is_blocking"
let is_blocking t =

View File

@ -14,6 +14,10 @@ val of_unix : sw:Switch.t -> ?blocking:bool -> ?seekable:bool -> close_unix:bool
@param seekable The value to be returned by {!is_seekable}. Defaults to probing if needed.
@param close_unix Whether {!close} also closes [fd] (this should normally be [true]). *)
val of_unix_list : sw:Switch.t -> Unix.file_descr list -> t list
(** [of_unix_list ~sw fds] is like [List.map (of_unix ~sw ~close_unix:true) fds],
except that if [sw] is off then it closes all the FDs. *)
(** {2 Using FDs} *)
val use : t -> (Unix.file_descr -> 'a) -> if_closed:(unit -> 'a) -> 'a

View File

@ -1,3 +1,9 @@
/* Note: fork actions MUST NOT allocate (either on the OCaml heap or with C malloc).
* This is because e.g. we might have forked while another thread in the parent had a lock.
* In the child, we inherit a copy of the locked mutex, but no corresponding thread to
* release it.
*/
#include <stdlib.h>
#include <unistd.h>
#include <fcntl.h>
@ -6,6 +12,9 @@
#include <caml/mlvalues.h>
#include <caml/unixsupport.h>
#include <caml/memory.h>
#include <caml/custom.h>
#include <caml/fail.h>
#include "fork_action.h"
@ -42,24 +51,61 @@ void eio_unix_fork_error(int fd, char *fn, char *buf) {
try_write_all(fd, buf);
}
static char **make_string_array(int errors, value v_array) {
int n = Wosize_val(v_array);
char **c = calloc(sizeof(char *), (n + 1));
if (!c) {
eio_unix_fork_error(errors, "make_string_array", "out of memory");
_exit(1);
}
#define String_array_val(v) *((char ***)Data_custom_val(v))
static void finalize_string_array(value v) {
free(String_array_val(v));
String_array_val(v) = NULL;
}
static struct custom_operations string_array_ops = {
"string.array",
finalize_string_array,
custom_compare_default,
custom_hash_default,
custom_serialize_default,
custom_deserialize_default,
custom_compare_ext_default,
custom_fixed_length_default
};
CAMLprim value eio_unix_make_string_array(value v_len) {
CAMLparam0();
CAMLlocal1(v_str_array);
int n = Int_val(v_len);
uintnat total;
if (caml_umul_overflow(sizeof(char *), n + 1, &total))
caml_raise_out_of_memory();
v_str_array = caml_alloc_custom_mem(&string_array_ops, sizeof(char ***), total);
char **c = calloc(sizeof(char *), n + 1);
String_array_val(v_str_array) = c;
if (!c)
caml_raise_out_of_memory();
CAMLreturn(v_str_array);
}
static void fill_string_array(char **c, value v_ocaml_array) {
int n = Wosize_val(v_ocaml_array);
for (int i = 0; i < n; i++) {
c[i] = (char *) String_val(Field(v_array, i));
c[i] = (char *) String_val(Field(v_ocaml_array, i));
}
c[n] = NULL;
return c;
}
static void action_execve(int errors, value v_config) {
value v_exe = Field(v_config, 1);
char **argv = make_string_array(errors, Field(v_config, 2));
char **envp = make_string_array(errors, Field(v_config, 3));
char **argv = String_array_val(Field(v_config, 2));
char **envp = String_array_val(Field(v_config, 4));
fill_string_array(argv, Field(v_config, 3));
fill_string_array(envp, Field(v_config, 5));
execve(String_val(v_exe), argv, envp);
eio_unix_fork_error(errors, "execve", strerror(errno));
_exit(1);

View File

@ -17,9 +17,14 @@ let rec with_actions actions fn =
with_actions xs @@ fun c_actions ->
fn (c_action :: c_actions)
type c_array
external make_string_array : int -> c_array = "eio_unix_make_string_array"
external action_execve : unit -> fork_fn = "eio_unix_fork_execve"
let action_execve = action_execve ()
let execve path ~argv ~env = { run = fun k -> k (Obj.repr (action_execve, path, argv, env)) }
let execve path ~argv ~env =
let argv_c_array = make_string_array (Array.length argv) in
let env_c_array = make_string_array (Array.length env) in
{ run = fun k -> k (Obj.repr (action_execve, path, argv_c_array, argv, env_c_array, env)) }
external action_chdir : unit -> fork_fn = "eio_unix_fork_chdir"
let action_chdir = action_chdir ()

View File

@ -1,7 +1,8 @@
#include <caml/mlvalues.h>
#include <caml/alloc.h>
/* A function that runs in the forked child process. It must not run any OCaml code or invoke the GC.
/* A function that runs in the forked child process.
* It must not run any OCaml code, invoke the GC, or even call [malloc].
* If the action fails then it writes an error message to the FD [errors] and calls [_exit].
* v_args is the c_action tuple (where field 0 is the function itself).
*/

View File

@ -1,5 +1,12 @@
open Eio.Std
type stream_socket_ty = [`Generic | `Unix] Eio.Net.stream_socket_ty
type datagram_socket_ty = [`Generic | `Unix] Eio.Net.datagram_socket_ty
type listening_socket_ty = [`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,13 +30,19 @@ 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
let send_msg (Eio.Resource.T (t, ops)) ?(fds=[]) bufs =
let module X = (val (Eio.Resource.get ops Pi.Stream_socket)) in
let rec aux ~fds bufs =
let sent = X.send_msg t ~fds bufs in
match Cstruct.shiftv bufs sent with
| [] -> ()
| bufs -> aux bufs ~fds:[]
in
aux ~fds bufs
class virtual datagram_socket = object (_ : <Resource.t; ..>)
inherit Eio.Net.datagram_socket
end
let recv_msg_with_fds (Eio.Resource.T (t, ops)) ~sw ~max_fds bufs =
let module X = (val (Eio.Resource.get ops Pi.Stream_socket)) in
X.recv_msg_with_fds t ~sw ~max_fds bufs
let getnameinfo (sockaddr : Eio.Net.Sockaddr.t) =
let options =
@ -42,28 +55,33 @@ 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 -> [`Unix_fd | stream_socket_ty] r Effect.t
| Import_socket_datagram : Switch.t * bool * Unix.file_descr -> [`Unix_fd | datagram_socket_ty] r Effect.t
| Socketpair_stream : Switch.t * Unix.socket_domain * int ->
(stream_socket * stream_socket) Effect.t
([`Unix_fd | stream_socket_ty] r * [`Unix_fd | stream_socket_ty] r) Effect.t
| Socketpair_datagram : Switch.t * Unix.socket_domain * int ->
(datagram_socket * datagram_socket) Effect.t
([`Unix_fd | datagram_socket_ty] r * [`Unix_fd | 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 :> [< `Unix_fd | stream_socket_ty] r)
let open_datagram s = (s : _ datagram_socket :> [< `Unix_fd | 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))
let fd socket =
Option.get (Resource.fd_opt socket)

View File

@ -4,19 +4,35 @@ 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 = [`Generic | `Unix] Eio.Net.stream_socket_ty
type datagram_socket_ty = [`Generic | `Unix] Eio.Net.datagram_socket_ty
type listening_socket_ty = [`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
type t = [`Generic | `Unix] Eio.Net.ty r
class virtual t : object
inherit Eio.Net.t
(** {2 Passing file descriptors} *)
method getnameinfo : Eio.Net.Sockaddr.t -> (string * string)
end
val send_msg :
[> `Platform of [>`Unix] | `Socket | `Stream] r ->
?fds:Fd.t list ->
Cstruct.t list -> unit
(** Like {!Eio.Flow.write}, but allows passing file descriptors (for Unix-domain sockets). *)
val recv_msg_with_fds :
[> `Platform of [>`Unix] | `Socket | `Stream] r ->
sw:Switch.t ->
max_fds:int ->
Cstruct.t list ->
int * Fd.t list
(** Like {!Eio.Flow.single_read}, but also allows receiving file descriptors (for Unix-domain sockets).
@param max_fds The maximum number of file descriptors to accept (additional ones will be closed). *)
val fd : [> `Platform of [> `Unix] | `Socket] r -> Fd.t
(** [fd socket] is the underlying FD of [socket]. *)
(** {2 Unix address conversions}
@ -39,7 +55,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 -> [`Unix_fd | 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 +63,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 -> [`Unix_fd | 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 +75,7 @@ val socketpair_stream :
?domain:Unix.socket_domain ->
?protocol:int ->
unit ->
stream_socket * stream_socket
[`Unix_fd | stream_socket_ty] r * [`Unix_fd | 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 +86,7 @@ val socketpair_datagram :
?domain:Unix.socket_domain ->
?protocol:int ->
unit ->
datagram_socket * datagram_socket
[`Unix_fd | datagram_socket_ty] r * [`Unix_fd | 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 +99,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 -> [`Unix_fd | 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 -> [`Unix_fd | 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} *)
([`Unix_fd | stream_socket_ty] r * [`Unix_fd | 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} *)
([`Unix_fd | datagram_socket_ty] r * [`Unix_fd | datagram_socket_ty] r) Effect.t (** See {!socketpair_datagram} *)
[@@alert "-unstable"]

51
lib_eio/unix/pi.ml Normal file
View File

@ -0,0 +1,51 @@
open Eio.Std
module type STREAM_SOCKET = sig
include Eio.Net.Pi.STREAM_SOCKET
val send_msg : t -> fds:Fd.t list -> Cstruct.t list -> int
val recv_msg_with_fds : t -> sw:Switch.t -> max_fds:int -> Cstruct.t list -> int * Fd.t list
val fd : t -> Fd.t
end
type (_, _, _) Eio.Resource.pi +=
| Stream_socket : ('t, (module STREAM_SOCKET with type t = 't), [> `Platform of [> `Unix] | `Socket | `Stream]) Eio.Resource.pi
module type FLOW = sig
include Eio.File.Pi.WRITE
include STREAM_SOCKET with type t := 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 (Resource.T, X.fd);
H (Stream_socket, (module X));
]
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 (Resource.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 (Resource.T, X.fd);
]

42
lib_eio/unix/pi.mli Normal file
View File

@ -0,0 +1,42 @@
open Eio.Std
module type STREAM_SOCKET = sig
include Eio.Net.Pi.STREAM_SOCKET
val send_msg : t -> fds:Fd.t list -> Cstruct.t list -> int
val recv_msg_with_fds : t -> sw:Switch.t -> max_fds:int -> Cstruct.t list -> int * Fd.t list
val fd : t -> Fd.t
end
type (_, _, _) Eio.Resource.pi +=
| Stream_socket : ('t, (module STREAM_SOCKET with type t = 't), [> `Platform of [> `Unix] | `Socket | `Stream]) Eio.Resource.pi
module type FLOW = sig
include Eio.File.Pi.WRITE
include STREAM_SOCKET with type t := 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

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

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,134 @@ let fallback_copy src dst =
let chunk_cs = Uring.Region.to_cstruct chunk in
try
while true do
let got = Eio.Flow.single_read src chunk_cs in
let got = Src.single_read src chunk_cs in
Low_level.write dst chunk got
done
with End_of_file -> ()
let datagram_socket sock = object
inherit Eio.Net.datagram_socket
module Datagram_socket = struct
type tag = [`Generic | `Unix]
method fd = sock
type t = Eio_unix.Fd.t
method close = Fd.close sock
let fd t = t
method send ?dst buf =
let close = Eio_unix.Fd.close
let send t ?dst buf =
let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in
let sent = Low_level.send_msg sock ?dst buf in
let sent = Low_level.send_msg t ?dst buf in
assert (sent = Cstruct.lenv buf)
method recv buf =
let addr, recv = Low_level.recv_msg sock [buf] in
let recv t buf =
let addr, recv = Low_level.recv_msg t [buf] in
Eio_unix.Net.sockaddr_of_unix_datagram (Uring.Sockaddr.get addr), recv
let shutdown t cmd =
Low_level.shutdown t @@ match cmd with
| `Receive -> Unix.SHUTDOWN_RECEIVE
| `Send -> Unix.SHUTDOWN_SEND
| `All -> Unix.SHUTDOWN_ALL
end
let datagram_handler = Eio_unix.Pi.datagram_handler (module Datagram_socket)
let datagram_socket fd =
Eio.Resource.T (fd, datagram_handler)
module Flow = struct
type tag = [`Generic | `Unix]
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
let send_msg t ~fds data =
Low_level.send_msg t ~fds data
let recv_msg_with_fds t ~sw ~max_fds data =
let _addr, n, fds = Low_level.recv_msg_with_fds t ~sw ~max_fds data in
n, fds
end
let flow_handler = Eio_unix.Pi.flow_handler (module Flow)
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
let r = Eio.Resource.T (fd, flow_handler) in
(r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :>
[< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r)
method stat = Low_level.fstat fd
let source fd = (flow fd :> _ Eio_unix.source)
let sink fd = (flow fd :> _ Eio_unix.sink)
method probe : type a. a Eio.Generic.ty -> a option = function
| Eio_unix.Resource.FD -> Some fd
| _ -> None
module Listening_socket = struct
type t = Fd.t
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]
type tag = [`Generic | `Unix]
method pread ~file_offset bufs =
Low_level.readv ~file_offset fd bufs
let fd t = t
method pwrite ~file_offset bufs =
Low_level.writev_single ~file_offset fd bufs
let close = Fd.close
method read_methods = []
method write bufs = Low_level.writev fd bufs
method copy src =
match Eio_unix.Resource.fd_opt src with
| Some src -> fast_copy_try_splice src fd
| None ->
let rec aux = function
| Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb rsb fd
| _ :: xs -> aux xs
| [] -> fallback_copy src fd
in
aux (Eio.Flow.read_methods src)
method shutdown cmd =
Low_level.shutdown fd @@ match cmd with
| `Receive -> Unix.SHUTDOWN_RECEIVE
| `Send -> Unix.SHUTDOWN_SEND
| `All -> Unix.SHUTDOWN_ALL
end
let source fd = (flow fd :> source)
let sink fd = (flow fd :> sink)
let listening_socket fd = object
inherit Eio.Net.listening_socket
method close = Fd.close fd
method accept ~sw =
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.Pi.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 +244,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 +277,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 +304,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 +421,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 +454,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 +532,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 +548,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 +559,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 +570,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 +579,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

@ -101,7 +101,7 @@ CAMLprim value caml_eio_getrandom(value v_ba, value v_off, value v_len) {
ssize_t off = (ssize_t)Long_val(v_off);
ssize_t len = (ssize_t)Long_val(v_len);
do {
void *buf = Caml_ba_data_val(v_ba) + off;
void *buf = (char *)Caml_ba_data_val(v_ba) + off;
caml_enter_blocking_section();
#if __GLIBC__ > 2 || __GLIBC_MINOR__ > 24
ret = getrandom(buf, len, 0);

View File

@ -263,10 +263,7 @@ let recv_msg_with_fds ~sw ~max_fds fd buf =
if res < 0 then (
raise @@ Err.wrap (Uring.error_of_errno res) "recv_msg" ""
);
let fds =
Uring.Msghdr.get_fds msghdr
|> List.map (fun fd -> Fd.of_unix ~sw ~close_unix:true fd)
in
let fds = Uring.Msghdr.get_fds msghdr |> Fd.of_unix_list ~sw in
addr, res, fds
let with_chunk ~fallback fn =

View File

@ -1,42 +0,0 @@
# Setting up the environment
```ocaml
# #require "eio_linux";;
```
```ocaml
open Eio.Std
let ( / ) = Eio.Path.( / )
```
Sending a file descriptor over a Unix domain socket:
```ocaml
# Eio_linux.run @@ fun env ->
Switch.run @@ fun sw ->
let fd = Eio.Path.open_out ~sw (env#cwd / "tmp.txt") ~create:(`Exclusive 0o600) in
Eio.Flow.copy_string "Test data" fd;
let r, w = Unix.(socketpair PF_UNIX SOCK_STREAM 0) in
let r = Eio_unix.Fd.of_unix ~sw ~seekable:false ~close_unix:true r in
let w = Eio_unix.Fd.of_unix ~sw ~seekable:false ~close_unix:true w in
Fiber.both
(fun () ->
let sent = Eio_linux.Low_level.send_msg w [Cstruct.of_string "x"] ~fds:[Eio_unix.Resource.fd_opt fd |> Option.get] in
assert (sent = 1)
)
(fun () ->
let buf = Cstruct.of_string "?" in
let addr, got, fds = Eio_linux.Low_level.recv_msg_with_fds ~sw r ~max_fds:10 [buf] in
traceln "Got: %S plus %d FD" (Cstruct.to_string buf) (List.length fds);
match fds with
| [fd] ->
Eio_unix.Fd.use_exn "read" fd @@ fun fd ->
ignore (Unix.lseek fd 0 Unix.SEEK_SET : int);
traceln "Read: %S" (really_input_string (Unix.in_channel_of_descr fd) 9);
| _ -> assert false
);;
+Got: "x" plus 1 FD
+Read: "Test data"
- : unit = ()
```

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

@ -212,23 +212,51 @@ CAMLprim value caml_eio_posix_spawn(value v_errors, value v_actions) {
CAMLreturn(Val_long(child_pid));
}
CAMLprim value caml_eio_posix_send_msg(value v_fd, value v_dst_opt, value v_bufs) {
CAMLparam2(v_dst_opt, v_bufs);
/* Copy [n_fds] from [v_fds] to [msg]. */
static void fill_fds(struct msghdr *msg, int n_fds, value v_fds) {
if (n_fds > 0) {
int i;
struct cmsghdr *cm;
cm = CMSG_FIRSTHDR(msg);
cm->cmsg_level = SOL_SOCKET;
cm->cmsg_type = SCM_RIGHTS;
cm->cmsg_len = CMSG_LEN(n_fds * sizeof(int));
for (i = 0; i < n_fds; i++) {
int fd = -1;
if (Is_block(v_fds)) {
fd = Int_val(Field(v_fds, 0));
v_fds = Field(v_fds, 1);
}
((int *)CMSG_DATA(cm))[i] = fd;
}
}
}
CAMLprim value caml_eio_posix_send_msg(value v_fd, value v_n_fds, value v_fds, value v_dst_opt, value v_bufs) {
CAMLparam3(v_fds, v_dst_opt, v_bufs);
int n_bufs = Wosize_val(v_bufs);
int n_fds = Int_val(v_n_fds);
struct iovec iov[n_bufs];
union sock_addr_union dst_addr;
int controllen = n_fds > 0 ? CMSG_SPACE(sizeof(int) * n_fds) : 0;
char cmsg[controllen];
struct msghdr msg = {
.msg_iov = iov,
.msg_iovlen = n_bufs,
.msg_control = n_fds > 0 ? cmsg : NULL,
.msg_controllen = controllen,
};
ssize_t r;
memset(cmsg, 0, controllen);
if (Is_some(v_dst_opt)) {
caml_unix_get_sockaddr(Some_val(v_dst_opt), &dst_addr, &msg.msg_namelen);
msg.msg_name = &dst_addr;
}
fill_iov(iov, v_bufs);
fill_fds(&msg, n_fds, v_fds);
caml_enter_blocking_section();
r = sendmsg(Int_val(v_fd), &msg, 0);
@ -238,20 +266,49 @@ CAMLprim value caml_eio_posix_send_msg(value v_fd, value v_dst_opt, value v_bufs
CAMLreturn(Val_long(r));
}
CAMLprim value caml_eio_posix_recv_msg(value v_fd, value v_bufs) {
static value get_msghdr_fds(struct msghdr *msg) {
CAMLparam0();
CAMLlocal2(v_list, v_cons);
struct cmsghdr *cm;
v_list = Val_int(0);
for (cm = CMSG_FIRSTHDR(msg); cm; cm = CMSG_NXTHDR(msg, cm)) {
if (cm->cmsg_level == SOL_SOCKET && cm->cmsg_type == SCM_RIGHTS) {
int *fds = (int *) CMSG_DATA(cm);
int n_fds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int);
int i;
for (i = n_fds - 1; i >= 0; i--) {
value fd = Val_int(fds[i]);
v_cons = caml_alloc_tuple(2);
Store_field(v_cons, 0, fd);
Store_field(v_cons, 1, v_list);
v_list = v_cons;
}
}
}
CAMLreturn(v_list);
}
CAMLprim value caml_eio_posix_recv_msg(value v_fd, value v_max_fds, value v_bufs) {
CAMLparam1(v_bufs);
CAMLlocal2(v_result, v_addr);
int max_fds = Int_val(v_max_fds);
int n_bufs = Wosize_val(v_bufs);
struct iovec iov[n_bufs];
union sock_addr_union source_addr;
int controllen = max_fds > 0 ? CMSG_SPACE(sizeof(int) * max_fds) : 0;
char cmsg[controllen];
struct msghdr msg = {
.msg_name = &source_addr,
.msg_namelen = sizeof(source_addr),
.msg_iov = iov,
.msg_iovlen = n_bufs,
.msg_control = max_fds > 0 ? cmsg : NULL,
.msg_controllen = controllen,
};
ssize_t r;
memset(cmsg, 0, controllen);
fill_iov(iov, v_bufs);
caml_enter_blocking_section();
@ -261,9 +318,10 @@ CAMLprim value caml_eio_posix_recv_msg(value v_fd, value v_bufs) {
v_addr = caml_unix_alloc_sockaddr(&source_addr, msg.msg_namelen, -1);
v_result = caml_alloc_tuple(2);
v_result = caml_alloc_tuple(3);
Store_field(v_result, 0, v_addr);
Store_field(v_result, 1, Val_long(r));
Store_field(v_result, 2, get_msghdr_fds(&msg));
CAMLreturn(v_result);
}

View File

@ -1,98 +1,115 @@
open Eio.Std
module Fd = Eio_unix.Fd
let fstat fd =
try
let ust = Low_level.fstat fd in
let st_kind : Eio.File.Stat.kind =
match ust.st_kind with
| Unix.S_REG -> `Regular_file
| Unix.S_DIR -> `Directory
| Unix.S_CHR -> `Character_special
| Unix.S_BLK -> `Block_device
| Unix.S_LNK -> `Symbolic_link
| Unix.S_FIFO -> `Fifo
| Unix.S_SOCK -> `Socket
in
Eio.File.Stat.{
dev = ust.st_dev |> Int64.of_int;
ino = ust.st_ino |> Int64.of_int;
kind = st_kind;
perm = ust.st_perm;
nlink = ust.st_nlink |> Int64.of_int;
uid = ust.st_uid |> Int64.of_int;
gid = ust.st_gid |> Int64.of_int;
rdev = ust.st_rdev |> Int64.of_int;
size = ust.st_size |> Optint.Int63.of_int64;
atime = ust.st_atime;
mtime = ust.st_mtime;
ctime = ust.st_ctime;
}
with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg
module Impl = struct
type tag = [`Generic | `Unix]
let write_bufs fd bufs =
try
let rec loop = function
| [] -> ()
| bufs ->
let wrote = Low_level.writev fd (Array.of_list bufs) in
loop (Cstruct.shiftv bufs wrote)
in
loop bufs
with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
type t = Eio_unix.Fd.t
let copy src dst =
let buf = Cstruct.create 4096 in
try
while true do
let got = Eio.Flow.single_read src buf in
write_bufs dst [Cstruct.sub buf 0 got]
done
with End_of_file -> ()
let stat t =
try
let ust = Low_level.fstat t in
let st_kind : Eio.File.Stat.kind =
match ust.st_kind with
| Unix.S_REG -> `Regular_file
| Unix.S_DIR -> `Directory
| Unix.S_CHR -> `Character_special
| Unix.S_BLK -> `Block_device
| Unix.S_LNK -> `Symbolic_link
| Unix.S_FIFO -> `Fifo
| Unix.S_SOCK -> `Socket
in
Eio.File.Stat.{
dev = ust.st_dev |> Int64.of_int;
ino = ust.st_ino |> Int64.of_int;
kind = st_kind;
perm = ust.st_perm;
nlink = ust.st_nlink |> Int64.of_int;
uid = ust.st_uid |> Int64.of_int;
gid = ust.st_gid |> Int64.of_int;
rdev = ust.st_rdev |> Int64.of_int;
size = ust.st_size |> Optint.Int63.of_int64;
atime = ust.st_atime;
mtime = ust.st_mtime;
ctime = ust.st_ctime;
}
with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg
let read fd buf =
match Low_level.readv fd [| buf |] with
| 0 -> raise End_of_file
| got -> got
| exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg)
let write t bufs =
try
let rec loop = function
| [] -> ()
| bufs ->
let wrote = Low_level.writev t (Array.of_list bufs) in
loop (Cstruct.shiftv bufs wrote)
in
loop bufs
with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
let shutdown fd cmd =
try
Low_level.shutdown fd @@ match cmd with
| `Receive -> Unix.SHUTDOWN_RECEIVE
| `Send -> Unix.SHUTDOWN_SEND
| `All -> Unix.SHUTDOWN_ALL
with
| Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
| Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
let copy dst ~src =
let buf = Cstruct.create 4096 in
try
while true do
let got = Eio.Flow.single_read src buf in
write dst [Cstruct.sub buf 0 got]
done
with End_of_file -> ()
let of_fd fd = object (_ : <Eio_unix.Net.stream_socket; Eio.File.rw>)
method fd = fd
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)
method read_methods = []
method copy src = copy src fd
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)
method pread ~file_offset bufs =
let got = Low_level.preadv ~file_offset fd (Array.of_list bufs) in
let read_methods = []
let pread t ~file_offset bufs =
let got = Low_level.preadv ~file_offset t (Array.of_list bufs) in
if got = 0 then raise End_of_file
else got
method pwrite ~file_offset bufs = Low_level.pwritev ~file_offset fd (Array.of_list bufs)
let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (Array.of_list bufs)
method stat = fstat fd
method read_into buf = read fd buf
method write bufs = write_bufs fd bufs
method shutdown cmd = shutdown fd cmd
method close = Fd.close fd
let send_msg t ~fds data =
Low_level.send_msg ~fds t (Array.of_list data)
method probe : type a. a Eio.Generic.ty -> a option = function
| Eio_unix.Resource.FD -> Some fd
| _ -> None
let recv_msg_with_fds t ~sw ~max_fds data =
let _addr, n, fds = Low_level.recv_msg_with_fds t ~sw ~max_fds (Array.of_list data) in
n, fds
let fd t = t
let close = Eio_unix.Fd.close
end
let secure_random = object
inherit Eio.Flow.source
let handler = Eio_unix.Pi.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,43 +26,77 @@ open Eio.Std
module Fd = Eio_unix.Fd
class virtual posix_dir = object
inherit Eio.Fs.dir
module rec Dir : sig
include Eio.Fs.Pi.DIR
val virtual opt_nofollow : Low_level.Open_flags.t
(** Extra flags for open operations. Sandboxes will add [O_NOFOLLOW] here. *)
val v : label:string -> sandbox:bool -> string -> t
method virtual private resolve : string -> string
(** [resolve path] returns the real path that should be used to access [path].
val resolve : t -> string -> string
(** [resolve t path] returns the real path that should be used to access [path].
For sandboxes, this is [realpath path] (and it checks that it is within the sandbox).
For unrestricted access, this is the identity function. *)
For unrestricted access, this returns [path] unchanged.
@raise Eio.Fs.Permission_denied if sandboxed and [path] is outside of [dir_path]. *)
method virtual with_parent_dir : 'a. (string -> (Fd.t option -> string -> 'a) -> 'a)
(** [with_parent_dir path fn] runs [fn dir_fd rel_path],
val with_parent_dir : t -> string -> (Fd.t option -> string -> 'a) -> 'a
(** [with_parent_dir t path fn] runs [fn dir_fd rel_path],
where [rel_path] accessed relative to [dir_fd] gives access to [path].
For unrestricted access, this just runs [fn None path].
For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *)
end
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
let resolve t path =
if t.sandbox then (
if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path;
if Filename.is_relative path then (
let dir_path = Err.run Low_level.realpath t.dir_path in
let full = Err.run Low_level.realpath (Filename.concat dir_path path) in
let prefix_len = String.length dir_path + 1 in
if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then
full
else if full = dir_path then
full
else
raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path)))
) else (
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
)
) else path
class virtual dir ~label = object (self)
inherit posix_dir
let with_parent_dir t path fn =
if t.sandbox then (
if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path;
let dir, leaf = Filename.dirname path, Filename.basename path in
if leaf = ".." then (
(* We could be smarter here and normalise the path first, but '..'
doesn't make sense for any of the current uses of [with_parent_dir]
anyway. *)
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
) else (
let dir = resolve t dir in
Switch.run @@ fun sw ->
let dirfd = Low_level.openat ~sw ~mode:0 dir Low_level.Open_flags.(directory + rdonly + nofollow) in
fn (Some dirfd) leaf
)
) else fn None path
val mutable closed = false
let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false }
method! probe : type a. a Eio.Generic.ty -> a option = function
| Posix_dir -> Some (self :> posix_dir)
| _ -> None
(* 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
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>)
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)
method open_out ~sw ~append ~create path =
let rec open_out t ~sw ~append ~create path =
let mode, flags =
match create with
| `Never -> 0, Low_level.Open_flags.empty
@ -71,12 +105,12 @@ class virtual dir ~label = object (self)
| `Exclusive perm -> perm, Low_level.Open_flags.(creat + excl)
in
let flags = if append then Low_level.Open_flags.(flags + append) else flags in
let flags = Low_level.Open_flags.(flags + rdwr + opt_nofollow) in
let flags = Low_level.Open_flags.(flags + rdwr + opt_nofollow t) in
match
self#with_parent_dir path @@ fun dirfd path ->
with_parent_dir t path @@ fun dirfd path ->
Low_level.openat ?dirfd ~sw ~mode path flags
with
| fd -> (Flow.of_fd fd :> <Eio.File.rw; Eio.Flow.close>)
| fd -> (Flow.of_fd fd :> Eio.File.rw_ty r)
| exception Unix.Unix_error (ELOOP, _, _) ->
(* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that).
A leaf symlink might be OK, but we need to check it's still in the sandbox.
@ -87,96 +121,67 @@ class virtual dir ~label = object (self)
Filename.concat (Filename.dirname path) target
else target
in
self#open_out ~sw ~append ~create full_target
open_out t ~sw ~append ~create full_target
| exception Unix.Unix_error (code, name, arg) ->
raise (Err.wrap code name arg)
method mkdir ~perm path =
self#with_parent_dir path @@ fun dirfd path ->
let mkdir t ~perm path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
method unlink path =
self#with_parent_dir path @@ fun dirfd path ->
let unlink t path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:false) path
method rmdir path =
self#with_parent_dir path @@ fun dirfd path ->
let rmdir t path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:true) path
method read_dir path =
let read_dir t path =
(* todo: need fdopendir here to avoid races *)
let path = self#resolve path in
let path = resolve t path in
Err.run Low_level.readdir path
|> Array.to_list
method rename old_path new_dir new_path =
match as_posix_dir new_dir with
let rename t old_path new_dir new_path =
match Handler.as_posix_dir new_dir with
| None -> invalid_arg "Target is not an eio_posix directory!"
| Some new_dir ->
self#with_parent_dir old_path @@ fun old_dir old_path ->
new_dir#with_parent_dir new_path @@ fun new_dir new_path ->
with_parent_dir t old_path @@ fun old_dir old_path ->
with_parent_dir new_dir new_path @@ fun new_dir new_path ->
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
method open_dir ~sw path =
let close t = t.closed <- true
let open_dir t ~sw path =
Switch.check sw;
let label = Filename.basename path in
let d = new sandbox ~label (self#resolve path) in
Switch.on_release sw (fun () -> d#close);
(d :> Eio.Fs.dir_with_close)
let d = v ~label (resolve t path) ~sandbox:true in
Switch.on_release sw (fun () -> close d);
Eio.Resource.T (d, Handler.v)
method close = closed <- true
method pp f = Fmt.string f (String.escaped label)
let pp f t = Fmt.string f (String.escaped t.label)
end
and Handler : sig
val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler
and sandbox ~label dir_path = object (self)
inherit dir ~label
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
val opt_nofollow = Low_level.Open_flags.nofollow
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)
(* Resolve a relative path to an absolute one, with no symlinks.
@raise Eio.Fs.Permission_denied if it's outside of [dir_path]. *)
method private resolve path =
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
if Filename.is_relative path then (
let dir_path = Err.run Low_level.realpath dir_path in
let full = Err.run Low_level.realpath (Filename.concat dir_path path) in
let prefix_len = String.length dir_path + 1 in
if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then
full
else if full = dir_path then
full
else
raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path)))
) else (
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
)
method with_parent_dir path fn =
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
let dir, leaf = Filename.dirname path, Filename.basename path in
if leaf = ".." then (
(* We could be smarter here and normalise the path first, but '..'
doesn't make sense for any of the current uses of [with_parent_dir]
anyway. *)
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
) else (
let dir = self#resolve dir in
Switch.run @@ fun sw ->
let dirfd = Low_level.openat ~sw ~mode:0 dir Low_level.Open_flags.(directory + rdonly + nofollow) in
fn (Some dirfd) leaf
)
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

@ -79,16 +79,27 @@ let accept ~sw sock =
let shutdown sock cmd =
Fd.use_exn "shutdown" sock (fun fd -> Unix.shutdown fd cmd)
external eio_send_msg : Unix.file_descr -> Unix.sockaddr option -> Cstruct.t array -> int = "caml_eio_posix_send_msg"
external eio_recv_msg : Unix.file_descr -> Cstruct.t array -> Unix.sockaddr * int = "caml_eio_posix_recv_msg"
external eio_send_msg : Unix.file_descr -> int -> Unix.file_descr list -> Unix.sockaddr option -> Cstruct.t array -> int = "caml_eio_posix_send_msg"
external eio_recv_msg : Unix.file_descr -> int -> Cstruct.t array -> Unix.sockaddr * int * Unix.file_descr list = "caml_eio_posix_recv_msg"
let send_msg fd ?dst buf =
let send_msg fd ?(fds = []) ?dst buf =
Fd.use_exn "send_msg" fd @@ fun fd ->
do_nonblocking Write (fun fd -> eio_send_msg fd dst buf) fd
Fd.use_exn_list "send_msg" fds @@ fun fds ->
do_nonblocking Write (fun fd -> eio_send_msg fd (List.length fds) fds dst buf) fd
let recv_msg fd buf =
Fd.use_exn "recv_msg" fd @@ fun fd ->
do_nonblocking Read (fun fd -> eio_recv_msg fd buf) fd
let addr, got, _ =
Fd.use_exn "recv_msg" fd @@ fun fd ->
do_nonblocking Read (fun fd -> eio_recv_msg fd 0 buf) fd
in
(addr, got)
let recv_msg_with_fds ~sw ~max_fds fd buf =
let addr, got, fds =
Fd.use_exn "recv_msg" fd @@ fun fd ->
do_nonblocking Read (fun fd -> eio_recv_msg fd max_fds buf) fd
in
(addr, got, Eio_unix.Fd.of_unix_list ~sw fds)
external eio_getrandom : Cstruct.buffer -> int -> int -> int = "caml_eio_posix_getrandom"

View File

@ -29,7 +29,9 @@ val accept : sw:Switch.t -> fd -> fd * Unix.sockaddr
val shutdown : fd -> Unix.shutdown_command -> unit
val recv_msg : fd -> Cstruct.t array -> Unix.sockaddr * int
val send_msg : fd -> ?dst:Unix.sockaddr -> Cstruct.t array -> int
val recv_msg_with_fds : sw:Switch.t -> max_fds:int -> fd -> Cstruct.t array -> Unix.sockaddr * int * fd list
val send_msg : fd -> ?fds:fd list -> ?dst:Unix.sockaddr -> Cstruct.t array -> int
val getrandom : Cstruct.t -> unit

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.Pi.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.Pi.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,92 +1,105 @@
open Eio.Std
module Fd = Eio_unix.Fd
let fstat fd =
try
let ust = Low_level.fstat fd in
let st_kind : Eio.File.Stat.kind =
match ust.st_kind with
| Unix.S_REG -> `Regular_file
| Unix.S_DIR -> `Directory
| Unix.S_CHR -> `Character_special
| Unix.S_BLK -> `Block_device
| Unix.S_LNK -> `Symbolic_link
| Unix.S_FIFO -> `Fifo
| Unix.S_SOCK -> `Socket
in
Eio.File.Stat.{
dev = ust.st_dev |> Int64.of_int;
ino = ust.st_ino |> Int64.of_int;
kind = st_kind;
perm = ust.st_perm;
nlink = ust.st_nlink |> Int64.of_int;
uid = ust.st_uid |> Int64.of_int;
gid = ust.st_gid |> Int64.of_int;
rdev = ust.st_rdev |> Int64.of_int;
size = ust.st_size |> Optint.Int63.of_int64;
atime = ust.st_atime;
mtime = ust.st_mtime;
ctime = ust.st_ctime;
}
with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg
module Impl = struct
type tag = [`Generic | `Unix]
let write_bufs fd bufs =
try
Low_level.writev fd bufs
with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
type t = Eio_unix.Fd.t
let copy src dst =
let buf = Cstruct.create 4096 in
try
while true do
let got = Eio.Flow.single_read src buf in
write_bufs dst [Cstruct.sub buf 0 got]
done
with End_of_file -> ()
let stat t =
try
let ust = Low_level.fstat t in
let st_kind : Eio.File.Stat.kind =
match ust.st_kind with
| Unix.S_REG -> `Regular_file
| Unix.S_DIR -> `Directory
| Unix.S_CHR -> `Character_special
| Unix.S_BLK -> `Block_device
| Unix.S_LNK -> `Symbolic_link
| Unix.S_FIFO -> `Fifo
| Unix.S_SOCK -> `Socket
in
Eio.File.Stat.{
dev = ust.st_dev |> Int64.of_int;
ino = ust.st_ino |> Int64.of_int;
kind = st_kind;
perm = ust.st_perm;
nlink = ust.st_nlink |> Int64.of_int;
uid = ust.st_uid |> Int64.of_int;
gid = ust.st_gid |> Int64.of_int;
rdev = ust.st_rdev |> Int64.of_int;
size = ust.st_size |> Optint.Int63.of_int64;
atime = ust.st_atime;
mtime = ust.st_mtime;
ctime = ust.st_ctime;
}
with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg
let read fd buf =
match Low_level.read_cstruct fd buf with
| 0 -> raise End_of_file
| got -> got
| exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg)
let write t bufs =
try Low_level.writev t bufs
with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
let shutdown fd cmd =
try
Low_level.shutdown fd @@ match cmd with
| `Receive -> Unix.SHUTDOWN_RECEIVE
| `Send -> Unix.SHUTDOWN_SEND
| `All -> Unix.SHUTDOWN_ALL
with
| Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
| Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
let copy dst ~src =
let buf = Cstruct.create 4096 in
try
while true do
let got = Eio.Flow.single_read src buf in
write dst [Cstruct.sub buf 0 got]
done
with End_of_file -> ()
let of_fd fd = object (_ : <Eio_unix.Net.stream_socket; Eio.File.rw>)
method fd = fd
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)
method read_methods = []
method copy src = copy src fd
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)
method pread ~file_offset bufs =
let got = Low_level.preadv ~file_offset fd (Array.of_list bufs) in
let read_methods = []
let pread t ~file_offset bufs =
let got = Low_level.preadv ~file_offset t (Array.of_list bufs) in
if got = 0 then raise End_of_file
else got
method pwrite ~file_offset bufs = Low_level.pwritev ~file_offset fd (Array.of_list bufs)
let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (Array.of_list bufs)
method stat = fstat fd
method read_into buf = read fd buf
method write bufs = write_bufs fd bufs
method shutdown cmd = shutdown fd cmd
method close = Fd.close fd
let send_msg _t ~fds:_ _data = failwith "Not implemented on Windows"
method probe : type a. a Eio.Generic.ty -> a option = function
| Eio_unix.Resource.FD -> Some fd
| _ -> None
let recv_msg_with_fds _t ~sw:_ ~max_fds:_ _data = failwith "Not implemented on Windows"
let fd t = t
let close = Eio_unix.Fd.close
end
let secure_random = object
inherit Eio.Flow.source
let handler = Eio_unix.Pi.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,44 +26,80 @@ open Eio.Std
module Fd = Eio_unix.Fd
class virtual posix_dir = object
inherit Eio.Fs.dir
module rec Dir : sig
include Eio.Fs.Pi.DIR
val virtual opt_nofollow : bool
(** Emulate [O_NOFOLLOW] here. *)
val v : label:string -> sandbox:bool -> string -> t
method virtual private resolve : string -> string
(** [resolve path] returns the real path that should be used to access [path].
val resolve : t -> string -> string
(** [resolve t path] returns the real path that should be used to access [path].
For sandboxes, this is [realpath path] (and it checks that it is within the sandbox).
For unrestricted access, this is the identity function. *)
For unrestricted access, this returns [path] unchanged.
@raise Eio.Fs.Permission_denied if sandboxed and [path] is outside of [dir_path]. *)
method virtual with_parent_dir : 'a. (string -> (Fd.t option -> string -> 'a) -> 'a)
(** [with_parent_dir path fn] runs [fn dir_fd rel_path],
val with_parent_dir : t -> string -> (Fd.t option -> string -> 'a) -> 'a
(** [with_parent_dir t path fn] runs [fn dir_fd rel_path],
where [rel_path] accessed relative to [dir_fd] gives access to [path].
For unrestricted access, this just runs [fn None path].
For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *)
end
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
let resolve t path =
if t.sandbox then (
if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path;
if Filename.is_relative path then (
let dir_path = Err.run Low_level.realpath t.dir_path in
let full = Err.run Low_level.realpath (Filename.concat dir_path path) in
let prefix_len = String.length dir_path + 1 in
(* \\??\\ Is necessary with NtCreateFile. *)
if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then begin
"\\??\\" ^ full
end else if full = dir_path then
"\\??\\" ^ full
else
raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path)))
) else (
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
)
) else path
class virtual dir ~label = object (self)
inherit posix_dir
let with_parent_dir t path fn =
if t.sandbox then (
if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path;
let dir, leaf = Filename.dirname path, Filename.basename path in
if leaf = ".." then (
(* We could be smarter here and normalise the path first, but '..'
doesn't make sense for any of the current uses of [with_parent_dir]
anyway. *)
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
) else (
let dir = resolve t dir in
Switch.run @@ fun sw ->
let open Low_level in
let dirfd = Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(directory) in
fn (Some dirfd) leaf
)
) else fn None path
val mutable closed = false
let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false }
method! probe : type a. a Eio.Generic.ty -> a option = function
| Posix_dir -> Some (self :> posix_dir)
| _ -> None
(* 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
method open_in ~sw path =
let open_in t ~sw path =
let open Low_level in
let fd = Err.run (Low_level.openat ~sw ~nofollow:opt_nofollow (self#resolve path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in
(Flow.of_fd fd :> <Eio.File.ro; Eio.Flow.close>)
let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in
(Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t)
method open_out ~sw ~append ~create path =
let rec open_out t ~sw ~append ~create path =
let open Low_level in
let _mode, disp =
match create with
@ -72,12 +108,15 @@ class virtual dir ~label = object (self)
| `Or_truncate perm -> perm, Low_level.Flags.Disposition.overwrite_if
| `Exclusive perm -> perm, Low_level.Flags.Disposition.create
in
let flags = if append then Low_level.Flags.Open.(synchronise + append) else Low_level.Flags.Open.(generic_write + synchronise) in
let flags =
if append then Low_level.Flags.Open.(synchronise + append)
else Low_level.Flags.Open.(generic_write + synchronise)
in
match
self#with_parent_dir path @@ fun dirfd path ->
Low_level.openat ?dirfd ~nofollow:opt_nofollow ~sw path flags disp Flags.Create.(non_directory)
with_parent_dir t path @@ fun dirfd path ->
Low_level.openat ?dirfd ~nofollow:(opt_nofollow t) ~sw path flags disp Flags.Create.(non_directory)
with
| fd -> (Flow.of_fd fd :> <Eio.File.rw; Eio.Flow.close>)
| fd -> (Flow.of_fd fd :> Eio.File.rw_ty r)
(* This is the result of raising [caml_unix_error(ELOOP,...)] *)
| exception Unix.Unix_error (EUNKNOWNERR 114, _, _) ->
print_endline "UNKNOWN";
@ -90,98 +129,67 @@ class virtual dir ~label = object (self)
Filename.concat (Filename.dirname path) target
else target
in
self#open_out ~sw ~append ~create full_target
open_out t ~sw ~append ~create full_target
| exception Unix.Unix_error (code, name, arg) ->
raise (Err.wrap code name arg)
method mkdir ~perm path =
self#with_parent_dir path @@ fun dirfd path ->
let mkdir t ~perm path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
method unlink path =
self#with_parent_dir path @@ fun dirfd path ->
let unlink t path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:false) path
method rmdir path =
self#with_parent_dir path @@ fun dirfd path ->
let rmdir t path =
with_parent_dir t path @@ fun dirfd path ->
Err.run (Low_level.unlink ?dirfd ~dir:true) path
method read_dir path =
let read_dir t path =
(* todo: need fdopendir here to avoid races *)
let path = self#resolve path in
let path = resolve t path in
Err.run Low_level.readdir path
|> Array.to_list
method rename old_path new_dir new_path =
match as_posix_dir new_dir with
let rename t old_path new_dir new_path =
match Handler.as_posix_dir new_dir with
| None -> invalid_arg "Target is not an eio_posix directory!"
| Some new_dir ->
self#with_parent_dir old_path @@ fun old_dir old_path ->
new_dir#with_parent_dir new_path @@ fun new_dir new_path ->
with_parent_dir t old_path @@ fun old_dir old_path ->
with_parent_dir new_dir new_path @@ fun new_dir new_path ->
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
method open_dir ~sw path =
let close t = t.closed <- true
let open_dir t ~sw path =
Switch.check sw;
let label = Filename.basename path in
let d = new sandbox ~label (self#resolve path) in
Switch.on_release sw (fun () -> d#close);
(d :> Eio.Fs.dir_with_close)
let d = v ~label (resolve t path) ~sandbox:true in
Switch.on_release sw (fun () -> close d);
Eio.Resource.T (d, Handler.v)
method close = closed <- true
method pp f = Fmt.string f (String.escaped label)
let pp f t = Fmt.string f (String.escaped t.label)
end
and Handler : sig
val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler
and sandbox ~label dir_path = object (self)
inherit dir ~label
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
val opt_nofollow = true
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)
(* Resolve a relative path to an absolute one, with no symlinks.
@raise Eio.Fs.Permission_denied if it's outside of [dir_path]. *)
method private resolve path =
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
if Filename.is_relative path then (
let dir_path = Err.run Low_level.realpath dir_path in
let full = Err.run Low_level.realpath (Filename.concat dir_path path) in
let prefix_len = String.length dir_path + 1 in
(* \\??\\ Is necessary with NtCreateFile. *)
if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then begin
"\\??\\" ^ full
end else if full = dir_path then
"\\??\\" ^ full
else
raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path)))
) else (
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
)
method with_parent_dir path fn =
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
let dir, leaf = Filename.dirname path, Filename.basename path in
if leaf = ".." then (
(* We could be smarter here and normalise the path first, but '..'
doesn't make sense for any of the current uses of [with_parent_dir]
anyway. *)
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
) else (
let dir = self#resolve dir in
Switch.run @@ fun sw ->
let open Low_level in
let dirfd = Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(directory) in
fn (Some dirfd) leaf
)
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.Pi.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.Pi.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)
@ -98,8 +98,8 @@ let test_wrap_socket pipe_or_socketpair () =
let test_eio_socketpair () =
Switch.run @@ fun sw ->
let a, b = Eio_unix.Net.socketpair_stream ~sw () in
ignore (Eio_unix.Resource.fd a : Eio_unix.Fd.t);
ignore (Eio_unix.Resource.fd b : Eio_unix.Fd.t);
ignore (Eio_unix.Net.fd a : Eio_unix.Fd.t);
ignore (Eio_unix.Net.fd b : Eio_unix.Fd.t);
Eio.Flow.copy_string "foo" a;
Eio.Flow.close a;
let msg = Eio.Buf_read.of_flow b ~max_size:10 |> Eio.Buf_read.take_all in

View File

@ -1,26 +1,35 @@
open Eio.Std
let n_domains = 4
let n_rounds = 100
let n_procs_per_round = 100
let n_procs_per_round_per_domain = 100 / n_domains
let main mgr =
let run_in_domain mgr =
let echo n = Eio.Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo " ^ string_of_int n] in
Switch.run @@ fun sw ->
for j = 1 to n_procs_per_round_per_domain do
Fiber.fork ~sw (fun () ->
let result = echo j in
assert (int_of_string result = j);
(* traceln "OK: %d" j *)
)
done
let main ~dm mgr =
let t0 = Unix.gettimeofday () in
for i = 1 to n_rounds do
Switch.run @@ fun sw ->
for j = 1 to n_procs_per_round do
Fiber.fork ~sw (fun () ->
let result = echo j in
assert (int_of_string result = j);
(* traceln "OK: %d" j *)
)
done;
if false then traceln "Finished round %d/%d" i n_rounds
Switch.run (fun sw ->
for _ = 1 to n_domains - 1 do
Fiber.fork ~sw (fun () -> Eio.Domain_manager.run dm (fun () -> run_in_domain mgr))
done;
Fiber.fork ~sw (fun () -> run_in_domain mgr);
);
if true then traceln "Finished round %d/%d" i n_rounds
done;
let t1 = Unix.gettimeofday () in
let n_procs = n_rounds * n_procs_per_round in
traceln "Finished process stress test: ran %d processes in %.2fs" n_procs (t1 -. t0)
let n_procs = n_rounds * n_procs_per_round_per_domain * n_domains in
traceln "Finished process stress test: ran %d processes in %.2fs (using %d domains)" n_procs (t1 -. t0) n_domains
let () =
Eio_main.run @@ fun env ->
main env#process_mgr
main ~dm:env#domain_mgr env#process_mgr

View File

@ -19,24 +19,27 @@ let ensure t n =
(* The next data to be returned by `mock_flow`. `[]` to raise `End_of_file`: *)
let next = ref []
let mock_flow = object
inherit Eio.Flow.source
let mock_flow =
let module X = struct
type t = unit
method read_methods = []
let read_methods = []
method read_into buf =
match !next with
| [] ->
traceln "mock_flow returning Eof";
raise End_of_file
| x :: xs ->
let len = min (Cstruct.length buf) (String.length x) in
traceln "mock_flow returning %d bytes" len;
Cstruct.blit_from_string x 0 buf 0 len;
let x' = String.sub x len (String.length x - len) in
next := (if x' = "" then xs else x' :: xs);
len
end
let single_read () buf =
match !next with
| [] ->
traceln "mock_flow returning Eof";
raise End_of_file
| x :: xs ->
let len = min (Cstruct.length buf) (String.length x) in
traceln "mock_flow returning %d bytes" len;
Cstruct.blit_from_string x 0 buf 0 len;
let x' = String.sub x len (String.length x - len) in
next := (if x' = "" then xs else x' :: xs);
len
end in
let ops = Eio.Flow.Pi.source (module X) in
Eio.Resource.T ((), ops)
let read flow n =
let buf = Cstruct.create n in
@ -238,7 +241,7 @@ Exception: End_of_file.
```ocaml
# let bflow = R.of_flow mock_flow ~max_size:100 |> R.as_flow;;
val bflow : Eio.Flow.source = <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

77
tests/fd_passing.md Normal file
View File

@ -0,0 +1,77 @@
# Setting up the environment
```ocaml
# #require "eio_main";;
```
```ocaml
open Eio.Std
let ( / ) = Eio.Path.( / )
```
```ocaml
(* Send [to_send] to [w] and get it from [r], then read it. *)
let test ~to_send r w =
Switch.run @@ fun sw ->
Fiber.both
(fun () -> Eio_unix.Net.send_msg w [Cstruct.of_string "x"] ~fds:to_send)
(fun () ->
let buf = Cstruct.of_string "?" in
let got, fds = Eio_unix.Net.recv_msg_with_fds ~sw r ~max_fds:2 [buf] in
let msg = Cstruct.to_string buf ~len:got in
traceln "Got: %S plus %d FDs" msg (List.length fds);
fds |> List.iter (fun fd ->
Eio_unix.Fd.use_exn "read" fd @@ fun fd ->
let len = Unix.lseek fd 0 Unix.SEEK_CUR in
ignore (Unix.lseek fd 0 Unix.SEEK_SET : int);
traceln "Read: %S" (really_input_string (Unix.in_channel_of_descr fd) len);
)
)
let with_tmp_file dir id fn =
let path = (dir / (Printf.sprintf "tmp-%s.txt" id)) in
Eio.Path.with_open_out path ~create:(`Exclusive 0o600) @@ fun file ->
Fun.protect
(fun () ->
Eio.Flow.copy_string id file;
fn (Option.get (Eio_unix.Resource.fd_opt file))
)
~finally:(fun () -> Eio.Path.unlink path)
```
## Tests
Using a socket-pair:
```ocaml
# Eio_main.run @@ fun env ->
with_tmp_file env#cwd "foo" @@ fun fd1 ->
with_tmp_file env#cwd "bar" @@ fun fd2 ->
Switch.run @@ fun sw ->
let r, w = Eio_unix.Net.socketpair_stream ~sw ~domain:PF_UNIX ~protocol:0 () in
test ~to_send:[fd1; fd2] r w;;
+Got: "x" plus 2 FDs
+Read: "foo"
+Read: "bar"
- : unit = ()
```
Using named sockets:
```ocaml
# Eio_main.run @@ fun env ->
let net = env#net in
with_tmp_file env#cwd "foo" @@ fun fd ->
Switch.run @@ fun sw ->
let addr = `Unix "test.socket" in
let server = Eio.Net.listen ~sw net ~reuse_addr:true ~backlog:1 addr in
let r, w = Fiber.pair
(fun () -> Eio.Net.connect ~sw net addr)
(fun () -> fst (Eio.Net.accept ~sw server))
in
test ~to_send:[fd] r w;;
+Got: "x" plus 1 FDs
+Read: "foo"
- : unit = ()
```

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 () ->
@ -470,8 +470,8 @@ Exception: Failure "Simulated error".
# Eio_main.run @@ fun _ ->
Switch.run @@ fun sw ->
let a, b = Eio_unix.Net.socketpair_stream ~sw () in
ignore (Eio_unix.Resource.fd a : Eio_unix.Fd.t);
ignore (Eio_unix.Resource.fd b : Eio_unix.Fd.t);
ignore (Eio_unix.Net.fd a : Eio_unix.Fd.t);
ignore (Eio_unix.Net.fd b : Eio_unix.Fd.t);
Eio.Flow.copy_string "foo" a;
Eio.Flow.close a;
let msg = Eio.Buf_read.of_flow b ~max_size:10 |> Eio.Buf_read.take_all in
@ -746,8 +746,8 @@ Eio.Io Net Connection_failure Timeout,
# Eio_main.run @@ fun _ ->
Switch.run @@ fun sw ->
let a, b = Eio_unix.Net.socketpair_datagram ~sw ~domain:Unix.PF_UNIX () in
ignore (Eio_unix.Resource.fd a : Eio_unix.Fd.t);
ignore (Eio_unix.Resource.fd b : Eio_unix.Fd.t);
ignore (Eio_unix.Net.fd a : Eio_unix.Fd.t);
ignore (Eio_unix.Net.fd b : Eio_unix.Fd.t);
let l = [ "foo"; "bar"; "foobar"; "cellar door"; "" ] in
let buf = Cstruct.create 32 in
let write bufs = Eio.Net.send a (List.map Cstruct.of_string bufs) in
@ -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
();;
```