mirror of
https://github.com/ocaml-multicore/eio.git
synced 2025-07-17 00:01:11 -04:00
Compare commits
2 Commits
47f4d2034c
...
bb474070bb
Author | SHA1 | Date | |
---|---|---|---|
|
bb474070bb | ||
|
95c91c061c |
58
README.md
58
README.md
@ -1524,19 +1524,26 @@ See Eio's own tests for examples, e.g., [tests/switch.md](tests/switch.md).
|
||||
## Provider Interfaces
|
||||
|
||||
Eio applications use resources by calling functions (such as `Eio.Flow.write`).
|
||||
These functions are actually wrappers that call methods on the resources.
|
||||
These functions are actually wrappers that look up the implementing module and call
|
||||
the appropriate function on that.
|
||||
This allows you to define your own resources.
|
||||
|
||||
Here's a flow that produces an endless stream of zeros (like "/dev/zero"):
|
||||
|
||||
```ocaml
|
||||
let zero = object
|
||||
inherit Eio.Flow.source
|
||||
module Zero = struct
|
||||
type t = unit
|
||||
|
||||
method read_into buf =
|
||||
let single_read () buf =
|
||||
Cstruct.memset buf 0;
|
||||
Cstruct.length buf
|
||||
|
||||
let read_methods = [] (* Optional optimisations *)
|
||||
end
|
||||
|
||||
let ops = Eio.Flow.Pi.source (module Zero)
|
||||
|
||||
let zero = Eio.Resource.T ((), ops)
|
||||
```
|
||||
|
||||
It can then be used like any other Eio flow:
|
||||
@ -1549,34 +1556,6 @@ It can then be used like any other Eio flow:
|
||||
- : unit = ()
|
||||
```
|
||||
|
||||
The `Flow.source` interface has some extra methods that can be used for optimisations
|
||||
(for example, instead of filling a buffer with zeros it could be more efficient to share
|
||||
a pre-allocated block of zeros).
|
||||
Using `inherit` provides default implementations of these methods that say no optimisations are available.
|
||||
It also protects you somewhat from API changes in future, as defaults can be provided for any new methods that get added.
|
||||
|
||||
Although it is possible to *use* an object by calling its methods directly,
|
||||
it is recommended that you use the functions instead.
|
||||
The functions provide type information to the compiler, leading to clearer error messages,
|
||||
and may provide extra features or sanity checks.
|
||||
|
||||
For example `Eio.Flow.single_read` is defined as:
|
||||
|
||||
```ocaml
|
||||
let single_read (t : #Eio.Flow.source) buf =
|
||||
let got = t#read_into buf in
|
||||
assert (got > 0 && got <= Cstruct.length buf);
|
||||
got
|
||||
```
|
||||
|
||||
As an exception to this rule, it is fine to use the methods of `env` directly
|
||||
(e.g. using `main env#stdin` instead of `main (Eio.Stdenv.stdin env)`.
|
||||
Here, the compiler already has the type from the `Eio_main.run` call immediately above it,
|
||||
and `env` is acting as a simple record.
|
||||
We avoid doing that in this guide only to avoid alarming OCaml users unfamiliar with object syntax.
|
||||
|
||||
See [Dynamic Dispatch](doc/rationale.md#dynamic-dispatch) for more discussion about the use of objects here.
|
||||
|
||||
## Example Applications
|
||||
|
||||
- [gemini-eio][] is a simple Gemini browser. It shows how to integrate Eio with `ocaml-tls` and `notty`.
|
||||
@ -1729,9 +1708,8 @@ Of course, you could use `with_open_in` in this case to simplify it further.
|
||||
|
||||
### Casting
|
||||
|
||||
Unlike many languages, OCaml does not automatically cast objects (polymorphic records) to super-types as needed.
|
||||
Unlike many languages, OCaml does not automatically cast to super-types as needed.
|
||||
Remember to keep the type polymorphic in your interface so users don't need to do this manually.
|
||||
This is similar to the case with polymorphic variants (where APIs should use `[< ...]` or `[> ...]`).
|
||||
|
||||
For example, if you need an `Eio.Flow.source` then users should be able to use a `Flow.two_way`
|
||||
without having to cast it first:
|
||||
@ -1741,13 +1719,13 @@ without having to cast it first:
|
||||
(* BAD - user must cast to use function: *)
|
||||
module Message : sig
|
||||
type t
|
||||
val read : Eio.Flow.source -> t
|
||||
val read : Eio.Flow.source_ty r -> t
|
||||
end
|
||||
|
||||
(* GOOD - a Flow.two_way can be used without casting: *)
|
||||
module Message : sig
|
||||
type t
|
||||
val read : #Eio.Flow.source -> t
|
||||
val read : _ Eio.Flow.source -> t
|
||||
end
|
||||
```
|
||||
|
||||
@ -1756,20 +1734,18 @@ If you want to store the argument, this may require you to cast internally:
|
||||
```ocaml
|
||||
module Foo : sig
|
||||
type t
|
||||
val of_source : #Eio.Flow.source -> t
|
||||
val of_source : _ Eio.Flow.source -> t
|
||||
end = struct
|
||||
type t = {
|
||||
src : Eio.Flow.source;
|
||||
src : Eio.Flow.source_ty r;
|
||||
}
|
||||
|
||||
let of_source x = {
|
||||
src = (x :> Eio.Flow.source);
|
||||
src = (x :> Eio.Flow.source_ty r);
|
||||
}
|
||||
end
|
||||
```
|
||||
|
||||
Note: the `#type` syntax only works on types defined by classes, whereas the slightly more verbose `<type; ..>` works on all object types.
|
||||
|
||||
### Passing env
|
||||
|
||||
The `env` value you get from `Eio_main.run` is a powerful capability,
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -1,10 +1,12 @@
|
||||
exception Buffer_limit_exceeded
|
||||
|
||||
open Std
|
||||
|
||||
type t = {
|
||||
mutable buf : Cstruct.buffer;
|
||||
mutable pos : int;
|
||||
mutable len : int;
|
||||
mutable flow : Flow.source option; (* None if we've seen eof *)
|
||||
mutable flow : Flow.source_ty r option; (* None if we've seen eof *)
|
||||
mutable consumed : int; (* Total bytes consumed so far *)
|
||||
max_size : int;
|
||||
}
|
||||
@ -45,7 +47,7 @@ open Syntax
|
||||
let capacity t = Bigarray.Array1.dim t.buf
|
||||
|
||||
let of_flow ?initial_size ~max_size flow =
|
||||
let flow = (flow :> Flow.source) in
|
||||
let flow = (flow :> Flow.source_ty r) in
|
||||
if max_size <= 0 then Fmt.invalid_arg "Max size %d should be positive!" max_size;
|
||||
let initial_size = Option.value initial_size ~default:(min 4096 max_size) in
|
||||
let buf = Bigarray.(Array1.create char c_layout initial_size) in
|
||||
@ -128,17 +130,22 @@ let ensure_slow_path t n =
|
||||
let ensure t n =
|
||||
if t.len < n then ensure_slow_path t n
|
||||
|
||||
let as_flow t =
|
||||
object
|
||||
inherit Flow.source
|
||||
module F = struct
|
||||
type nonrec t = t
|
||||
|
||||
method read_into dst =
|
||||
let single_read t dst =
|
||||
ensure t 1;
|
||||
let len = min (buffered_bytes t) (Cstruct.length dst) in
|
||||
Cstruct.blit (peek t) 0 dst 0 len;
|
||||
consume t len;
|
||||
len
|
||||
end
|
||||
|
||||
let read_methods = []
|
||||
end
|
||||
|
||||
let as_flow =
|
||||
let ops = Flow.Pi.source (module F) in
|
||||
fun t -> Resource.T (t, ops)
|
||||
|
||||
let get t i =
|
||||
Bigarray.Array1.get t.buf (t.pos + i)
|
||||
|
@ -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,
|
||||
|
@ -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].
|
||||
|
@ -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
|
||||
|
@ -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} *)
|
||||
|
113
lib_eio/file.ml
113
lib_eio/file.ml
@ -1,13 +1,10 @@
|
||||
(** Tranditional Unix permissions. *)
|
||||
open Std
|
||||
|
||||
module Unix_perm = struct
|
||||
type t = int
|
||||
(** This is the same as {!Unix.file_perm}, but avoids a dependency on [Unix]. *)
|
||||
end
|
||||
|
||||
(** Portable file stats. *)
|
||||
module Stat = struct
|
||||
|
||||
(** Kind of file from st_mode. **)
|
||||
type kind = [
|
||||
| `Unknown
|
||||
| `Fifo
|
||||
@ -19,7 +16,6 @@ module Stat = struct
|
||||
| `Socket
|
||||
]
|
||||
|
||||
(** Like stat(2). *)
|
||||
type t = {
|
||||
dev : Int64.t;
|
||||
ino : Int64.t;
|
||||
@ -36,62 +32,85 @@ module Stat = struct
|
||||
}
|
||||
end
|
||||
|
||||
(** A file opened for reading. *)
|
||||
class virtual ro = object (_ : <Generic.t; Flow.source; ..>)
|
||||
method probe _ = None
|
||||
method read_methods = []
|
||||
method virtual pread : file_offset:Optint.Int63.t -> Cstruct.t list -> int
|
||||
method virtual stat : Stat.t
|
||||
type ro_ty = [`File | Flow.source_ty | Resource.close_ty]
|
||||
|
||||
type 'a ro = ([> ro_ty] as 'a) r
|
||||
|
||||
type rw_ty = [ro_ty | Flow.sink_ty]
|
||||
|
||||
type 'a rw = ([> rw_ty] as 'a) r
|
||||
|
||||
module Pi = struct
|
||||
module type READ = sig
|
||||
include Flow.Pi.SOURCE
|
||||
|
||||
val pread : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int
|
||||
val stat : t -> Stat.t
|
||||
val close : t -> unit
|
||||
end
|
||||
|
||||
module type WRITE = sig
|
||||
include Flow.Pi.SINK
|
||||
include READ with type t := t
|
||||
|
||||
val pwrite : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int
|
||||
end
|
||||
|
||||
type (_, _, _) Resource.pi +=
|
||||
| Read : ('t, (module READ with type t = 't), [> ro_ty]) Resource.pi
|
||||
| Write : ('t, (module WRITE with type t = 't), [> rw_ty]) Resource.pi
|
||||
|
||||
let ro (type t) (module X : READ with type t = t) =
|
||||
Resource.handler [
|
||||
H (Flow.Pi.Source, (module X));
|
||||
H (Read, (module X));
|
||||
H (Resource.Close, X.close);
|
||||
]
|
||||
|
||||
let rw (type t) (module X : WRITE with type t = t) =
|
||||
Resource.handler (
|
||||
H (Flow.Pi.Sink, (module X)) ::
|
||||
H (Write, (module X)) ::
|
||||
Resource.bindings (ro (module X))
|
||||
)
|
||||
end
|
||||
|
||||
(** A file opened for reading and writing. *)
|
||||
class virtual rw = object (_ : <Generic.t; Flow.source; Flow.sink; ..>)
|
||||
inherit ro
|
||||
method virtual pwrite : file_offset:Optint.Int63.t -> Cstruct.t list -> int
|
||||
end
|
||||
let stat (Resource.T (t, ops)) =
|
||||
let module X = (val (Resource.get ops Pi.Read)) in
|
||||
X.stat t
|
||||
|
||||
(** [stat t] returns the {!Stat.t} record associated with [t]. *)
|
||||
let stat (t : #ro) = t#stat
|
||||
|
||||
(** [size t] returns the size of [t]. *)
|
||||
let size t = (stat t).size
|
||||
|
||||
(** [pread t ~file_offset bufs] performs a single read of [t] at [file_offset] into [bufs].
|
||||
|
||||
It returns the number of bytes read, which may be less than the space in [bufs],
|
||||
even if more bytes are available. Use {!pread_exact} instead if you require
|
||||
the buffer to be filled.
|
||||
|
||||
To read at the current offset, use {!Flow.single_read} instead. *)
|
||||
let pread (t : #ro) ~file_offset bufs =
|
||||
let got = t#pread ~file_offset bufs in
|
||||
let pread (Resource.T (t, ops)) ~file_offset bufs =
|
||||
let module X = (val (Resource.get ops Pi.Read)) in
|
||||
let got = X.pread t ~file_offset bufs in
|
||||
assert (got > 0 && got <= Cstruct.lenv bufs);
|
||||
got
|
||||
|
||||
(** [pread_exact t ~file_offset bufs] reads from [t] into [bufs] until [bufs] is full.
|
||||
|
||||
@raise End_of_file if the buffer could not be filled. *)
|
||||
let rec pread_exact (t : #ro) ~file_offset bufs =
|
||||
let pread_exact (Resource.T (t, ops)) ~file_offset bufs =
|
||||
let module X = (val (Resource.get ops Pi.Read)) in
|
||||
let rec aux ~file_offset bufs =
|
||||
if Cstruct.lenv bufs > 0 then (
|
||||
let got = t#pread ~file_offset bufs in
|
||||
let got = X.pread t ~file_offset bufs in
|
||||
let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in
|
||||
pread_exact t ~file_offset (Cstruct.shiftv bufs got)
|
||||
aux ~file_offset (Cstruct.shiftv bufs got)
|
||||
)
|
||||
in
|
||||
aux ~file_offset bufs
|
||||
|
||||
(** [pwrite_single t ~file_offset bufs] performs a single write operation, writing
|
||||
data from [bufs] to location [file_offset] in [t].
|
||||
|
||||
It returns the number of bytes written, which may be less than the length of [bufs].
|
||||
In most cases, you will want to use {!pwrite_all} instead. *)
|
||||
let pwrite_single (t : #rw) ~file_offset bufs =
|
||||
let got = t#pwrite ~file_offset bufs in
|
||||
let pwrite_single (Resource.T (t, ops)) ~file_offset bufs =
|
||||
let module X = (val (Resource.get ops Pi.Write)) in
|
||||
let got = X.pwrite t ~file_offset bufs in
|
||||
assert (got > 0 && got <= Cstruct.lenv bufs);
|
||||
got
|
||||
|
||||
(** [pwrite_all t ~file_offset bufs] writes all the data in [bufs] to location [file_offset] in [t]. *)
|
||||
let rec pwrite_all (t : #rw) ~file_offset bufs =
|
||||
let pwrite_all (Resource.T (t, ops)) ~file_offset bufs =
|
||||
let module X = (val (Resource.get ops Pi.Write)) in
|
||||
let rec aux ~file_offset bufs =
|
||||
if Cstruct.lenv bufs > 0 then (
|
||||
let got = t#pwrite ~file_offset bufs in
|
||||
let got = X.pwrite t ~file_offset bufs in
|
||||
let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in
|
||||
pwrite_all t ~file_offset (Cstruct.shiftv bufs got)
|
||||
aux ~file_offset (Cstruct.shiftv bufs got)
|
||||
)
|
||||
in
|
||||
aux ~file_offset bufs
|
||||
|
104
lib_eio/file.mli
Normal file
104
lib_eio/file.mli
Normal 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]. *)
|
189
lib_eio/flow.ml
189
lib_eio/flow.ml
@ -1,106 +1,169 @@
|
||||
open Std
|
||||
|
||||
type shutdown_command = [ `Receive | `Send | `All ]
|
||||
|
||||
type read_method = ..
|
||||
type read_method += Read_source_buffer of ((Cstruct.t list -> int) -> unit)
|
||||
type 't read_method = ..
|
||||
type 't read_method += Read_source_buffer of ('t -> (Cstruct.t list -> int) -> unit)
|
||||
|
||||
class type close = Generic.close
|
||||
let close = Generic.close
|
||||
type source_ty = [`R | `Flow]
|
||||
type 'a source = ([> source_ty] as 'a) r
|
||||
|
||||
class virtual source = object (_ : <Generic.t; ..>)
|
||||
method probe _ = None
|
||||
method read_methods : read_method list = []
|
||||
method virtual read_into : Cstruct.t -> int
|
||||
type sink_ty = [`W | `Flow]
|
||||
type 'a sink = ([> sink_ty] as 'a) r
|
||||
|
||||
type shutdown_ty = [`Shutdown]
|
||||
type 'a shutdown = ([> shutdown_ty] as 'a) r
|
||||
|
||||
module Pi = struct
|
||||
module type SOURCE = sig
|
||||
type t
|
||||
val read_methods : t read_method list
|
||||
val single_read : t -> Cstruct.t -> int
|
||||
end
|
||||
|
||||
module type SINK = sig
|
||||
type t
|
||||
val copy : t -> src:_ source -> unit
|
||||
val write : t -> Cstruct.t list -> unit
|
||||
end
|
||||
|
||||
module type SHUTDOWN = sig
|
||||
type t
|
||||
val shutdown : t -> shutdown_command -> unit
|
||||
end
|
||||
|
||||
type (_, _, _) Resource.pi +=
|
||||
| Source : ('t, (module SOURCE with type t = 't), [> source_ty]) Resource.pi
|
||||
| Sink : ('t, (module SINK with type t = 't), [> sink_ty]) Resource.pi
|
||||
| Shutdown : ('t, (module SHUTDOWN with type t = 't), [> shutdown_ty]) Resource.pi
|
||||
|
||||
|
||||
let source (type t) (module X : SOURCE with type t = t) =
|
||||
Resource.handler [H (Source, (module X))]
|
||||
|
||||
let sink (type t) (module X : SINK with type t = t) =
|
||||
Resource.handler [H (Sink, (module X))]
|
||||
|
||||
let shutdown (type t) (module X : SHUTDOWN with type t = t) =
|
||||
Resource.handler [ H (Shutdown, (module X))]
|
||||
|
||||
module type TWO_WAY = sig
|
||||
include SHUTDOWN
|
||||
include SOURCE with type t := t
|
||||
include SINK with type t := t
|
||||
end
|
||||
|
||||
let two_way (type t) (module X : TWO_WAY with type t = t) =
|
||||
Resource.handler [
|
||||
H (Shutdown, (module X));
|
||||
H (Source, (module X));
|
||||
H (Sink, (module X));
|
||||
]
|
||||
end
|
||||
|
||||
let single_read (t : #source) buf =
|
||||
let got = t#read_into buf in
|
||||
open Pi
|
||||
|
||||
let close = Resource.close
|
||||
|
||||
let single_read (Resource.T (t, ops)) buf =
|
||||
let module X = (val (Resource.get ops Source)) in
|
||||
let got = X.single_read t buf in
|
||||
assert (got > 0 && got <= Cstruct.length buf);
|
||||
got
|
||||
|
||||
let read_methods (t : #source) = t#read_methods
|
||||
|
||||
let rec read_exact t buf =
|
||||
if Cstruct.length buf > 0 then (
|
||||
let got = single_read t buf in
|
||||
read_exact t (Cstruct.shift buf got)
|
||||
)
|
||||
|
||||
let cstruct_source data : source =
|
||||
object (self)
|
||||
val mutable data = data
|
||||
module Cstruct_source = struct
|
||||
type t = Cstruct.t list ref
|
||||
|
||||
inherit source
|
||||
let create data = ref data
|
||||
|
||||
method private read_source_buffer fn =
|
||||
let read_source_buffer t fn =
|
||||
let rec aux () =
|
||||
match data with
|
||||
match !t with
|
||||
| [] -> raise End_of_file
|
||||
| x :: xs when Cstruct.length x = 0 -> data <- xs; aux ()
|
||||
| x :: xs when Cstruct.length x = 0 -> t := xs; aux ()
|
||||
| xs ->
|
||||
let n = fn xs in
|
||||
data <- Cstruct.shiftv xs n
|
||||
t := Cstruct.shiftv xs n
|
||||
in
|
||||
aux ()
|
||||
|
||||
method! read_methods =
|
||||
[ Read_source_buffer self#read_source_buffer ]
|
||||
let read_methods =
|
||||
[ Read_source_buffer read_source_buffer ]
|
||||
|
||||
method read_into dst =
|
||||
let avail, src = Cstruct.fillv ~dst ~src:data in
|
||||
let single_read t dst =
|
||||
let avail, src = Cstruct.fillv ~dst ~src:!t in
|
||||
if avail = 0 then raise End_of_file;
|
||||
data <- src;
|
||||
t := src;
|
||||
avail
|
||||
end
|
||||
|
||||
let string_source s : source =
|
||||
object
|
||||
val mutable offset = 0
|
||||
|
||||
inherit source
|
||||
|
||||
method read_into dst =
|
||||
if offset = String.length s then raise End_of_file;
|
||||
|
||||
let len = min (Cstruct.length dst) (String.length s - offset) in
|
||||
Cstruct.blit_from_string s offset dst 0 len;
|
||||
offset <- offset + len;
|
||||
len
|
||||
end
|
||||
|
||||
class virtual sink = object (self : <Generic.t; ..>)
|
||||
method probe _ = None
|
||||
method virtual copy : 'a. (#source as 'a) -> unit
|
||||
method write bufs = self#copy (cstruct_source bufs)
|
||||
end
|
||||
|
||||
let write (t : #sink) (bufs : Cstruct.t list) = t#write bufs
|
||||
let cstruct_source =
|
||||
let ops = Pi.source (module Cstruct_source) in
|
||||
fun data -> Resource.T (Cstruct_source.create data, ops)
|
||||
|
||||
let copy (src : #source) (dst : #sink) = dst#copy src
|
||||
module String_source = struct
|
||||
type t = {
|
||||
s : string;
|
||||
mutable offset : int;
|
||||
}
|
||||
|
||||
let single_read t dst =
|
||||
if t.offset = String.length t.s then raise End_of_file;
|
||||
let len = min (Cstruct.length dst) (String.length t.s - t.offset) in
|
||||
Cstruct.blit_from_string t.s t.offset dst 0 len;
|
||||
t.offset <- t.offset + len;
|
||||
len
|
||||
|
||||
let read_methods = []
|
||||
|
||||
let create s = { s; offset = 0 }
|
||||
end
|
||||
|
||||
let string_source =
|
||||
let ops = Pi.source (module String_source) in
|
||||
fun s -> Resource.T (String_source.create s, ops)
|
||||
|
||||
let write (Resource.T (t, ops)) bufs =
|
||||
let module X = (val (Resource.get ops Sink)) in
|
||||
X.write t bufs
|
||||
|
||||
let copy src (Resource.T (t, ops)) =
|
||||
let module X = (val (Resource.get ops Sink)) in
|
||||
X.copy t ~src
|
||||
|
||||
let copy_string s = copy (string_source s)
|
||||
|
||||
let buffer_sink b =
|
||||
object
|
||||
inherit sink
|
||||
module Buffer_sink = struct
|
||||
type t = Buffer.t
|
||||
|
||||
method copy src =
|
||||
let copy t ~src:(Resource.T (src, ops)) =
|
||||
let module Src = (val (Resource.get ops Source)) in
|
||||
let buf = Cstruct.create 4096 in
|
||||
try
|
||||
while true do
|
||||
let got = src#read_into buf in
|
||||
Buffer.add_string b (Cstruct.to_string ~len:got buf)
|
||||
let got = Src.single_read src buf in
|
||||
Buffer.add_string t (Cstruct.to_string ~len:got buf)
|
||||
done
|
||||
with End_of_file -> ()
|
||||
|
||||
method! write bufs =
|
||||
List.iter (fun buf -> Buffer.add_bytes b (Cstruct.to_bytes buf)) bufs
|
||||
end
|
||||
|
||||
class virtual two_way = object (_ : <source; sink; ..>)
|
||||
inherit sink
|
||||
method read_methods = []
|
||||
|
||||
method virtual shutdown : shutdown_command -> unit
|
||||
let write t bufs =
|
||||
List.iter (fun buf -> Buffer.add_bytes t (Cstruct.to_bytes buf)) bufs
|
||||
end
|
||||
|
||||
let shutdown (t : #two_way) = t#shutdown
|
||||
let buffer_sink =
|
||||
let ops = Pi.sink (module Buffer_sink) in
|
||||
fun b -> Resource.T (b, ops)
|
||||
|
||||
type two_way_ty = [source_ty | sink_ty | shutdown_ty]
|
||||
type 'a two_way = ([> two_way_ty] as 'a) r
|
||||
|
||||
let shutdown (Resource.T (t, ops)) cmd =
|
||||
let module X = (val (Resource.get ops Shutdown)) in
|
||||
X.shutdown t cmd
|
||||
|
125
lib_eio/flow.mli
125
lib_eio/flow.mli
@ -4,24 +4,37 @@
|
||||
|
||||
To read structured data (e.g. a line at a time), wrap a source using {!Buf_read}. *)
|
||||
|
||||
(** {2 Reading} *)
|
||||
open Std
|
||||
|
||||
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}. *)
|
||||
|
@ -1,5 +1,7 @@
|
||||
(** Defines types used by file-systems. *)
|
||||
|
||||
open Std
|
||||
|
||||
type path = string
|
||||
|
||||
type error =
|
||||
@ -36,24 +38,32 @@ type create = [
|
||||
]
|
||||
(** If a new file is created, the given permissions are used for it. *)
|
||||
|
||||
type dir_ty = [`Dir]
|
||||
type 'a dir = ([> dir_ty] as 'a) r
|
||||
|
||||
(** Note: use the functions in {!Path} to access directories. *)
|
||||
class virtual dir = object (_ : #Generic.t)
|
||||
method probe _ = None
|
||||
method virtual open_in : sw:Switch.t -> path -> <File.ro; Flow.close>
|
||||
method virtual open_out :
|
||||
module Pi = struct
|
||||
module type DIR = sig
|
||||
type t
|
||||
|
||||
val open_in : t -> sw:Switch.t -> path -> File.ro_ty r
|
||||
|
||||
val open_out :
|
||||
t ->
|
||||
sw:Switch.t ->
|
||||
append:bool ->
|
||||
create:create ->
|
||||
path -> <File.rw; Flow.close>
|
||||
method virtual mkdir : perm:File.Unix_perm.t -> path -> unit
|
||||
method virtual open_dir : sw:Switch.t -> path -> dir_with_close
|
||||
method virtual read_dir : path -> string list
|
||||
method virtual unlink : path -> unit
|
||||
method virtual rmdir : path -> unit
|
||||
method virtual rename : path -> dir -> path -> unit
|
||||
method virtual pp : Format.formatter -> unit
|
||||
end
|
||||
and virtual dir_with_close = object (_ : <Generic.close; ..>)
|
||||
(* This dummy class avoids an "Error: The type < .. > is not an object type" error from the compiler. *)
|
||||
inherit dir
|
||||
path -> File.rw_ty r
|
||||
|
||||
val mkdir : t -> perm:File.Unix_perm.t -> path -> unit
|
||||
val open_dir : t -> sw:Switch.t -> path -> [`Close | dir_ty] r
|
||||
val read_dir : t -> path -> string list
|
||||
val unlink : t -> path -> unit
|
||||
val rmdir : t -> path -> unit
|
||||
val rename : t -> path -> _ dir -> path -> unit
|
||||
val pp : t Fmt.t
|
||||
end
|
||||
|
||||
type (_, _, _) Resource.pi +=
|
||||
| Dir : ('t, (module DIR with type t = 't), [> dir_ty]) Resource.pi
|
||||
end
|
||||
|
@ -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
|
@ -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. *)
|
@ -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
|
||||
|
@ -5,16 +5,19 @@ type copy_method = [
|
||||
| `Read_source_buffer
|
||||
]
|
||||
|
||||
type t = <
|
||||
Eio.Flow.two_way;
|
||||
Eio.Flow.close;
|
||||
module Mock_flow = struct
|
||||
type tag = [`Generic | `Mock]
|
||||
|
||||
type t = {
|
||||
label : string;
|
||||
pp : string Fmt.t;
|
||||
on_close : (unit -> unit) Queue.t;
|
||||
on_read : string Handler.t;
|
||||
on_copy_bytes : int Handler.t;
|
||||
set_copy_method : copy_method -> unit;
|
||||
attach_to_switch : Switch.t -> unit;
|
||||
>
|
||||
mutable copy_method : copy_method;
|
||||
}
|
||||
|
||||
let pp_default f s =
|
||||
let pp_default f s =
|
||||
let rec aux i =
|
||||
let nl =
|
||||
match String.index_from_opt s i '\n' with
|
||||
@ -29,88 +32,105 @@ let pp_default f s =
|
||||
in
|
||||
aux 0
|
||||
|
||||
let rec takev len = function
|
||||
let rec takev len = function
|
||||
| [] -> []
|
||||
| x :: _ when Cstruct.length x >= len -> [Cstruct.sub x 0 len]
|
||||
| x :: xs -> x :: takev (len - Cstruct.length x) xs
|
||||
|
||||
let make ?(pp=pp_default) label =
|
||||
let on_read = Handler.make (`Raise End_of_file) in
|
||||
let on_copy_bytes = Handler.make (`Return 4096) in
|
||||
let copy_method = ref `Read_into in
|
||||
(* Test optimised copying using Read_source_buffer *)
|
||||
let copy_rsb_iovec src =
|
||||
let size = Handler.run on_copy_bytes in
|
||||
let copy_rsb_iovec t src =
|
||||
let size = Handler.run t.on_copy_bytes in
|
||||
let len = min (Cstruct.lenv src) size in
|
||||
let bufs = takev len src in
|
||||
traceln "%s: wrote (rsb) @[<v>%a@]" label (Fmt.Dump.list (Fmt.using Cstruct.to_string pp)) bufs;
|
||||
traceln "%s: wrote (rsb) @[<v>%a@]" t.label (Fmt.Dump.list (Fmt.using Cstruct.to_string t.pp)) bufs;
|
||||
len
|
||||
in
|
||||
let copy_rsb rsb =
|
||||
try while true do rsb copy_rsb_iovec done
|
||||
|
||||
let copy_rsb t rsb =
|
||||
try while true do rsb (copy_rsb_iovec t) done
|
||||
with End_of_file -> ()
|
||||
in
|
||||
|
||||
(* Test fallback copy using buffer. *)
|
||||
let copy_via_buffer src =
|
||||
let copy_via_buffer t src =
|
||||
try
|
||||
while true do
|
||||
let size = Handler.run on_copy_bytes in
|
||||
let size = Handler.run t.on_copy_bytes in
|
||||
let buf = Cstruct.create size in
|
||||
let n = Eio.Flow.single_read src buf in
|
||||
traceln "%s: wrote @[<v>%a@]" label pp (Cstruct.to_string (Cstruct.sub buf 0 n))
|
||||
traceln "%s: wrote @[<v>%a@]" t.label t.pp (Cstruct.to_string (Cstruct.sub buf 0 n))
|
||||
done
|
||||
with End_of_file -> ()
|
||||
in
|
||||
object (self)
|
||||
inherit Eio.Flow.two_way
|
||||
|
||||
val on_close = Queue.create ()
|
||||
let read_methods = []
|
||||
|
||||
method on_read = on_read
|
||||
method on_copy_bytes = on_copy_bytes
|
||||
|
||||
method read_into buf =
|
||||
let data = Handler.run on_read in
|
||||
let single_read t buf =
|
||||
let data = Handler.run t.on_read in
|
||||
let len = String.length data in
|
||||
if Cstruct.length buf < len then
|
||||
Fmt.failwith "%s: read buffer too short for %a!" label pp data;
|
||||
Fmt.failwith "%s: read buffer too short for %a!" t.label t.pp data;
|
||||
Cstruct.blit_from_string data 0 buf 0 len;
|
||||
traceln "%s: read @[<v>%a@]" label pp data;
|
||||
traceln "%s: read @[<v>%a@]" t.label t.pp data;
|
||||
len
|
||||
|
||||
method copy src =
|
||||
match !copy_method with
|
||||
| `Read_into -> copy_via_buffer src
|
||||
let copy t ~src =
|
||||
match t.copy_method with
|
||||
| `Read_into -> copy_via_buffer t src
|
||||
| `Read_source_buffer ->
|
||||
let Eio.Resource.T (src, ops) = src in
|
||||
let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in
|
||||
let try_rsb = function
|
||||
| Eio.Flow.Read_source_buffer rsb -> copy_rsb rsb; true
|
||||
| Eio.Flow.Read_source_buffer rsb -> copy_rsb t (rsb src); true
|
||||
| _ -> false
|
||||
in
|
||||
if not (List.exists try_rsb (Eio.Flow.read_methods src)) then
|
||||
if not (List.exists try_rsb Src.read_methods) then
|
||||
Fmt.failwith "Source does not offer Read_source_buffer optimisation"
|
||||
|
||||
method set_copy_method m =
|
||||
copy_method := m
|
||||
let write t bufs =
|
||||
copy t ~src:(Eio.Flow.cstruct_source bufs)
|
||||
|
||||
method shutdown cmd =
|
||||
traceln "%s: shutdown %s" label @@
|
||||
let shutdown t cmd =
|
||||
traceln "%s: shutdown %s" t.label @@
|
||||
match cmd with
|
||||
| `Receive -> "receive"
|
||||
| `Send -> "send"
|
||||
| `All -> "all"
|
||||
|
||||
method attach_to_switch sw =
|
||||
let hook = Switch.on_release_cancellable sw (fun () -> Eio.Flow.close self) in
|
||||
Queue.add (fun () -> Eio.Switch.remove_hook hook) on_close
|
||||
|
||||
method close =
|
||||
while not (Queue.is_empty on_close) do
|
||||
Queue.take on_close ()
|
||||
let close t =
|
||||
while not (Queue.is_empty t.on_close) do
|
||||
Queue.take t.on_close ()
|
||||
done;
|
||||
traceln "%s: closed" label
|
||||
end
|
||||
traceln "%s: closed" t.label
|
||||
|
||||
let on_read (t:t) = Handler.seq t#on_read
|
||||
let on_copy_bytes (t:t) = Handler.seq t#on_copy_bytes
|
||||
let set_copy_method (t:t) = t#set_copy_method
|
||||
let attach_to_switch (t:t) = t#attach_to_switch
|
||||
let make ?(pp=pp_default) label =
|
||||
{
|
||||
pp;
|
||||
label;
|
||||
on_close = Queue.create ();
|
||||
on_read = Handler.make (`Raise End_of_file);
|
||||
on_copy_bytes = Handler.make (`Return 4096);
|
||||
copy_method = `Read_into;
|
||||
}
|
||||
end
|
||||
|
||||
type ty = [`Generic | `Mock] Eio.Net.stream_socket_ty
|
||||
|
||||
type t = ty r
|
||||
|
||||
type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> Mock_flow.t, ty) Eio.Resource.pi
|
||||
let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t
|
||||
|
||||
let attach_to_switch t sw =
|
||||
let t = raw t in
|
||||
let hook = Switch.on_release_cancellable sw (fun () -> Mock_flow.close t) in
|
||||
Queue.add (fun () -> Eio.Switch.remove_hook hook) t.on_close
|
||||
|
||||
let on_read t = Handler.seq (raw t).on_read
|
||||
let on_copy_bytes t = Handler.seq (raw t).on_copy_bytes
|
||||
let set_copy_method t v = (raw t).copy_method <- v
|
||||
|
||||
let handler = Eio.Resource.handler (
|
||||
H (Type, Fun.id) ::
|
||||
Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module Mock_flow))
|
||||
)
|
||||
|
||||
let make ?pp label : t =
|
||||
Eio.Resource.T (Mock_flow.make ?pp label, handler)
|
||||
|
@ -1,98 +1,138 @@
|
||||
open Eio.Std
|
||||
|
||||
type t = <
|
||||
Eio.Net.t;
|
||||
on_listen : Eio.Net.listening_socket Handler.t;
|
||||
on_connect : Eio.Net.stream_socket Handler.t;
|
||||
on_datagram_socket : Eio.Net.datagram_socket Handler.t;
|
||||
type ty = [`Generic | `Mock] Eio.Net.ty
|
||||
type t = ty r
|
||||
|
||||
module Impl = struct
|
||||
type tag = [`Generic]
|
||||
|
||||
type t = {
|
||||
label : string;
|
||||
on_listen : tag Eio.Net.listening_socket_ty r Handler.t;
|
||||
on_connect : tag Eio.Net.stream_socket_ty r Handler.t;
|
||||
on_datagram_socket : tag Eio.Net.datagram_socket_ty r Handler.t;
|
||||
on_getaddrinfo : Eio.Net.Sockaddr.t list Handler.t;
|
||||
on_getnameinfo : (string * string) Handler.t;
|
||||
>
|
||||
}
|
||||
|
||||
let make label =
|
||||
let on_listen = Handler.make (`Raise (Failure "Mock listen handler not configured")) in
|
||||
let on_connect = Handler.make (`Raise (Failure "Mock connect handler not configured")) in
|
||||
let on_datagram_socket = Handler.make (`Raise (Failure "Mock datagram_socket handler not configured")) in
|
||||
let on_getaddrinfo = Handler.make (`Raise (Failure "Mock getaddrinfo handler not configured")) in
|
||||
let on_getnameinfo = Handler.make (`Raise (Failure "Mock getnameinfo handler not configured")) in
|
||||
object
|
||||
inherit Eio.Net.t
|
||||
let make label = {
|
||||
label;
|
||||
on_listen = Handler.make (`Raise (Failure "Mock listen handler not configured"));
|
||||
on_connect = Handler.make (`Raise (Failure "Mock connect handler not configured"));
|
||||
on_datagram_socket = Handler.make (`Raise (Failure "Mock datagram_socket handler not configured"));
|
||||
on_getaddrinfo = Handler.make (`Raise (Failure "Mock getaddrinfo handler not configured"));
|
||||
on_getnameinfo = Handler.make (`Raise (Failure "Mock getnameinfo handler not configured"));
|
||||
}
|
||||
|
||||
method on_listen = on_listen
|
||||
method on_connect = on_connect
|
||||
method on_datagram_socket = on_datagram_socket
|
||||
method on_getaddrinfo = on_getaddrinfo
|
||||
method on_getnameinfo = on_getnameinfo
|
||||
let on_listen t = t.on_listen
|
||||
let on_connect t = t.on_connect
|
||||
let on_datagram_socket t = t.on_datagram_socket
|
||||
let on_getaddrinfo t = t.on_getaddrinfo
|
||||
let on_getnameinfo t = t.on_getnameinfo
|
||||
|
||||
method listen ~reuse_addr:_ ~reuse_port:_ ~backlog:_ ~sw addr =
|
||||
traceln "%s: listen on %a" label Eio.Net.Sockaddr.pp addr;
|
||||
let socket = Handler.run on_listen in
|
||||
let listen t ~reuse_addr:_ ~reuse_port:_ ~backlog:_ ~sw addr =
|
||||
traceln "%s: listen on %a" t.label Eio.Net.Sockaddr.pp addr;
|
||||
let socket = Handler.run t.on_listen in
|
||||
Switch.on_release sw (fun () -> Eio.Resource.close socket);
|
||||
socket
|
||||
|
||||
let connect t ~sw addr =
|
||||
traceln "%s: connect to %a" t.label Eio.Net.Sockaddr.pp addr;
|
||||
let socket = Handler.run t.on_connect in
|
||||
Switch.on_release sw (fun () -> Eio.Flow.close socket);
|
||||
socket
|
||||
|
||||
method connect ~sw addr =
|
||||
traceln "%s: connect to %a" label Eio.Net.Sockaddr.pp addr;
|
||||
let socket = Handler.run on_connect in
|
||||
Switch.on_release sw (fun () -> Eio.Flow.close socket);
|
||||
socket
|
||||
|
||||
method datagram_socket ~reuse_addr:_ ~reuse_port:_ ~sw addr =
|
||||
let datagram_socket t ~reuse_addr:_ ~reuse_port:_ ~sw addr =
|
||||
(match addr with
|
||||
| #Eio.Net.Sockaddr.datagram as saddr -> traceln "%s: datagram_socket %a" label Eio.Net.Sockaddr.pp saddr
|
||||
| `UdpV4 -> traceln "%s: datagram_socket UDPv4" label
|
||||
| `UdpV6 -> traceln "%s: datagram_socket UDPv6" label
|
||||
| #Eio.Net.Sockaddr.datagram as saddr -> traceln "%s: datagram_socket %a" t.label Eio.Net.Sockaddr.pp saddr
|
||||
| `UdpV4 -> traceln "%s: datagram_socket UDPv4" t.label
|
||||
| `UdpV6 -> traceln "%s: datagram_socket UDPv6" t.label
|
||||
);
|
||||
let socket = Handler.run on_datagram_socket in
|
||||
let socket = Handler.run t.on_datagram_socket in
|
||||
Switch.on_release sw (fun () -> Eio.Flow.close socket);
|
||||
socket
|
||||
|
||||
method getaddrinfo ~service node =
|
||||
traceln "%s: getaddrinfo ~service:%s %s" label service node;
|
||||
Handler.run on_getaddrinfo
|
||||
let getaddrinfo t ~service node =
|
||||
traceln "%s: getaddrinfo ~service:%s %s" t.label service node;
|
||||
Handler.run t.on_getaddrinfo
|
||||
|
||||
method getnameinfo sockaddr =
|
||||
traceln "%s: getnameinfo %a" label Eio.Net.Sockaddr.pp sockaddr;
|
||||
Handler.run on_getnameinfo
|
||||
end
|
||||
let getnameinfo t sockaddr =
|
||||
traceln "%s: getnameinfo %a" t.label Eio.Net.Sockaddr.pp sockaddr;
|
||||
Handler.run t.on_getnameinfo
|
||||
|
||||
type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, ty) Eio.Resource.pi
|
||||
let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t
|
||||
end
|
||||
|
||||
let make : string -> t =
|
||||
let super = Eio.Net.Pi.network (module Impl) in
|
||||
let handler = Eio.Resource.handler (
|
||||
H (Impl.Raw, Fun.id) ::
|
||||
Eio.Resource.bindings super
|
||||
) in
|
||||
fun label -> Eio.Resource.T (Impl.make label, handler)
|
||||
|
||||
let on_connect (t:t) actions =
|
||||
let as_socket x = (x :> Eio.Net.stream_socket) in
|
||||
Handler.seq t#on_connect (List.map (Action.map as_socket) actions)
|
||||
let t = Impl.raw t in
|
||||
let as_socket x = (x :> [`Generic] Eio.Net.stream_socket_ty r) in
|
||||
Handler.seq t.on_connect (List.map (Action.map as_socket) actions)
|
||||
|
||||
let on_listen (t:t) actions =
|
||||
let as_socket x = (x :> Eio.Net.listening_socket) in
|
||||
Handler.seq t#on_listen (List.map (Action.map as_socket) actions)
|
||||
let t = Impl.raw t in
|
||||
let as_socket x = (x :> [`Generic] Eio.Net.listening_socket_ty r) in
|
||||
Handler.seq t.on_listen (List.map (Action.map as_socket) actions)
|
||||
|
||||
let on_datagram_socket (t:t) actions =
|
||||
let as_socket x = (x :> Eio.Net.datagram_socket) in
|
||||
Handler.seq t#on_datagram_socket (List.map (Action.map as_socket) actions)
|
||||
let on_datagram_socket (t:t) (actions : _ r Handler.actions) =
|
||||
let t = Impl.raw t in
|
||||
let as_socket x = (x :> [`Generic] Eio.Net.datagram_socket_ty r) in
|
||||
Handler.seq t.on_datagram_socket (List.map (Action.map as_socket) actions)
|
||||
|
||||
let on_getaddrinfo (t:t) actions = Handler.seq t#on_getaddrinfo actions
|
||||
let on_getaddrinfo (t:t) actions = Handler.seq (Impl.raw t).on_getaddrinfo actions
|
||||
|
||||
let on_getnameinfo (t:t) actions = Handler.seq t#on_getnameinfo actions
|
||||
let on_getnameinfo (t:t) actions = Handler.seq (Impl.raw t).on_getnameinfo actions
|
||||
|
||||
type listening_socket = <
|
||||
Eio.Net.listening_socket;
|
||||
type listening_socket_ty = [`Generic | `Mock] Eio.Net.listening_socket_ty
|
||||
type listening_socket = listening_socket_ty r
|
||||
|
||||
module Listening_socket = struct
|
||||
type t = {
|
||||
label : string;
|
||||
on_accept : (Flow.t * Eio.Net.Sockaddr.stream) Handler.t;
|
||||
>
|
||||
}
|
||||
|
||||
let listening_socket label =
|
||||
let on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured")) in
|
||||
object
|
||||
inherit Eio.Net.listening_socket
|
||||
type tag = [`Generic]
|
||||
|
||||
method on_accept = on_accept
|
||||
let make label =
|
||||
{
|
||||
label;
|
||||
on_accept = Handler.make (`Raise (Failure "Mock accept handler not configured"))
|
||||
}
|
||||
|
||||
method accept ~sw =
|
||||
let socket, addr = Handler.run on_accept in
|
||||
Flow.attach_to_switch socket sw;
|
||||
traceln "%s: accepted connection from %a" label Eio.Net.Sockaddr.pp addr;
|
||||
(socket :> Eio.Net.stream_socket), addr
|
||||
let on_accept t = t.on_accept
|
||||
|
||||
method close =
|
||||
traceln "%s: closed" label
|
||||
end
|
||||
let accept t ~sw =
|
||||
let socket, addr = Handler.run t.on_accept in
|
||||
Flow.attach_to_switch (socket : Flow.t) sw;
|
||||
traceln "%s: accepted connection from %a" t.label Eio.Net.Sockaddr.pp addr;
|
||||
(socket :> tag Eio.Net.stream_socket_ty r), addr
|
||||
|
||||
let on_accept (l:listening_socket) actions =
|
||||
let close t =
|
||||
traceln "%s: closed" t.label
|
||||
|
||||
type (_, _, _) Eio.Resource.pi += Type : ('t, 't -> t, listening_socket_ty) Eio.Resource.pi
|
||||
let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Type t
|
||||
end
|
||||
|
||||
let listening_socket_handler =
|
||||
Eio.Resource.handler @@
|
||||
Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module Listening_socket)) @ [
|
||||
H (Listening_socket.Type, Fun.id);
|
||||
]
|
||||
|
||||
let listening_socket label : listening_socket =
|
||||
Eio.Resource.T (Listening_socket.make label, listening_socket_handler)
|
||||
|
||||
let on_accept l actions =
|
||||
let r = Listening_socket.raw l in
|
||||
let as_accept_pair x = (x :> Flow.t * Eio.Net.Sockaddr.stream) in
|
||||
Handler.seq l#on_accept (List.map (Action.map as_accept_pair) actions)
|
||||
Handler.seq r.on_accept (List.map (Action.map as_accept_pair) actions)
|
||||
|
174
lib_eio/net.ml
174
lib_eio/net.ml
@ -1,3 +1,5 @@
|
||||
open Std
|
||||
|
||||
type connection_failure =
|
||||
| Refused of Exn.Backend.t
|
||||
| No_matching_addresses
|
||||
@ -157,30 +159,114 @@ module Sockaddr = struct
|
||||
Format.fprintf f "udp:%a:%d" Ipaddr.pp_for_uri addr port
|
||||
end
|
||||
|
||||
class virtual socket = object (_ : <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 ->
|
||||
|
160
lib_eio/net.mli
160
lib_eio/net.mli
@ -11,6 +11,8 @@
|
||||
]}
|
||||
*)
|
||||
|
||||
open Std
|
||||
|
||||
type connection_failure =
|
||||
| Refused of Exn.Backend.t
|
||||
| No_matching_addresses
|
||||
@ -100,45 +102,34 @@ module Sockaddr : sig
|
||||
val pp : Format.formatter -> [< t] -> unit
|
||||
end
|
||||
|
||||
(** {2 Provider Interfaces} *)
|
||||
(** {2 Types} *)
|
||||
|
||||
class virtual socket : object (<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
|
||||
|
@ -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
|
||||
|
@ -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). *)
|
||||
|
||||
|
@ -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 ->
|
||||
|
@ -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
35
lib_eio/resource.ml
Normal 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
114
lib_eio/resource.mli
Normal 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
5
lib_eio/std.ml
Normal 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
10
lib_eio/std.mli
Normal 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}. *)
|
@ -1,11 +1,12 @@
|
||||
[@@@alert "-unstable"]
|
||||
|
||||
open Eio.Std
|
||||
|
||||
module Fd = Fd
|
||||
module Resource = Resource
|
||||
module Private = Private
|
||||
|
||||
include Types
|
||||
type socket = Net.stream_socket
|
||||
|
||||
let await_readable = Private.await_readable
|
||||
let await_writable = Private.await_writable
|
||||
@ -32,17 +33,17 @@ module Net = Net
|
||||
|
||||
module Stdenv = struct
|
||||
type base = <
|
||||
stdin : source;
|
||||
stdout : sink;
|
||||
stderr : sink;
|
||||
net : Eio.Net.t;
|
||||
stdin : source_ty r;
|
||||
stdout : sink_ty r;
|
||||
stderr : sink_ty r;
|
||||
net : [`Unix | `Generic] Eio.Net.ty r;
|
||||
domain_mgr : Eio.Domain_manager.t;
|
||||
process_mgr : Process.mgr;
|
||||
clock : Eio.Time.clock;
|
||||
mono_clock : Eio.Time.Mono.t;
|
||||
fs : Eio.Fs.dir Eio.Path.t;
|
||||
cwd : Eio.Fs.dir Eio.Path.t;
|
||||
secure_random : Eio.Flow.source;
|
||||
fs : Eio.Fs.dir_ty Eio.Path.t;
|
||||
cwd : Eio.Fs.dir_ty Eio.Path.t;
|
||||
secure_random : Eio.Flow.source_ty r;
|
||||
debug : Eio.Debug.t;
|
||||
backend_id: string;
|
||||
>
|
||||
|
@ -16,27 +16,58 @@ module Fd = Fd
|
||||
|
||||
(** Eio resources backed by an OS file descriptor. *)
|
||||
module Resource : sig
|
||||
type t = < fd : Fd.t >
|
||||
(** Resources that have FDs are sub-types of [t]. *)
|
||||
type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t
|
||||
(** Resources that have FDs are tagged with [`Unix_fd]. *)
|
||||
|
||||
val fd : <t;..> -> Fd.t
|
||||
type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi
|
||||
|
||||
val fd : _ t -> Fd.t
|
||||
(** [fd t] returns the FD being wrapped by a resource. *)
|
||||
|
||||
type _ Eio.Generic.ty += FD : Fd.t Eio.Generic.ty
|
||||
(** Resources that wrap FDs can handle this in their [probe] method to expose the FD. *)
|
||||
|
||||
val fd_opt : #Eio.Generic.t -> Fd.t option
|
||||
val fd_opt : _ Eio.Resource.t -> Fd.t option
|
||||
(** [fd_opt t] returns the FD being wrapped by a generic resource, if any.
|
||||
|
||||
This just probes [t] using {!extension-FD}. *)
|
||||
|
||||
module type FLOW = sig
|
||||
include Eio.Net.Pi.STREAM_SOCKET
|
||||
include Eio.File.Pi.WRITE with type t := t
|
||||
|
||||
val fd : t -> Fd.t
|
||||
end
|
||||
|
||||
val flow_handler :
|
||||
(module FLOW with type t = 't and type tag = 'tag) ->
|
||||
('t, [`Unix_fd | 'tag Eio.Net.stream_socket_ty | Eio.File.rw_ty]) Eio.Resource.handler
|
||||
|
||||
module type DATAGRAM_SOCKET = sig
|
||||
include Eio.Net.Pi.DATAGRAM_SOCKET
|
||||
|
||||
val fd : t -> Fd.t
|
||||
end
|
||||
|
||||
val datagram_handler :
|
||||
(module DATAGRAM_SOCKET with type t = 't and type tag = 'tag) ->
|
||||
('t, [`Unix_fd | 'tag Eio.Net.datagram_socket_ty]) Eio.Resource.handler
|
||||
|
||||
module type LISTENING_SOCKET = sig
|
||||
include Eio.Net.Pi.LISTENING_SOCKET
|
||||
|
||||
val fd : t -> Fd.t
|
||||
end
|
||||
|
||||
val listening_socket_handler :
|
||||
(module LISTENING_SOCKET with type t = 't and type tag = 'tag) ->
|
||||
('t, [`Unix_fd | 'tag Eio.Net.listening_socket_ty]) Eio.Resource.handler
|
||||
end
|
||||
|
||||
module Net = Net
|
||||
(** Extended network API with support for file descriptors. *)
|
||||
|
||||
type source = < Eio.Flow.source; Resource.t; Eio.Flow.close >
|
||||
type sink = < Eio.Flow.sink; Resource.t; Eio.Flow.close >
|
||||
type socket = Net.stream_socket
|
||||
type source_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.source_ty]
|
||||
type sink_ty = [`Unix_fd | Eio.Resource.close_ty | Eio.Flow.sink_ty]
|
||||
type 'a source = ([> source_ty] as 'a) r
|
||||
type 'a sink = ([> sink_ty] as 'a) r
|
||||
|
||||
val await_readable : Unix.file_descr -> unit
|
||||
(** [await_readable fd] blocks until [fd] is readable (or has an error). *)
|
||||
@ -54,7 +85,7 @@ val run_in_systhread : (unit -> 'a) -> 'a
|
||||
(** [run_in_systhread fn] runs the function [fn] in a newly created system thread (a {! Thread.t}).
|
||||
This allows blocking calls to be made non-blocking. *)
|
||||
|
||||
val pipe : Switch.t -> source * sink
|
||||
val pipe : Switch.t -> source_ty r * sink_ty r
|
||||
(** [pipe sw] returns a connected pair of flows [src] and [sink]. Data written to [sink]
|
||||
can be read from [src].
|
||||
Note that, like all FDs created by Eio, they are both marked as close-on-exec by default. *)
|
||||
@ -65,17 +96,17 @@ module Process = Process
|
||||
(** The set of resources provided to a process on a Unix-compatible system. *)
|
||||
module Stdenv : sig
|
||||
type base = <
|
||||
stdin : source;
|
||||
stdout : sink;
|
||||
stderr : sink;
|
||||
net : Eio.Net.t;
|
||||
stdin : source_ty r;
|
||||
stdout : sink_ty r;
|
||||
stderr : sink_ty r;
|
||||
net : [`Unix | `Generic] Eio.Net.ty r;
|
||||
domain_mgr : Eio.Domain_manager.t;
|
||||
process_mgr : Process.mgr;
|
||||
clock : Eio.Time.clock;
|
||||
mono_clock : Eio.Time.Mono.t;
|
||||
fs : Eio.Fs.dir Eio.Path.t;
|
||||
cwd : Eio.Fs.dir Eio.Path.t;
|
||||
secure_random : Eio.Flow.source;
|
||||
fs : Eio.Fs.dir_ty Eio.Path.t;
|
||||
cwd : Eio.Fs.dir_ty Eio.Path.t;
|
||||
secure_random : Eio.Flow.source_ty r;
|
||||
debug : Eio.Debug.t;
|
||||
backend_id : string;
|
||||
>
|
||||
@ -90,7 +121,7 @@ module Private : sig
|
||||
| Await_readable : Unix.file_descr -> unit Effect.t (** See {!await_readable} *)
|
||||
| Await_writable : Unix.file_descr -> unit Effect.t (** See {!await_writable} *)
|
||||
| Get_monotonic_clock : Eio.Time.Mono.t Effect.t
|
||||
| Pipe : Eio.Switch.t -> (source * sink) Effect.t (** See {!pipe} *)
|
||||
| Pipe : Eio.Switch.t -> (source_ty r * sink_ty r) Effect.t (** See {!pipe} *)
|
||||
|
||||
module Rcfd = Rcfd
|
||||
|
||||
|
@ -1,5 +1,12 @@
|
||||
open Eio.Std
|
||||
|
||||
type stream_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.stream_socket_ty]
|
||||
type datagram_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.datagram_socket_ty]
|
||||
type listening_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.listening_socket_ty]
|
||||
type 'a stream_socket = ([> stream_socket_ty] as 'a) r
|
||||
type 'a datagram_socket = ([> datagram_socket_ty] as 'a) r
|
||||
type 'a listening_socket = ([> listening_socket_ty] as 'a) r
|
||||
|
||||
module Ipaddr = struct
|
||||
let to_unix : _ Eio.Net.Ipaddr.t -> Unix.inet_addr = Obj.magic
|
||||
let of_unix : Unix.inet_addr -> _ Eio.Net.Ipaddr.t = Obj.magic
|
||||
@ -23,14 +30,6 @@ let sockaddr_of_unix_datagram = function
|
||||
let host = Ipaddr.of_unix host in
|
||||
`Udp (host, port)
|
||||
|
||||
class virtual stream_socket = object (_ : <Resource.t; ..>)
|
||||
inherit Eio.Net.stream_socket
|
||||
end
|
||||
|
||||
class virtual datagram_socket = object (_ : <Resource.t; ..>)
|
||||
inherit Eio.Net.datagram_socket
|
||||
end
|
||||
|
||||
let getnameinfo (sockaddr : Eio.Net.Sockaddr.t) =
|
||||
let options =
|
||||
match sockaddr with
|
||||
@ -42,28 +41,30 @@ let getnameinfo (sockaddr : Eio.Net.Sockaddr.t) =
|
||||
let Unix.{ni_hostname; ni_service} = Unix.getnameinfo sockaddr options in
|
||||
(ni_hostname, ni_service))
|
||||
|
||||
class virtual t = object
|
||||
inherit Eio.Net.t
|
||||
|
||||
method getnameinfo = getnameinfo
|
||||
end
|
||||
type t = [`Generic | `Unix] Eio.Net.ty r
|
||||
|
||||
[@@@alert "-unstable"]
|
||||
|
||||
type _ Effect.t +=
|
||||
| Import_socket_stream : Switch.t * bool * Unix.file_descr -> stream_socket Effect.t
|
||||
| Import_socket_datagram : Switch.t * bool * Unix.file_descr -> datagram_socket Effect.t
|
||||
| Import_socket_stream : Switch.t * bool * Unix.file_descr -> stream_socket_ty r Effect.t
|
||||
| Import_socket_datagram : Switch.t * bool * Unix.file_descr -> datagram_socket_ty r Effect.t
|
||||
| Socketpair_stream : Switch.t * Unix.socket_domain * int ->
|
||||
(stream_socket * stream_socket) Effect.t
|
||||
(stream_socket_ty r * stream_socket_ty r) Effect.t
|
||||
| Socketpair_datagram : Switch.t * Unix.socket_domain * int ->
|
||||
(datagram_socket * datagram_socket) Effect.t
|
||||
(datagram_socket_ty r * datagram_socket_ty r) Effect.t
|
||||
|
||||
let import_socket_stream ~sw ~close_unix fd = Effect.perform (Import_socket_stream (sw, close_unix, fd))
|
||||
let open_stream s = (s : _ stream_socket :> [< stream_socket_ty] r)
|
||||
let open_datagram s = (s : _ datagram_socket :> [< datagram_socket_ty] r)
|
||||
|
||||
let import_socket_datagram ~sw ~close_unix fd = Effect.perform (Import_socket_datagram (sw, close_unix, fd))
|
||||
let import_socket_stream ~sw ~close_unix fd =
|
||||
open_stream @@ Effect.perform (Import_socket_stream (sw, close_unix, fd))
|
||||
|
||||
let import_socket_datagram ~sw ~close_unix fd =
|
||||
open_datagram @@ Effect.perform (Import_socket_datagram (sw, close_unix, fd))
|
||||
|
||||
let socketpair_stream ~sw ?(domain=Unix.PF_UNIX) ?(protocol=0) () =
|
||||
Effect.perform (Socketpair_stream (sw, domain, protocol))
|
||||
let a, b = Effect.perform (Socketpair_stream (sw, domain, protocol)) in
|
||||
(open_stream a, open_stream b)
|
||||
|
||||
let socketpair_datagram ~sw ?(domain=Unix.PF_UNIX) ?(protocol=0) () =
|
||||
Effect.perform (Socketpair_datagram (sw, domain, protocol))
|
||||
|
@ -4,19 +4,14 @@ open Eio.Std
|
||||
|
||||
These extend the types in {!Eio.Net} with support for file descriptors. *)
|
||||
|
||||
class virtual stream_socket : object (<Resource.t; ..>)
|
||||
inherit Eio.Net.stream_socket
|
||||
end
|
||||
type stream_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.stream_socket_ty]
|
||||
type datagram_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.datagram_socket_ty]
|
||||
type listening_socket_ty = [`Unix_fd | [`Generic | `Unix] Eio.Net.listening_socket_ty]
|
||||
type 'a stream_socket = ([> stream_socket_ty] as 'a) r
|
||||
type 'a datagram_socket = ([> datagram_socket_ty] as 'a) r
|
||||
type 'a listening_socket = ([> listening_socket_ty] as 'a) r
|
||||
|
||||
class virtual datagram_socket : object (<Resource.t; ..>)
|
||||
inherit Eio.Net.datagram_socket
|
||||
end
|
||||
|
||||
class virtual t : object
|
||||
inherit Eio.Net.t
|
||||
|
||||
method getnameinfo : Eio.Net.Sockaddr.t -> (string * string)
|
||||
end
|
||||
type t = [`Generic | `Unix] Eio.Net.ty r
|
||||
|
||||
(** {2 Unix address conversions}
|
||||
|
||||
@ -39,7 +34,7 @@ end
|
||||
|
||||
(** {2 Creating or importing sockets} *)
|
||||
|
||||
val import_socket_stream : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> stream_socket
|
||||
val import_socket_stream : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> stream_socket_ty r
|
||||
(** [import_socket_stream ~sw ~close_unix:true fd] is an Eio flow that uses [fd].
|
||||
|
||||
It can be cast to e.g. {!source} for a one-way flow.
|
||||
@ -47,7 +42,7 @@ val import_socket_stream : sw:Switch.t -> close_unix:bool -> Unix.file_descr ->
|
||||
|
||||
The [close_unix] and [sw] arguments are passed to {!Fd.of_unix}. *)
|
||||
|
||||
val import_socket_datagram : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> datagram_socket
|
||||
val import_socket_datagram : sw:Switch.t -> close_unix:bool -> Unix.file_descr -> datagram_socket_ty r
|
||||
(** [import_socket_datagram ~sw ~close_unix:true fd] is an Eio datagram socket that uses [fd].
|
||||
|
||||
The socket object will be closed when [sw] finishes.
|
||||
@ -59,7 +54,7 @@ val socketpair_stream :
|
||||
?domain:Unix.socket_domain ->
|
||||
?protocol:int ->
|
||||
unit ->
|
||||
stream_socket * stream_socket
|
||||
stream_socket_ty r * stream_socket_ty r
|
||||
(** [socketpair_stream ~sw ()] returns a connected pair of flows, such that writes to one can be read by the other.
|
||||
|
||||
This creates OS-level resources using [socketpair(2)].
|
||||
@ -70,7 +65,7 @@ val socketpair_datagram :
|
||||
?domain:Unix.socket_domain ->
|
||||
?protocol:int ->
|
||||
unit ->
|
||||
datagram_socket * datagram_socket
|
||||
datagram_socket_ty r * datagram_socket_ty r
|
||||
(** [socketpair_datagram ~sw ()] returns a connected pair of flows, such that writes to one can be read by the other.
|
||||
|
||||
This creates OS-level resources using [socketpair(2)].
|
||||
@ -83,11 +78,11 @@ val getnameinfo : Eio.Net.Sockaddr.t -> (string * string)
|
||||
|
||||
type _ Effect.t +=
|
||||
| Import_socket_stream :
|
||||
Switch.t * bool * Unix.file_descr -> stream_socket Effect.t (** See {!import_socket_stream} *)
|
||||
Switch.t * bool * Unix.file_descr -> stream_socket_ty r Effect.t (** See {!import_socket_stream} *)
|
||||
| Import_socket_datagram :
|
||||
Switch.t * bool * Unix.file_descr -> datagram_socket Effect.t (** See {!import_socket_datagram} *)
|
||||
Switch.t * bool * Unix.file_descr -> datagram_socket_ty r Effect.t (** See {!import_socket_datagram} *)
|
||||
| Socketpair_stream : Eio.Switch.t * Unix.socket_domain * int ->
|
||||
(stream_socket * stream_socket) Effect.t (** See {!socketpair_stream} *)
|
||||
(stream_socket_ty r * stream_socket_ty r) Effect.t (** See {!socketpair_stream} *)
|
||||
| Socketpair_datagram : Eio.Switch.t * Unix.socket_domain * int ->
|
||||
(datagram_socket * datagram_socket) Effect.t (** See {!socketpair_datagram} *)
|
||||
(datagram_socket_ty r * datagram_socket_ty r) Effect.t (** See {!socketpair_datagram} *)
|
||||
[@@alert "-unstable"]
|
||||
|
@ -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)
|
||||
|
@ -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 ->
|
||||
|
@ -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 ->
|
||||
|
@ -1,6 +1,48 @@
|
||||
type t = < fd : Fd.t >
|
||||
type 'a t = ([> `Unix_fd] as 'a) Eio.Resource.t
|
||||
|
||||
type _ Eio.Generic.ty += FD : Fd.t Eio.Generic.ty
|
||||
type ('t, _, _) Eio.Resource.pi += T : ('t, 't -> Fd.t, [> `Unix_fd]) Eio.Resource.pi
|
||||
let fd (Eio.Resource.T (t, ops)) = Eio.Resource.get ops T t
|
||||
|
||||
let fd t = t#fd
|
||||
let fd_opt t = Eio.Generic.probe t FD
|
||||
let fd_opt (Eio.Resource.T (t, ops)) =
|
||||
match Eio.Resource.get_opt ops T with
|
||||
| Some f -> Some (f t)
|
||||
| None -> None
|
||||
|
||||
module type FLOW = sig
|
||||
include Eio.Net.Pi.STREAM_SOCKET
|
||||
include Eio.File.Pi.WRITE with type t := t
|
||||
|
||||
val fd : t -> Fd.t
|
||||
end
|
||||
|
||||
let flow_handler (type t tag) (module X : FLOW with type t = t and type tag = tag) : (t, _) Eio.Resource.handler =
|
||||
Eio.Resource.handler @@
|
||||
Eio.Resource.bindings (Eio.Net.Pi.stream_socket (module X)) @
|
||||
Eio.Resource.bindings (Eio.File.Pi.rw (module X)) @ [
|
||||
H (T, X.fd);
|
||||
]
|
||||
|
||||
module type DATAGRAM_SOCKET = sig
|
||||
include Eio.Net.Pi.DATAGRAM_SOCKET
|
||||
|
||||
val fd : t -> Fd.t
|
||||
end
|
||||
|
||||
let datagram_handler (type t tag) (module X : DATAGRAM_SOCKET with type t = t and type tag = tag) : (t, _) Eio.Resource.handler =
|
||||
Eio.Resource.handler @@
|
||||
Eio.Resource.bindings (Eio.Net.Pi.datagram_socket (module X)) @ [
|
||||
H (T, X.fd);
|
||||
]
|
||||
|
||||
module type LISTENING_SOCKET = sig
|
||||
include Eio.Net.Pi.LISTENING_SOCKET
|
||||
|
||||
val fd : t -> Fd.t
|
||||
end
|
||||
|
||||
let listening_socket_handler (type t tag) (module X : LISTENING_SOCKET with type t = t and type tag = tag)
|
||||
: (t, _) Eio.Resource.handler =
|
||||
Eio.Resource.handler @@
|
||||
Eio.Resource.bindings (Eio.Net.Pi.listening_socket (module X)) @ [
|
||||
H (T, X.fd);
|
||||
]
|
||||
|
@ -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
|
||||
|
@ -29,11 +29,14 @@ module Lf_queue = Eio_utils.Lf_queue
|
||||
|
||||
module Low_level = Low_level
|
||||
|
||||
type _ Eio.Generic.ty += Dir_fd : Low_level.dir_fd Eio.Generic.ty
|
||||
let get_dir_fd_opt t = Eio.Generic.probe t Dir_fd
|
||||
(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check
|
||||
that the new location is within its sandbox. *)
|
||||
type ('t, _, _) Eio.Resource.pi += Dir_fd : ('t, 't -> Low_level.dir_fd, [> `Dir_fd]) Eio.Resource.pi
|
||||
|
||||
type source = Eio_unix.source
|
||||
type sink = Eio_unix.sink
|
||||
let get_dir_fd_opt (Eio.Resource.T (t, ops)) =
|
||||
match Eio.Resource.get_opt ops Dir_fd with
|
||||
| Some f -> Some (f t)
|
||||
| None -> None
|
||||
|
||||
(* When copying between a source with an FD and a sink with an FD, we can share the chunk
|
||||
and avoid copying. *)
|
||||
@ -83,13 +86,13 @@ let copy_with_rsb rsb dst =
|
||||
(* Copy by allocating a chunk from the pre-shared buffer and asking
|
||||
the source to write into it. This used when the other methods
|
||||
aren't available. *)
|
||||
let fallback_copy src dst =
|
||||
let fallback_copy (type src) (module Src : Eio.Flow.Pi.SOURCE with type t = src) src dst =
|
||||
let fallback () =
|
||||
(* No chunks available. Use regular memory instead. *)
|
||||
let buf = Cstruct.create 4096 in
|
||||
try
|
||||
while true do
|
||||
let got = Eio.Flow.single_read src buf in
|
||||
let got = Src.single_read src buf in
|
||||
Low_level.writev dst [Cstruct.sub buf 0 got]
|
||||
done
|
||||
with End_of_file -> ()
|
||||
@ -98,99 +101,127 @@ let fallback_copy src dst =
|
||||
let chunk_cs = Uring.Region.to_cstruct chunk in
|
||||
try
|
||||
while true do
|
||||
let got = Eio.Flow.single_read src chunk_cs in
|
||||
let got = Src.single_read src chunk_cs in
|
||||
Low_level.write dst chunk got
|
||||
done
|
||||
with End_of_file -> ()
|
||||
|
||||
let datagram_socket sock = object
|
||||
inherit Eio.Net.datagram_socket
|
||||
module Datagram_socket = struct
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
method fd = sock
|
||||
type t = Eio_unix.Fd.t
|
||||
|
||||
method close = Fd.close sock
|
||||
let fd t = t
|
||||
|
||||
method send ?dst buf =
|
||||
let close = Eio_unix.Fd.close
|
||||
|
||||
let send t ?dst buf =
|
||||
let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in
|
||||
let sent = Low_level.send_msg sock ?dst buf in
|
||||
let sent = Low_level.send_msg t ?dst buf in
|
||||
assert (sent = Cstruct.lenv buf)
|
||||
|
||||
method recv buf =
|
||||
let addr, recv = Low_level.recv_msg sock [buf] in
|
||||
let recv t buf =
|
||||
let addr, recv = Low_level.recv_msg t [buf] in
|
||||
Eio_unix.Net.sockaddr_of_unix_datagram (Uring.Sockaddr.get addr), recv
|
||||
end
|
||||
|
||||
let flow fd =
|
||||
let is_tty = Fd.use_exn "isatty" fd Unix.isatty in
|
||||
object (_ : <source; sink; ..>)
|
||||
method fd = fd
|
||||
method close = Fd.close fd
|
||||
|
||||
method stat = Low_level.fstat fd
|
||||
|
||||
method probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Eio_unix.Resource.FD -> Some fd
|
||||
| _ -> None
|
||||
|
||||
method read_into buf =
|
||||
if is_tty then (
|
||||
(* Work-around for https://github.com/axboe/liburing/issues/354
|
||||
(should be fixed in Linux 5.14) *)
|
||||
Low_level.await_readable fd
|
||||
);
|
||||
Low_level.readv fd [buf]
|
||||
|
||||
method pread ~file_offset bufs =
|
||||
Low_level.readv ~file_offset fd bufs
|
||||
|
||||
method pwrite ~file_offset bufs =
|
||||
Low_level.writev_single ~file_offset fd bufs
|
||||
|
||||
method read_methods = []
|
||||
|
||||
method write bufs = Low_level.writev fd bufs
|
||||
|
||||
method copy src =
|
||||
match Eio_unix.Resource.fd_opt src with
|
||||
| Some src -> fast_copy_try_splice src fd
|
||||
| None ->
|
||||
let rec aux = function
|
||||
| Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb rsb fd
|
||||
| _ :: xs -> aux xs
|
||||
| [] -> fallback_copy src fd
|
||||
in
|
||||
aux (Eio.Flow.read_methods src)
|
||||
|
||||
method shutdown cmd =
|
||||
Low_level.shutdown fd @@ match cmd with
|
||||
let shutdown t cmd =
|
||||
Low_level.shutdown t @@ match cmd with
|
||||
| `Receive -> Unix.SHUTDOWN_RECEIVE
|
||||
| `Send -> Unix.SHUTDOWN_SEND
|
||||
| `All -> Unix.SHUTDOWN_ALL
|
||||
end
|
||||
end
|
||||
|
||||
let source fd = (flow fd :> source)
|
||||
let sink fd = (flow fd :> sink)
|
||||
let datagram_handler = Eio_unix.Resource.datagram_handler (module Datagram_socket)
|
||||
|
||||
let listening_socket fd = object
|
||||
inherit Eio.Net.listening_socket
|
||||
let datagram_socket fd =
|
||||
Eio.Resource.T (fd, datagram_handler)
|
||||
|
||||
method close = Fd.close fd
|
||||
module Flow = struct
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
method accept ~sw =
|
||||
type t = Eio_unix.Fd.t
|
||||
|
||||
let fd t = t
|
||||
|
||||
let close = Eio_unix.Fd.close
|
||||
|
||||
let is_tty t = Fd.use_exn "isatty" t Unix.isatty
|
||||
|
||||
let stat = Low_level.fstat
|
||||
|
||||
let single_read t buf =
|
||||
if is_tty t then (
|
||||
(* Work-around for https://github.com/axboe/liburing/issues/354
|
||||
(should be fixed in Linux 5.14) *)
|
||||
Low_level.await_readable t
|
||||
);
|
||||
Low_level.readv t [buf]
|
||||
|
||||
let pread t ~file_offset bufs =
|
||||
Low_level.readv ~file_offset t bufs
|
||||
|
||||
let pwrite t ~file_offset bufs =
|
||||
Low_level.writev_single ~file_offset t bufs
|
||||
|
||||
let read_methods = []
|
||||
|
||||
let write t bufs = Low_level.writev t bufs
|
||||
|
||||
let copy t ~src =
|
||||
match Eio_unix.Resource.fd_opt src with
|
||||
| Some src -> fast_copy_try_splice src t
|
||||
| None ->
|
||||
let Eio.Resource.T (src, ops) = src in
|
||||
let module Src = (val (Eio.Resource.get ops Eio.Flow.Pi.Source)) in
|
||||
let rec aux = function
|
||||
| Eio.Flow.Read_source_buffer rsb :: _ -> copy_with_rsb (rsb src) t
|
||||
| _ :: xs -> aux xs
|
||||
| [] -> fallback_copy (module Src) src t
|
||||
in
|
||||
aux Src.read_methods
|
||||
|
||||
let shutdown t cmd =
|
||||
Low_level.shutdown t @@ match cmd with
|
||||
| `Receive -> Unix.SHUTDOWN_RECEIVE
|
||||
| `Send -> Unix.SHUTDOWN_SEND
|
||||
| `All -> Unix.SHUTDOWN_ALL
|
||||
end
|
||||
|
||||
let flow_handler = Eio_unix.Resource.flow_handler (module Flow)
|
||||
|
||||
let flow fd =
|
||||
let r = Eio.Resource.T (fd, flow_handler) in
|
||||
(r : [Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :>
|
||||
[< Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r)
|
||||
|
||||
let source fd = (flow fd :> _ Eio_unix.source)
|
||||
let sink fd = (flow fd :> _ Eio_unix.sink)
|
||||
|
||||
module Listening_socket = struct
|
||||
type t = Fd.t
|
||||
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
let fd t = t
|
||||
|
||||
let close = Fd.close
|
||||
|
||||
let accept t ~sw =
|
||||
Switch.check sw;
|
||||
let client, client_addr = Low_level.accept ~sw fd in
|
||||
let client, client_addr = Low_level.accept ~sw t in
|
||||
let client_addr = match client_addr with
|
||||
| Unix.ADDR_UNIX path -> `Unix path
|
||||
| Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port)
|
||||
in
|
||||
let flow = (flow client :> Eio.Net.stream_socket) in
|
||||
let flow = (flow client :> _ Eio.Net.stream_socket) in
|
||||
flow, client_addr
|
||||
|
||||
method! probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Eio_unix.Resource.FD -> Some fd
|
||||
| _ -> None
|
||||
end
|
||||
|
||||
let listening_handler = Eio_unix.Resource.listening_socket_handler (module Listening_socket)
|
||||
|
||||
let listening_socket fd =
|
||||
Eio.Resource.T (fd, listening_handler)
|
||||
|
||||
let socket_domain_of = function
|
||||
| `Unix _ -> Unix.PF_UNIX
|
||||
| `UdpV4 -> Unix.PF_INET
|
||||
@ -206,12 +237,13 @@ let connect ~sw connect_addr =
|
||||
let sock_unix = Unix.socket ~cloexec:true (socket_domain_of connect_addr) Unix.SOCK_STREAM 0 in
|
||||
let sock = Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in
|
||||
Low_level.connect sock addr;
|
||||
(flow sock :> Eio.Net.stream_socket)
|
||||
(flow sock :> _ Eio_unix.Net.stream_socket)
|
||||
|
||||
let net = object
|
||||
inherit Eio_unix.Net.t
|
||||
module Impl = struct
|
||||
type t = unit
|
||||
type tag = [`Unix | `Generic]
|
||||
|
||||
method listen ~reuse_addr ~reuse_port ~backlog ~sw listen_addr =
|
||||
let listen () ~reuse_addr ~reuse_port ~backlog ~sw listen_addr =
|
||||
if reuse_addr then (
|
||||
match listen_addr with
|
||||
| `Tcp _ -> ()
|
||||
@ -238,11 +270,11 @@ let net = object
|
||||
Unix.setsockopt sock_unix Unix.SO_REUSEPORT true;
|
||||
Unix.bind sock_unix addr;
|
||||
Unix.listen sock_unix backlog;
|
||||
listening_socket sock
|
||||
(listening_socket sock :> _ Eio.Net.listening_socket_ty r)
|
||||
|
||||
method connect = connect
|
||||
let connect () ~sw addr = (connect ~sw addr :> [`Generic | `Unix] Eio.Net.stream_socket_ty r)
|
||||
|
||||
method datagram_socket ~reuse_addr ~reuse_port ~sw saddr =
|
||||
let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr =
|
||||
if reuse_addr then (
|
||||
match saddr with
|
||||
| `Udp _ | `UdpV4 | `UdpV6 -> ()
|
||||
@ -265,11 +297,16 @@ let net = object
|
||||
Unix.bind sock_unix addr
|
||||
| `UdpV4 | `UdpV6 -> ()
|
||||
end;
|
||||
(datagram_socket sock :> Eio.Net.datagram_socket)
|
||||
(datagram_socket sock :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r)
|
||||
|
||||
method getaddrinfo = Low_level.getaddrinfo
|
||||
let getaddrinfo () = Low_level.getaddrinfo
|
||||
let getnameinfo () = Eio_unix.Net.getnameinfo
|
||||
end
|
||||
|
||||
let net =
|
||||
let handler = Eio.Net.Pi.network (module Impl) in
|
||||
Eio.Resource.T ((), handler)
|
||||
|
||||
type stdenv = Eio_unix.Stdenv.base
|
||||
|
||||
module Process = Low_level.Process
|
||||
@ -377,22 +414,31 @@ let clock = object
|
||||
Eio.Time.Mono.sleep mono_clock d
|
||||
end
|
||||
|
||||
class dir ~label (fd : Low_level.dir_fd) = object
|
||||
inherit Eio.Fs.dir
|
||||
module rec Dir : sig
|
||||
include Eio.Fs.Pi.DIR
|
||||
|
||||
method! probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Dir_fd -> Some fd
|
||||
| _ -> None
|
||||
val v : label:string -> Low_level.dir_fd -> t
|
||||
|
||||
method open_in ~sw path =
|
||||
let fd = Low_level.openat ~sw fd path
|
||||
val close : t -> unit
|
||||
|
||||
val fd : t -> Low_level.dir_fd
|
||||
end = struct
|
||||
type t = {
|
||||
fd : Low_level.dir_fd;
|
||||
label : string;
|
||||
}
|
||||
|
||||
let v ~label fd = { fd; label }
|
||||
|
||||
let open_in t ~sw path =
|
||||
let fd = Low_level.openat ~sw t.fd path
|
||||
~access:`R
|
||||
~flags:Uring.Open_flags.cloexec
|
||||
~perm:0
|
||||
in
|
||||
(flow fd :> <Eio.File.ro; Eio.Flow.close>)
|
||||
(flow fd :> Eio.File.ro_ty r)
|
||||
|
||||
method open_out ~sw ~append ~create path =
|
||||
let open_out t ~sw ~append ~create path =
|
||||
let perm, flags =
|
||||
match create with
|
||||
| `Never -> 0, Uring.Open_flags.empty
|
||||
@ -401,56 +447,75 @@ class dir ~label (fd : Low_level.dir_fd) = object
|
||||
| `Exclusive perm -> perm, Uring.Open_flags.(creat + excl)
|
||||
in
|
||||
let flags = if append then Uring.Open_flags.(flags + append) else flags in
|
||||
let fd = Low_level.openat ~sw fd path
|
||||
let fd = Low_level.openat ~sw t.fd path
|
||||
~access:`RW
|
||||
~flags:Uring.Open_flags.(cloexec + flags)
|
||||
~perm
|
||||
in
|
||||
(flow fd :> <Eio.File.rw; Eio.Flow.close>)
|
||||
(flow fd :> Eio.File.rw_ty r)
|
||||
|
||||
method open_dir ~sw path =
|
||||
let fd = Low_level.openat ~sw ~seekable:false fd (if path = "" then "." else path)
|
||||
let open_dir t ~sw path =
|
||||
let fd = Low_level.openat ~sw ~seekable:false t.fd (if path = "" then "." else path)
|
||||
~access:`R
|
||||
~flags:Uring.Open_flags.(cloexec + path + directory)
|
||||
~perm:0
|
||||
in
|
||||
let label = Filename.basename path in
|
||||
(new dir ~label (Low_level.FD fd) :> <Eio.Fs.dir; Eio.Flow.close>)
|
||||
let d = v ~label (Low_level.FD fd) in
|
||||
Eio.Resource.T (d, Dir_handler.v)
|
||||
|
||||
method mkdir ~perm path = Low_level.mkdir_beneath ~perm fd path
|
||||
let mkdir t ~perm path = Low_level.mkdir_beneath ~perm t.fd path
|
||||
|
||||
method read_dir path =
|
||||
let read_dir t path =
|
||||
Switch.run @@ fun sw ->
|
||||
let fd = Low_level.open_dir ~sw fd (if path = "" then "." else path) in
|
||||
let fd = Low_level.open_dir ~sw t.fd (if path = "" then "." else path) in
|
||||
Low_level.read_dir fd
|
||||
|
||||
method close =
|
||||
match fd with
|
||||
let close t =
|
||||
match t.fd with
|
||||
| FD x -> Fd.close x
|
||||
| Cwd | Fs -> failwith "Can't close non-FD directory!"
|
||||
|
||||
method unlink path = Low_level.unlink ~rmdir:false fd path
|
||||
method rmdir path = Low_level.unlink ~rmdir:true fd path
|
||||
let unlink t path = Low_level.unlink ~rmdir:false t.fd path
|
||||
let rmdir t path = Low_level.unlink ~rmdir:true t.fd path
|
||||
|
||||
method rename old_path t2 new_path =
|
||||
let rename t old_path t2 new_path =
|
||||
match get_dir_fd_opt t2 with
|
||||
| Some fd2 -> Low_level.rename fd old_path fd2 new_path
|
||||
| Some fd2 -> Low_level.rename t.fd old_path fd2 new_path
|
||||
| None -> raise (Unix.Unix_error (Unix.EXDEV, "rename-dst", new_path))
|
||||
|
||||
method pp f = Fmt.string f (String.escaped label)
|
||||
let pp f t = Fmt.string f (String.escaped t.label)
|
||||
|
||||
let fd t = t.fd
|
||||
end
|
||||
and Dir_handler : sig
|
||||
val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler
|
||||
end = struct
|
||||
let v = Eio.Resource.handler [
|
||||
H (Eio.Fs.Pi.Dir, (module Dir));
|
||||
H (Eio.Resource.Close, Dir.close);
|
||||
H (Dir_fd, Dir.fd);
|
||||
]
|
||||
end
|
||||
|
||||
let secure_random = object
|
||||
inherit Eio.Flow.source
|
||||
method read_into buf = Low_level.getrandom buf; Cstruct.length buf
|
||||
let dir ~label fd = Eio.Resource.T (Dir.v ~label fd, Dir_handler.v)
|
||||
|
||||
module Secure_random = struct
|
||||
type t = unit
|
||||
let single_read () buf = Low_level.getrandom buf; Cstruct.length buf
|
||||
let read_methods = []
|
||||
end
|
||||
|
||||
let secure_random =
|
||||
let ops = Eio.Flow.Pi.source (module Secure_random) in
|
||||
Eio.Resource.T ((), ops)
|
||||
|
||||
let stdenv ~run_event_loop =
|
||||
let stdin = source Eio_unix.Fd.stdin in
|
||||
let stdout = sink Eio_unix.Fd.stdout in
|
||||
let stderr = sink Eio_unix.Fd.stderr in
|
||||
let fs = (new dir ~label:"fs" Fs, "") in
|
||||
let cwd = (new dir ~label:"cwd" Cwd, "") in
|
||||
let fs = (dir ~label:"fs" Fs, "") in
|
||||
let cwd = (dir ~label:"cwd" Cwd, "") in
|
||||
object (_ : stdenv)
|
||||
method stdin = stdin
|
||||
method stdout = stdout
|
||||
@ -460,8 +525,8 @@ let stdenv ~run_event_loop =
|
||||
method domain_mgr = domain_mgr ~run_event_loop
|
||||
method clock = clock
|
||||
method mono_clock = mono_clock
|
||||
method fs = (fs :> Eio.Fs.dir Eio.Path.t)
|
||||
method cwd = (cwd :> Eio.Fs.dir Eio.Path.t)
|
||||
method fs = (fs :> Eio.Fs.dir_ty Eio.Path.t)
|
||||
method cwd = (cwd :> Eio.Fs.dir_ty Eio.Path.t)
|
||||
method secure_random = secure_random
|
||||
method debug = Eio.Private.Debug.v
|
||||
method backend_id = "linux"
|
||||
@ -476,7 +541,7 @@ let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a =
|
||||
| Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k mono_clock)
|
||||
| Eio_unix.Net.Import_socket_stream (sw, close_unix, fd) -> Some (fun k ->
|
||||
let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in
|
||||
continue k (flow fd :> Eio_unix.Net.stream_socket)
|
||||
continue k (flow fd :> _ Eio_unix.Net.stream_socket)
|
||||
)
|
||||
| Eio_unix.Net.Import_socket_datagram (sw, close_unix, fd) -> Some (fun k ->
|
||||
let fd = Fd.of_unix ~sw ~seekable:false ~close_unix fd in
|
||||
@ -487,7 +552,7 @@ let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a =
|
||||
let a, b = Unix.socketpair ~cloexec:true domain Unix.SOCK_STREAM protocol in
|
||||
let a = Fd.of_unix ~sw ~seekable:false ~close_unix:true a |> flow in
|
||||
let b = Fd.of_unix ~sw ~seekable:false ~close_unix:true b |> flow in
|
||||
((a :> Eio_unix.Net.stream_socket), (b :> Eio_unix.Net.stream_socket))
|
||||
((a :> _ Eio_unix.Net.stream_socket), (b :> _ Eio_unix.Net.stream_socket))
|
||||
with
|
||||
| r -> continue k r
|
||||
| exception Unix.Unix_error (code, name, arg) ->
|
||||
@ -498,7 +563,7 @@ let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a =
|
||||
let a, b = Unix.socketpair ~cloexec:true domain Unix.SOCK_DGRAM protocol in
|
||||
let a = Fd.of_unix ~sw ~seekable:false ~close_unix:true a |> datagram_socket in
|
||||
let b = Fd.of_unix ~sw ~seekable:false ~close_unix:true b |> datagram_socket in
|
||||
((a :> Eio_unix.Net.datagram_socket), (b :> Eio_unix.Net.datagram_socket))
|
||||
((a :> _ Eio_unix.Net.datagram_socket), (b :> _ Eio_unix.Net.datagram_socket))
|
||||
with
|
||||
| r -> continue k r
|
||||
| exception Unix.Unix_error (code, name, arg) ->
|
||||
@ -507,8 +572,8 @@ let run_event_loop (type a) ?fallback config (main : _ -> a) arg : a =
|
||||
| Eio_unix.Private.Pipe sw -> Some (fun k ->
|
||||
match
|
||||
let r, w = Low_level.pipe ~sw in
|
||||
let r = (flow r :> Eio_unix.source) in
|
||||
let w = (flow w :> Eio_unix.sink) in
|
||||
let r = (flow r :> _ Eio_unix.source) in
|
||||
let w = (flow w :> _ Eio_unix.sink) in
|
||||
(r, w)
|
||||
with
|
||||
| r -> continue k r
|
||||
|
@ -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 ->
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -1,8 +1,15 @@
|
||||
open Eio.Std
|
||||
|
||||
module Fd = Eio_unix.Fd
|
||||
|
||||
let fstat fd =
|
||||
module Impl = struct
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
type t = Eio_unix.Fd.t
|
||||
|
||||
let stat t =
|
||||
try
|
||||
let ust = Low_level.fstat fd in
|
||||
let ust = Low_level.fstat t in
|
||||
let st_kind : Eio.File.Stat.kind =
|
||||
match ust.st_kind with
|
||||
| Unix.S_REG -> `Regular_file
|
||||
@ -29,35 +36,35 @@ let fstat fd =
|
||||
}
|
||||
with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg
|
||||
|
||||
let write_bufs fd bufs =
|
||||
let write t bufs =
|
||||
try
|
||||
let rec loop = function
|
||||
| [] -> ()
|
||||
| bufs ->
|
||||
let wrote = Low_level.writev fd (Array.of_list bufs) in
|
||||
let wrote = Low_level.writev t (Array.of_list bufs) in
|
||||
loop (Cstruct.shiftv bufs wrote)
|
||||
in
|
||||
loop bufs
|
||||
with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
|
||||
|
||||
let copy src dst =
|
||||
let copy dst ~src =
|
||||
let buf = Cstruct.create 4096 in
|
||||
try
|
||||
while true do
|
||||
let got = Eio.Flow.single_read src buf in
|
||||
write_bufs dst [Cstruct.sub buf 0 got]
|
||||
write dst [Cstruct.sub buf 0 got]
|
||||
done
|
||||
with End_of_file -> ()
|
||||
|
||||
let read fd buf =
|
||||
match Low_level.readv fd [| buf |] with
|
||||
let single_read t buf =
|
||||
match Low_level.readv t [| buf |] with
|
||||
| 0 -> raise End_of_file
|
||||
| got -> got
|
||||
| exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg)
|
||||
|
||||
let shutdown fd cmd =
|
||||
let shutdown t cmd =
|
||||
try
|
||||
Low_level.shutdown fd @@ match cmd with
|
||||
Low_level.shutdown t @@ match cmd with
|
||||
| `Receive -> Unix.SHUTDOWN_RECEIVE
|
||||
| `Send -> Unix.SHUTDOWN_SEND
|
||||
| `All -> Unix.SHUTDOWN_ALL
|
||||
@ -65,34 +72,37 @@ let shutdown fd cmd =
|
||||
| Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
|
||||
| Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
|
||||
|
||||
let of_fd fd = object (_ : <Eio_unix.Net.stream_socket; Eio.File.rw>)
|
||||
method fd = fd
|
||||
let read_methods = []
|
||||
|
||||
method read_methods = []
|
||||
method copy src = copy src fd
|
||||
|
||||
method pread ~file_offset bufs =
|
||||
let got = Low_level.preadv ~file_offset fd (Array.of_list bufs) in
|
||||
let pread t ~file_offset bufs =
|
||||
let got = Low_level.preadv ~file_offset t (Array.of_list bufs) in
|
||||
if got = 0 then raise End_of_file
|
||||
else got
|
||||
|
||||
method pwrite ~file_offset bufs = Low_level.pwritev ~file_offset fd (Array.of_list bufs)
|
||||
let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (Array.of_list bufs)
|
||||
|
||||
method stat = fstat fd
|
||||
method read_into buf = read fd buf
|
||||
method write bufs = write_bufs fd bufs
|
||||
method shutdown cmd = shutdown fd cmd
|
||||
method close = Fd.close fd
|
||||
let fd t = t
|
||||
|
||||
method probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Eio_unix.Resource.FD -> Some fd
|
||||
| _ -> None
|
||||
let close = Eio_unix.Fd.close
|
||||
end
|
||||
|
||||
let secure_random = object
|
||||
inherit Eio.Flow.source
|
||||
let handler = Eio_unix.Resource.flow_handler (module Impl)
|
||||
|
||||
method read_into buf =
|
||||
let of_fd fd =
|
||||
let r = Eio.Resource.T (fd, handler) in
|
||||
(r : [`Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :>
|
||||
[< `Unix_fd | Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r)
|
||||
|
||||
module Secure_random = struct
|
||||
type t = unit
|
||||
|
||||
let single_read () buf =
|
||||
Low_level.getrandom buf;
|
||||
Cstruct.length buf
|
||||
|
||||
let read_methods = []
|
||||
end
|
||||
|
||||
let secure_random =
|
||||
let ops = Eio.Flow.Pi.source (module Secure_random) in
|
||||
Eio.Resource.T ((), ops)
|
||||
|
@ -26,120 +26,35 @@ open Eio.Std
|
||||
|
||||
module Fd = Eio_unix.Fd
|
||||
|
||||
class virtual posix_dir = object
|
||||
inherit Eio.Fs.dir
|
||||
module rec Dir : sig
|
||||
include Eio.Fs.Pi.DIR
|
||||
|
||||
val virtual opt_nofollow : Low_level.Open_flags.t
|
||||
(** Extra flags for open operations. Sandboxes will add [O_NOFOLLOW] here. *)
|
||||
val v : label:string -> sandbox:bool -> string -> t
|
||||
|
||||
method virtual private resolve : string -> string
|
||||
(** [resolve path] returns the real path that should be used to access [path].
|
||||
val resolve : t -> string -> string
|
||||
(** [resolve t path] returns the real path that should be used to access [path].
|
||||
For sandboxes, this is [realpath path] (and it checks that it is within the sandbox).
|
||||
For unrestricted access, this is the identity function. *)
|
||||
For unrestricted access, this returns [path] unchanged.
|
||||
@raise Eio.Fs.Permission_denied if sandboxed and [path] is outside of [dir_path]. *)
|
||||
|
||||
method virtual with_parent_dir : 'a. (string -> (Fd.t option -> string -> 'a) -> 'a)
|
||||
(** [with_parent_dir path fn] runs [fn dir_fd rel_path],
|
||||
val with_parent_dir : t -> string -> (Fd.t option -> string -> 'a) -> 'a
|
||||
(** [with_parent_dir t path fn] runs [fn dir_fd rel_path],
|
||||
where [rel_path] accessed relative to [dir_fd] gives access to [path].
|
||||
For unrestricted access, this just runs [fn None path].
|
||||
For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *)
|
||||
end
|
||||
end = struct
|
||||
type t = {
|
||||
dir_path : string;
|
||||
sandbox : bool;
|
||||
label : string;
|
||||
mutable closed : bool;
|
||||
}
|
||||
|
||||
(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check
|
||||
that the new location is within its sandbox. *)
|
||||
type _ Eio.Generic.ty += Posix_dir : posix_dir Eio.Generic.ty
|
||||
let as_posix_dir x = Eio.Generic.probe x Posix_dir
|
||||
|
||||
class virtual dir ~label = object (self)
|
||||
inherit posix_dir
|
||||
|
||||
val mutable closed = false
|
||||
|
||||
method! probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Posix_dir -> Some (self :> posix_dir)
|
||||
| _ -> None
|
||||
|
||||
method open_in ~sw path =
|
||||
let fd = Err.run (Low_level.openat ~mode:0 ~sw (self#resolve path)) Low_level.Open_flags.(opt_nofollow + rdonly) in
|
||||
(Flow.of_fd fd :> <Eio.File.ro; Eio.Flow.close>)
|
||||
|
||||
method open_out ~sw ~append ~create path =
|
||||
let mode, flags =
|
||||
match create with
|
||||
| `Never -> 0, Low_level.Open_flags.empty
|
||||
| `If_missing perm -> perm, Low_level.Open_flags.creat
|
||||
| `Or_truncate perm -> perm, Low_level.Open_flags.(creat + trunc)
|
||||
| `Exclusive perm -> perm, Low_level.Open_flags.(creat + excl)
|
||||
in
|
||||
let flags = if append then Low_level.Open_flags.(flags + append) else flags in
|
||||
let flags = Low_level.Open_flags.(flags + rdwr + opt_nofollow) in
|
||||
match
|
||||
self#with_parent_dir path @@ fun dirfd path ->
|
||||
Low_level.openat ?dirfd ~sw ~mode path flags
|
||||
with
|
||||
| fd -> (Flow.of_fd fd :> <Eio.File.rw; Eio.Flow.close>)
|
||||
| exception Unix.Unix_error (ELOOP, _, _) ->
|
||||
(* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that).
|
||||
A leaf symlink might be OK, but we need to check it's still in the sandbox.
|
||||
todo: possibly we should limit the number of redirections here, like the kernel does. *)
|
||||
let target = Unix.readlink path in
|
||||
let full_target =
|
||||
if Filename.is_relative target then
|
||||
Filename.concat (Filename.dirname path) target
|
||||
else target
|
||||
in
|
||||
self#open_out ~sw ~append ~create full_target
|
||||
| exception Unix.Unix_error (code, name, arg) ->
|
||||
raise (Err.wrap code name arg)
|
||||
|
||||
method mkdir ~perm path =
|
||||
self#with_parent_dir path @@ fun dirfd path ->
|
||||
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
|
||||
|
||||
method unlink path =
|
||||
self#with_parent_dir path @@ fun dirfd path ->
|
||||
Err.run (Low_level.unlink ?dirfd ~dir:false) path
|
||||
|
||||
method rmdir path =
|
||||
self#with_parent_dir path @@ fun dirfd path ->
|
||||
Err.run (Low_level.unlink ?dirfd ~dir:true) path
|
||||
|
||||
method read_dir path =
|
||||
(* todo: need fdopendir here to avoid races *)
|
||||
let path = self#resolve path in
|
||||
Err.run Low_level.readdir path
|
||||
|> Array.to_list
|
||||
|
||||
method rename old_path new_dir new_path =
|
||||
match as_posix_dir new_dir with
|
||||
| None -> invalid_arg "Target is not an eio_posix directory!"
|
||||
| Some new_dir ->
|
||||
self#with_parent_dir old_path @@ fun old_dir old_path ->
|
||||
new_dir#with_parent_dir new_path @@ fun new_dir new_path ->
|
||||
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
|
||||
|
||||
method open_dir ~sw path =
|
||||
Switch.check sw;
|
||||
let label = Filename.basename path in
|
||||
let d = new sandbox ~label (self#resolve path) in
|
||||
Switch.on_release sw (fun () -> d#close);
|
||||
(d :> Eio.Fs.dir_with_close)
|
||||
|
||||
method close = closed <- true
|
||||
|
||||
method pp f = Fmt.string f (String.escaped label)
|
||||
end
|
||||
|
||||
and sandbox ~label dir_path = object (self)
|
||||
inherit dir ~label
|
||||
|
||||
val opt_nofollow = Low_level.Open_flags.nofollow
|
||||
|
||||
(* Resolve a relative path to an absolute one, with no symlinks.
|
||||
@raise Eio.Fs.Permission_denied if it's outside of [dir_path]. *)
|
||||
method private resolve path =
|
||||
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
|
||||
let resolve t path =
|
||||
if t.sandbox then (
|
||||
if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path;
|
||||
if Filename.is_relative path then (
|
||||
let dir_path = Err.run Low_level.realpath dir_path in
|
||||
let dir_path = Err.run Low_level.realpath t.dir_path in
|
||||
let full = Err.run Low_level.realpath (Filename.concat dir_path path) in
|
||||
let prefix_len = String.length dir_path + 1 in
|
||||
if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then
|
||||
@ -151,9 +66,11 @@ and sandbox ~label dir_path = object (self)
|
||||
) else (
|
||||
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
|
||||
)
|
||||
) else path
|
||||
|
||||
method with_parent_dir path fn =
|
||||
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
|
||||
let with_parent_dir t path fn =
|
||||
if t.sandbox then (
|
||||
if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path;
|
||||
let dir, leaf = Filename.dirname path, Filename.basename path in
|
||||
if leaf = ".." then (
|
||||
(* We could be smarter here and normalise the path first, but '..'
|
||||
@ -161,22 +78,110 @@ and sandbox ~label dir_path = object (self)
|
||||
anyway. *)
|
||||
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
|
||||
) else (
|
||||
let dir = self#resolve dir in
|
||||
let dir = resolve t dir in
|
||||
Switch.run @@ fun sw ->
|
||||
let dirfd = Low_level.openat ~sw ~mode:0 dir Low_level.Open_flags.(directory + rdonly + nofollow) in
|
||||
fn (Some dirfd) leaf
|
||||
)
|
||||
) else fn None path
|
||||
|
||||
let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false }
|
||||
|
||||
(* Sandboxes use [O_NOFOLLOW] when opening files ([resolve] already removed any symlinks).
|
||||
This avoids a race where symlink might be added after [realpath] returns. *)
|
||||
let opt_nofollow t =
|
||||
if t.sandbox then Low_level.Open_flags.nofollow else Low_level.Open_flags.empty
|
||||
|
||||
let open_in t ~sw path =
|
||||
let fd = Err.run (Low_level.openat ~mode:0 ~sw (resolve t path)) Low_level.Open_flags.(opt_nofollow t + rdonly) in
|
||||
(Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t)
|
||||
|
||||
let rec open_out t ~sw ~append ~create path =
|
||||
let mode, flags =
|
||||
match create with
|
||||
| `Never -> 0, Low_level.Open_flags.empty
|
||||
| `If_missing perm -> perm, Low_level.Open_flags.creat
|
||||
| `Or_truncate perm -> perm, Low_level.Open_flags.(creat + trunc)
|
||||
| `Exclusive perm -> perm, Low_level.Open_flags.(creat + excl)
|
||||
in
|
||||
let flags = if append then Low_level.Open_flags.(flags + append) else flags in
|
||||
let flags = Low_level.Open_flags.(flags + rdwr + opt_nofollow t) in
|
||||
match
|
||||
with_parent_dir t path @@ fun dirfd path ->
|
||||
Low_level.openat ?dirfd ~sw ~mode path flags
|
||||
with
|
||||
| fd -> (Flow.of_fd fd :> Eio.File.rw_ty r)
|
||||
| exception Unix.Unix_error (ELOOP, _, _) ->
|
||||
(* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that).
|
||||
A leaf symlink might be OK, but we need to check it's still in the sandbox.
|
||||
todo: possibly we should limit the number of redirections here, like the kernel does. *)
|
||||
let target = Unix.readlink path in
|
||||
let full_target =
|
||||
if Filename.is_relative target then
|
||||
Filename.concat (Filename.dirname path) target
|
||||
else target
|
||||
in
|
||||
open_out t ~sw ~append ~create full_target
|
||||
| exception Unix.Unix_error (code, name, arg) ->
|
||||
raise (Err.wrap code name arg)
|
||||
|
||||
let mkdir t ~perm path =
|
||||
with_parent_dir t path @@ fun dirfd path ->
|
||||
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
|
||||
|
||||
let unlink t path =
|
||||
with_parent_dir t path @@ fun dirfd path ->
|
||||
Err.run (Low_level.unlink ?dirfd ~dir:false) path
|
||||
|
||||
let rmdir t path =
|
||||
with_parent_dir t path @@ fun dirfd path ->
|
||||
Err.run (Low_level.unlink ?dirfd ~dir:true) path
|
||||
|
||||
let read_dir t path =
|
||||
(* todo: need fdopendir here to avoid races *)
|
||||
let path = resolve t path in
|
||||
Err.run Low_level.readdir path
|
||||
|> Array.to_list
|
||||
|
||||
let rename t old_path new_dir new_path =
|
||||
match Handler.as_posix_dir new_dir with
|
||||
| None -> invalid_arg "Target is not an eio_posix directory!"
|
||||
| Some new_dir ->
|
||||
with_parent_dir t old_path @@ fun old_dir old_path ->
|
||||
with_parent_dir new_dir new_path @@ fun new_dir new_path ->
|
||||
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
|
||||
|
||||
let close t = t.closed <- true
|
||||
|
||||
let open_dir t ~sw path =
|
||||
Switch.check sw;
|
||||
let label = Filename.basename path in
|
||||
let d = v ~label (resolve t path) ~sandbox:true in
|
||||
Switch.on_release sw (fun () -> close d);
|
||||
Eio.Resource.T (d, Handler.v)
|
||||
|
||||
let pp f t = Fmt.string f (String.escaped t.label)
|
||||
end
|
||||
and Handler : sig
|
||||
val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler
|
||||
|
||||
val as_posix_dir : [> `Dir] r -> Dir.t option
|
||||
end = struct
|
||||
(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check
|
||||
that the new location is within its sandbox. *)
|
||||
type (_, _, _) Eio.Resource.pi += Posix_dir : ('t, 't -> Dir.t, [> `Posix_dir]) Eio.Resource.pi
|
||||
|
||||
let as_posix_dir (Eio.Resource.T (t, ops)) =
|
||||
match Eio.Resource.get_opt ops Posix_dir with
|
||||
| None -> None
|
||||
| Some fn -> Some (fn t)
|
||||
|
||||
let v = Eio.Resource.handler [
|
||||
H (Eio.Fs.Pi.Dir, (module Dir));
|
||||
H (Posix_dir, Fun.id);
|
||||
]
|
||||
end
|
||||
|
||||
(* Full access to the filesystem. *)
|
||||
let fs = object
|
||||
inherit dir ~label:"fs"
|
||||
|
||||
val opt_nofollow = Low_level.Open_flags.empty
|
||||
|
||||
(* No checks *)
|
||||
method private resolve path = path
|
||||
method private with_parent_dir path fn = fn None path
|
||||
end
|
||||
|
||||
let cwd = new sandbox ~label:"cwd" "."
|
||||
let fs = Eio.Resource.T (Dir.v ~label:"fs" ~sandbox:false ".", Handler.v)
|
||||
let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~sandbox:true ".", Handler.v)
|
||||
|
@ -12,44 +12,71 @@ let socket_domain_of = function
|
||||
~v4:(fun _ -> Unix.PF_INET)
|
||||
~v6:(fun _ -> Unix.PF_INET6)
|
||||
|
||||
let listening_socket ~hook fd = object
|
||||
inherit Eio.Net.listening_socket
|
||||
module Listening_socket = struct
|
||||
type t = {
|
||||
hook : Switch.hook;
|
||||
fd : Fd.t;
|
||||
}
|
||||
|
||||
method close =
|
||||
Switch.remove_hook hook;
|
||||
Fd.close fd
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
method accept ~sw =
|
||||
let client, client_addr = Err.run (Low_level.accept ~sw) fd in
|
||||
let make ~hook fd = { hook; fd }
|
||||
|
||||
let fd t = t.fd
|
||||
|
||||
let close t =
|
||||
Switch.remove_hook t.hook;
|
||||
Fd.close t.fd
|
||||
|
||||
let accept t ~sw =
|
||||
let client, client_addr = Err.run (Low_level.accept ~sw) t.fd in
|
||||
let client_addr = match client_addr with
|
||||
| Unix.ADDR_UNIX path -> `Unix path
|
||||
| Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port)
|
||||
in
|
||||
let flow = (Flow.of_fd client :> Eio.Net.stream_socket) in
|
||||
let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in
|
||||
flow, client_addr
|
||||
|
||||
method! probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Eio_unix.Resource.FD -> Some fd
|
||||
| _ -> None
|
||||
end
|
||||
|
||||
let datagram_socket sock = object
|
||||
inherit Eio_unix.Net.datagram_socket
|
||||
let listening_handler = Eio_unix.Resource.listening_socket_handler (module Listening_socket)
|
||||
|
||||
method close = Fd.close sock
|
||||
let listening_socket ~hook fd =
|
||||
Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler)
|
||||
|
||||
method fd = sock
|
||||
module Datagram_socket = struct
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
method send ?dst buf =
|
||||
type t = Eio_unix.Fd.t
|
||||
|
||||
let close = Fd.close
|
||||
|
||||
let fd t = t
|
||||
|
||||
let send t ?dst buf =
|
||||
let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in
|
||||
let sent = Err.run (Low_level.send_msg sock ?dst) (Array.of_list buf) in
|
||||
let sent = Err.run (Low_level.send_msg t ?dst) (Array.of_list buf) in
|
||||
assert (sent = Cstruct.lenv buf)
|
||||
|
||||
method recv buf =
|
||||
let addr, recv = Err.run (Low_level.recv_msg sock) [| buf |] in
|
||||
let recv t buf =
|
||||
let addr, recv = Err.run (Low_level.recv_msg t) [| buf |] in
|
||||
Eio_unix.Net.sockaddr_of_unix_datagram addr, recv
|
||||
|
||||
let shutdown t cmd =
|
||||
try
|
||||
Low_level.shutdown t @@ match cmd with
|
||||
| `Receive -> Unix.SHUTDOWN_RECEIVE
|
||||
| `Send -> Unix.SHUTDOWN_SEND
|
||||
| `All -> Unix.SHUTDOWN_ALL
|
||||
with
|
||||
| Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
|
||||
| Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
|
||||
end
|
||||
|
||||
let datagram_handler = Eio_unix.Resource.datagram_handler (module Datagram_socket)
|
||||
|
||||
let datagram_socket fd =
|
||||
Eio.Resource.T (fd, datagram_handler)
|
||||
|
||||
(* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *)
|
||||
let getaddrinfo ~service node =
|
||||
let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } =
|
||||
@ -105,7 +132,7 @@ let listen ~reuse_addr ~reuse_port ~backlog ~sw (listen_addr : Eio.Net.Sockaddr.
|
||||
Unix.bind fd addr;
|
||||
Unix.listen fd backlog;
|
||||
);
|
||||
listening_socket ~hook sock
|
||||
(listening_socket ~hook sock :> _ Eio.Net.listening_socket_ty r)
|
||||
|
||||
let connect ~sw connect_addr =
|
||||
let socket_type, addr =
|
||||
@ -118,7 +145,7 @@ let connect ~sw connect_addr =
|
||||
let sock = Low_level.socket ~sw (socket_domain_of connect_addr) socket_type 0 in
|
||||
try
|
||||
Low_level.connect sock addr;
|
||||
(Flow.of_fd sock :> Eio.Net.stream_socket)
|
||||
(Flow.of_fd sock :> _ Eio_unix.Net.stream_socket)
|
||||
with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
|
||||
|
||||
let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr =
|
||||
@ -135,13 +162,26 @@ let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr =
|
||||
)
|
||||
| `UdpV4 | `UdpV6 -> ()
|
||||
end;
|
||||
(datagram_socket sock :> Eio.Net.datagram_socket)
|
||||
datagram_socket sock
|
||||
|
||||
let v = object
|
||||
inherit Eio_unix.Net.t
|
||||
module Impl = struct
|
||||
type t = unit
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
method listen = listen
|
||||
method connect = connect
|
||||
method datagram_socket = create_datagram_socket
|
||||
method getaddrinfo = getaddrinfo
|
||||
let listen () = listen
|
||||
|
||||
let connect () ~sw addr =
|
||||
let socket = connect ~sw addr in
|
||||
(socket :> [`Generic | `Unix] Eio.Net.stream_socket_ty r)
|
||||
|
||||
let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr =
|
||||
let socket = create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr in
|
||||
(socket :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r)
|
||||
|
||||
let getaddrinfo () = getaddrinfo
|
||||
let getnameinfo () = Eio_unix.Net.getnameinfo
|
||||
end
|
||||
|
||||
let v : Impl.tag Eio.Net.ty r =
|
||||
let handler = Eio.Net.Pi.network (module Impl) in
|
||||
Eio.Resource.T ((), handler)
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -1,8 +1,15 @@
|
||||
open Eio.Std
|
||||
|
||||
module Fd = Eio_unix.Fd
|
||||
|
||||
let fstat fd =
|
||||
module Impl = struct
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
type t = Eio_unix.Fd.t
|
||||
|
||||
let stat t =
|
||||
try
|
||||
let ust = Low_level.fstat fd in
|
||||
let ust = Low_level.fstat t in
|
||||
let st_kind : Eio.File.Stat.kind =
|
||||
match ust.st_kind with
|
||||
| Unix.S_REG -> `Regular_file
|
||||
@ -29,29 +36,28 @@ let fstat fd =
|
||||
}
|
||||
with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap code name arg
|
||||
|
||||
let write_bufs fd bufs =
|
||||
try
|
||||
Low_level.writev fd bufs
|
||||
let write t bufs =
|
||||
try Low_level.writev t bufs
|
||||
with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
|
||||
|
||||
let copy src dst =
|
||||
let copy dst ~src =
|
||||
let buf = Cstruct.create 4096 in
|
||||
try
|
||||
while true do
|
||||
let got = Eio.Flow.single_read src buf in
|
||||
write_bufs dst [Cstruct.sub buf 0 got]
|
||||
write dst [Cstruct.sub buf 0 got]
|
||||
done
|
||||
with End_of_file -> ()
|
||||
|
||||
let read fd buf =
|
||||
match Low_level.read_cstruct fd buf with
|
||||
let single_read t buf =
|
||||
match Low_level.read_cstruct t buf with
|
||||
| 0 -> raise End_of_file
|
||||
| got -> got
|
||||
| exception (Unix.Unix_error (code, name, arg)) -> raise (Err.wrap code name arg)
|
||||
|
||||
let shutdown fd cmd =
|
||||
let shutdown t cmd =
|
||||
try
|
||||
Low_level.shutdown fd @@ match cmd with
|
||||
Low_level.shutdown t @@ match cmd with
|
||||
| `Receive -> Unix.SHUTDOWN_RECEIVE
|
||||
| `Send -> Unix.SHUTDOWN_SEND
|
||||
| `All -> Unix.SHUTDOWN_ALL
|
||||
@ -59,34 +65,37 @@ let shutdown fd cmd =
|
||||
| Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
|
||||
| Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
|
||||
|
||||
let of_fd fd = object (_ : <Eio_unix.Net.stream_socket; Eio.File.rw>)
|
||||
method fd = fd
|
||||
let read_methods = []
|
||||
|
||||
method read_methods = []
|
||||
method copy src = copy src fd
|
||||
|
||||
method pread ~file_offset bufs =
|
||||
let got = Low_level.preadv ~file_offset fd (Array.of_list bufs) in
|
||||
let pread t ~file_offset bufs =
|
||||
let got = Low_level.preadv ~file_offset t (Array.of_list bufs) in
|
||||
if got = 0 then raise End_of_file
|
||||
else got
|
||||
|
||||
method pwrite ~file_offset bufs = Low_level.pwritev ~file_offset fd (Array.of_list bufs)
|
||||
let pwrite t ~file_offset bufs = Low_level.pwritev ~file_offset t (Array.of_list bufs)
|
||||
|
||||
method stat = fstat fd
|
||||
method read_into buf = read fd buf
|
||||
method write bufs = write_bufs fd bufs
|
||||
method shutdown cmd = shutdown fd cmd
|
||||
method close = Fd.close fd
|
||||
let fd t = t
|
||||
|
||||
method probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Eio_unix.Resource.FD -> Some fd
|
||||
| _ -> None
|
||||
let close = Eio_unix.Fd.close
|
||||
end
|
||||
|
||||
let secure_random = object
|
||||
inherit Eio.Flow.source
|
||||
let handler = Eio_unix.Resource.flow_handler (module Impl)
|
||||
|
||||
method read_into buf =
|
||||
let of_fd fd =
|
||||
let r = Eio.Resource.T (fd, handler) in
|
||||
(r : [Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r :>
|
||||
[< Eio_unix.Net.stream_socket_ty | Eio.File.rw_ty] r)
|
||||
|
||||
module Secure_random = struct
|
||||
type t = unit
|
||||
|
||||
let single_read () buf =
|
||||
Low_level.getrandom buf;
|
||||
Cstruct.length buf
|
||||
|
||||
let read_methods = []
|
||||
end
|
||||
|
||||
let secure_random =
|
||||
let ops = Eio.Flow.Pi.source (module Secure_random) in
|
||||
Eio.Resource.T ((), ops)
|
||||
|
@ -26,123 +26,35 @@ open Eio.Std
|
||||
|
||||
module Fd = Eio_unix.Fd
|
||||
|
||||
class virtual posix_dir = object
|
||||
inherit Eio.Fs.dir
|
||||
module rec Dir : sig
|
||||
include Eio.Fs.Pi.DIR
|
||||
|
||||
val virtual opt_nofollow : bool
|
||||
(** Emulate [O_NOFOLLOW] here. *)
|
||||
val v : label:string -> sandbox:bool -> string -> t
|
||||
|
||||
method virtual private resolve : string -> string
|
||||
(** [resolve path] returns the real path that should be used to access [path].
|
||||
val resolve : t -> string -> string
|
||||
(** [resolve t path] returns the real path that should be used to access [path].
|
||||
For sandboxes, this is [realpath path] (and it checks that it is within the sandbox).
|
||||
For unrestricted access, this is the identity function. *)
|
||||
For unrestricted access, this returns [path] unchanged.
|
||||
@raise Eio.Fs.Permission_denied if sandboxed and [path] is outside of [dir_path]. *)
|
||||
|
||||
method virtual with_parent_dir : 'a. (string -> (Fd.t option -> string -> 'a) -> 'a)
|
||||
(** [with_parent_dir path fn] runs [fn dir_fd rel_path],
|
||||
val with_parent_dir : t -> string -> (Fd.t option -> string -> 'a) -> 'a
|
||||
(** [with_parent_dir t path fn] runs [fn dir_fd rel_path],
|
||||
where [rel_path] accessed relative to [dir_fd] gives access to [path].
|
||||
For unrestricted access, this just runs [fn None path].
|
||||
For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *)
|
||||
end
|
||||
end = struct
|
||||
type t = {
|
||||
dir_path : string;
|
||||
sandbox : bool;
|
||||
label : string;
|
||||
mutable closed : bool;
|
||||
}
|
||||
|
||||
(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check
|
||||
that the new location is within its sandbox. *)
|
||||
type _ Eio.Generic.ty += Posix_dir : posix_dir Eio.Generic.ty
|
||||
let as_posix_dir x = Eio.Generic.probe x Posix_dir
|
||||
|
||||
class virtual dir ~label = object (self)
|
||||
inherit posix_dir
|
||||
|
||||
val mutable closed = false
|
||||
|
||||
method! probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Posix_dir -> Some (self :> posix_dir)
|
||||
| _ -> None
|
||||
|
||||
method open_in ~sw path =
|
||||
let open Low_level in
|
||||
let fd = Err.run (Low_level.openat ~sw ~nofollow:opt_nofollow (self#resolve path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in
|
||||
(Flow.of_fd fd :> <Eio.File.ro; Eio.Flow.close>)
|
||||
|
||||
method open_out ~sw ~append ~create path =
|
||||
let open Low_level in
|
||||
let _mode, disp =
|
||||
match create with
|
||||
| `Never -> 0, Low_level.Flags.Disposition.open_
|
||||
| `If_missing perm -> perm, Low_level.Flags.Disposition.open_if
|
||||
| `Or_truncate perm -> perm, Low_level.Flags.Disposition.overwrite_if
|
||||
| `Exclusive perm -> perm, Low_level.Flags.Disposition.create
|
||||
in
|
||||
let flags = if append then Low_level.Flags.Open.(synchronise + append) else Low_level.Flags.Open.(generic_write + synchronise) in
|
||||
match
|
||||
self#with_parent_dir path @@ fun dirfd path ->
|
||||
Low_level.openat ?dirfd ~nofollow:opt_nofollow ~sw path flags disp Flags.Create.(non_directory)
|
||||
with
|
||||
| fd -> (Flow.of_fd fd :> <Eio.File.rw; Eio.Flow.close>)
|
||||
(* This is the result of raising [caml_unix_error(ELOOP,...)] *)
|
||||
| exception Unix.Unix_error (EUNKNOWNERR 114, _, _) ->
|
||||
print_endline "UNKNOWN";
|
||||
(* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that).
|
||||
A leaf symlink might be OK, but we need to check it's still in the sandbox.
|
||||
todo: possibly we should limit the number of redirections here, like the kernel does. *)
|
||||
let target = Unix.readlink path in
|
||||
let full_target =
|
||||
if Filename.is_relative target then
|
||||
Filename.concat (Filename.dirname path) target
|
||||
else target
|
||||
in
|
||||
self#open_out ~sw ~append ~create full_target
|
||||
| exception Unix.Unix_error (code, name, arg) ->
|
||||
raise (Err.wrap code name arg)
|
||||
|
||||
method mkdir ~perm path =
|
||||
self#with_parent_dir path @@ fun dirfd path ->
|
||||
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
|
||||
|
||||
method unlink path =
|
||||
self#with_parent_dir path @@ fun dirfd path ->
|
||||
Err.run (Low_level.unlink ?dirfd ~dir:false) path
|
||||
|
||||
method rmdir path =
|
||||
self#with_parent_dir path @@ fun dirfd path ->
|
||||
Err.run (Low_level.unlink ?dirfd ~dir:true) path
|
||||
|
||||
method read_dir path =
|
||||
(* todo: need fdopendir here to avoid races *)
|
||||
let path = self#resolve path in
|
||||
Err.run Low_level.readdir path
|
||||
|> Array.to_list
|
||||
|
||||
method rename old_path new_dir new_path =
|
||||
match as_posix_dir new_dir with
|
||||
| None -> invalid_arg "Target is not an eio_posix directory!"
|
||||
| Some new_dir ->
|
||||
self#with_parent_dir old_path @@ fun old_dir old_path ->
|
||||
new_dir#with_parent_dir new_path @@ fun new_dir new_path ->
|
||||
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
|
||||
|
||||
method open_dir ~sw path =
|
||||
Switch.check sw;
|
||||
let label = Filename.basename path in
|
||||
let d = new sandbox ~label (self#resolve path) in
|
||||
Switch.on_release sw (fun () -> d#close);
|
||||
(d :> Eio.Fs.dir_with_close)
|
||||
|
||||
method close = closed <- true
|
||||
|
||||
method pp f = Fmt.string f (String.escaped label)
|
||||
end
|
||||
|
||||
and sandbox ~label dir_path = object (self)
|
||||
inherit dir ~label
|
||||
|
||||
val opt_nofollow = true
|
||||
|
||||
(* Resolve a relative path to an absolute one, with no symlinks.
|
||||
@raise Eio.Fs.Permission_denied if it's outside of [dir_path]. *)
|
||||
method private resolve path =
|
||||
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
|
||||
let resolve t path =
|
||||
if t.sandbox then (
|
||||
if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path;
|
||||
if Filename.is_relative path then (
|
||||
let dir_path = Err.run Low_level.realpath dir_path in
|
||||
let dir_path = Err.run Low_level.realpath t.dir_path in
|
||||
let full = Err.run Low_level.realpath (Filename.concat dir_path path) in
|
||||
let prefix_len = String.length dir_path + 1 in
|
||||
(* \\??\\ Is necessary with NtCreateFile. *)
|
||||
@ -155,9 +67,11 @@ and sandbox ~label dir_path = object (self)
|
||||
) else (
|
||||
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
|
||||
)
|
||||
) else path
|
||||
|
||||
method with_parent_dir path fn =
|
||||
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
|
||||
let with_parent_dir t path fn =
|
||||
if t.sandbox then (
|
||||
if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path;
|
||||
let dir, leaf = Filename.dirname path, Filename.basename path in
|
||||
if leaf = ".." then (
|
||||
(* We could be smarter here and normalise the path first, but '..'
|
||||
@ -165,23 +79,117 @@ and sandbox ~label dir_path = object (self)
|
||||
anyway. *)
|
||||
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
|
||||
) else (
|
||||
let dir = self#resolve dir in
|
||||
let dir = resolve t dir in
|
||||
Switch.run @@ fun sw ->
|
||||
let open Low_level in
|
||||
let dirfd = Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(directory) in
|
||||
fn (Some dirfd) leaf
|
||||
)
|
||||
) else fn None path
|
||||
|
||||
let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false }
|
||||
|
||||
(* Sandboxes use [O_NOFOLLOW] when opening files ([resolve] already removed any symlinks).
|
||||
This avoids a race where symlink might be added after [realpath] returns.
|
||||
TODO: Emulate [O_NOFOLLOW] here. *)
|
||||
let opt_nofollow t = t.sandbox
|
||||
|
||||
let open_in t ~sw path =
|
||||
let open Low_level in
|
||||
let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in
|
||||
(Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t)
|
||||
|
||||
let rec open_out t ~sw ~append ~create path =
|
||||
let open Low_level in
|
||||
let _mode, disp =
|
||||
match create with
|
||||
| `Never -> 0, Low_level.Flags.Disposition.open_
|
||||
| `If_missing perm -> perm, Low_level.Flags.Disposition.open_if
|
||||
| `Or_truncate perm -> perm, Low_level.Flags.Disposition.overwrite_if
|
||||
| `Exclusive perm -> perm, Low_level.Flags.Disposition.create
|
||||
in
|
||||
let flags =
|
||||
if append then Low_level.Flags.Open.(synchronise + append)
|
||||
else Low_level.Flags.Open.(generic_write + synchronise)
|
||||
in
|
||||
match
|
||||
with_parent_dir t path @@ fun dirfd path ->
|
||||
Low_level.openat ?dirfd ~nofollow:(opt_nofollow t) ~sw path flags disp Flags.Create.(non_directory)
|
||||
with
|
||||
| fd -> (Flow.of_fd fd :> Eio.File.rw_ty r)
|
||||
(* This is the result of raising [caml_unix_error(ELOOP,...)] *)
|
||||
| exception Unix.Unix_error (EUNKNOWNERR 114, _, _) ->
|
||||
print_endline "UNKNOWN";
|
||||
(* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that).
|
||||
A leaf symlink might be OK, but we need to check it's still in the sandbox.
|
||||
todo: possibly we should limit the number of redirections here, like the kernel does. *)
|
||||
let target = Unix.readlink path in
|
||||
let full_target =
|
||||
if Filename.is_relative target then
|
||||
Filename.concat (Filename.dirname path) target
|
||||
else target
|
||||
in
|
||||
open_out t ~sw ~append ~create full_target
|
||||
| exception Unix.Unix_error (code, name, arg) ->
|
||||
raise (Err.wrap code name arg)
|
||||
|
||||
let mkdir t ~perm path =
|
||||
with_parent_dir t path @@ fun dirfd path ->
|
||||
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
|
||||
|
||||
let unlink t path =
|
||||
with_parent_dir t path @@ fun dirfd path ->
|
||||
Err.run (Low_level.unlink ?dirfd ~dir:false) path
|
||||
|
||||
let rmdir t path =
|
||||
with_parent_dir t path @@ fun dirfd path ->
|
||||
Err.run (Low_level.unlink ?dirfd ~dir:true) path
|
||||
|
||||
let read_dir t path =
|
||||
(* todo: need fdopendir here to avoid races *)
|
||||
let path = resolve t path in
|
||||
Err.run Low_level.readdir path
|
||||
|> Array.to_list
|
||||
|
||||
let rename t old_path new_dir new_path =
|
||||
match Handler.as_posix_dir new_dir with
|
||||
| None -> invalid_arg "Target is not an eio_posix directory!"
|
||||
| Some new_dir ->
|
||||
with_parent_dir t old_path @@ fun old_dir old_path ->
|
||||
with_parent_dir new_dir new_path @@ fun new_dir new_path ->
|
||||
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
|
||||
|
||||
let close t = t.closed <- true
|
||||
|
||||
let open_dir t ~sw path =
|
||||
Switch.check sw;
|
||||
let label = Filename.basename path in
|
||||
let d = v ~label (resolve t path) ~sandbox:true in
|
||||
Switch.on_release sw (fun () -> close d);
|
||||
Eio.Resource.T (d, Handler.v)
|
||||
|
||||
let pp f t = Fmt.string f (String.escaped t.label)
|
||||
end
|
||||
and Handler : sig
|
||||
val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler
|
||||
|
||||
val as_posix_dir : [> `Dir] r -> Dir.t option
|
||||
end = struct
|
||||
(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check
|
||||
that the new location is within its sandbox. *)
|
||||
type (_, _, _) Eio.Resource.pi += Posix_dir : ('t, 't -> Dir.t, [> `Posix_dir]) Eio.Resource.pi
|
||||
|
||||
let as_posix_dir (Eio.Resource.T (t, ops)) =
|
||||
match Eio.Resource.get_opt ops Posix_dir with
|
||||
| None -> None
|
||||
| Some fn -> Some (fn t)
|
||||
|
||||
let v = Eio.Resource.handler [
|
||||
H (Eio.Fs.Pi.Dir, (module Dir));
|
||||
H (Posix_dir, Fun.id);
|
||||
]
|
||||
end
|
||||
|
||||
(* Full access to the filesystem. *)
|
||||
let fs = object
|
||||
inherit dir ~label:"fs"
|
||||
|
||||
val opt_nofollow = false
|
||||
|
||||
(* No checks *)
|
||||
method private resolve path = path
|
||||
method private with_parent_dir path fn = fn None path
|
||||
end
|
||||
|
||||
let cwd = new sandbox ~label:"cwd" "."
|
||||
let fs = Eio.Resource.T (Dir.v ~label:"fs" ~sandbox:false ".", Handler.v)
|
||||
let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~sandbox:true ".", Handler.v)
|
||||
|
@ -12,47 +12,73 @@ let socket_domain_of = function
|
||||
~v4:(fun _ -> Unix.PF_INET)
|
||||
~v6:(fun _ -> Unix.PF_INET6)
|
||||
|
||||
let listening_socket ~hook fd = object
|
||||
inherit Eio.Net.listening_socket
|
||||
module Listening_socket = struct
|
||||
type t = {
|
||||
hook : Switch.hook;
|
||||
fd : Fd.t;
|
||||
}
|
||||
|
||||
method close =
|
||||
Switch.remove_hook hook;
|
||||
Fd.close fd
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
method accept ~sw =
|
||||
let client, client_addr = Err.run (Low_level.accept ~sw) fd in
|
||||
let make ~hook fd = { hook; fd }
|
||||
|
||||
let fd t = t.fd
|
||||
|
||||
let close t =
|
||||
Switch.remove_hook t.hook;
|
||||
Fd.close t.fd
|
||||
|
||||
let accept t ~sw =
|
||||
let client, client_addr = Err.run (Low_level.accept ~sw) t.fd in
|
||||
let client_addr = match client_addr with
|
||||
| Unix.ADDR_UNIX path -> `Unix path
|
||||
| Unix.ADDR_INET (host, port) -> `Tcp (Eio_unix.Net.Ipaddr.of_unix host, port)
|
||||
in
|
||||
let flow = (Flow.of_fd client :> Eio.Net.stream_socket) in
|
||||
let flow = (Flow.of_fd client :> _ Eio.Net.stream_socket) in
|
||||
flow, client_addr
|
||||
|
||||
method! probe : type a. a Eio.Generic.ty -> a option = function
|
||||
| Eio_unix.Resource.FD -> Some fd
|
||||
| _ -> None
|
||||
end
|
||||
|
||||
(* todo: would be nice to avoid copying between bytes and cstructs here *)
|
||||
let datagram_socket sock = object
|
||||
inherit Eio_unix.Net.datagram_socket
|
||||
let listening_handler = Eio_unix.Resource.listening_socket_handler (module Listening_socket)
|
||||
|
||||
method close = Fd.close sock
|
||||
let listening_socket ~hook fd =
|
||||
Eio.Resource.T (Listening_socket.make ~hook fd, listening_handler)
|
||||
|
||||
method fd = sock
|
||||
module Datagram_socket = struct
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
method send ?dst buf =
|
||||
type t = Eio_unix.Fd.t
|
||||
|
||||
let close = Fd.close
|
||||
|
||||
let fd t = t
|
||||
|
||||
let send t ?dst buf =
|
||||
let dst = Option.map Eio_unix.Net.sockaddr_to_unix dst in
|
||||
let sent = Err.run (Low_level.send_msg sock ?dst) (Bytes.unsafe_of_string (Cstruct.copyv buf)) in
|
||||
let sent = Err.run (Low_level.send_msg t ?dst) (Bytes.unsafe_of_string (Cstruct.copyv buf)) in
|
||||
assert (sent = Cstruct.lenv buf)
|
||||
|
||||
method recv buf =
|
||||
let recv t buf =
|
||||
let b = Bytes.create (Cstruct.length buf) in
|
||||
let recv, addr = Err.run (Low_level.recv_msg sock) b in
|
||||
let recv, addr = Err.run (Low_level.recv_msg t) b in
|
||||
Cstruct.blit_from_bytes b 0 buf 0 recv;
|
||||
Eio_unix.Net.sockaddr_of_unix_datagram addr, recv
|
||||
|
||||
let shutdown t cmd =
|
||||
try
|
||||
Low_level.shutdown t @@ match cmd with
|
||||
| `Receive -> Unix.SHUTDOWN_RECEIVE
|
||||
| `Send -> Unix.SHUTDOWN_SEND
|
||||
| `All -> Unix.SHUTDOWN_ALL
|
||||
with
|
||||
| Unix.Unix_error (Unix.ENOTCONN, _, _) -> ()
|
||||
| Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
|
||||
end
|
||||
|
||||
let datagram_handler = Eio_unix.Resource.datagram_handler (module Datagram_socket)
|
||||
|
||||
let datagram_socket fd =
|
||||
Eio.Resource.T (fd, datagram_handler)
|
||||
|
||||
(* https://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml *)
|
||||
let getaddrinfo ~service node =
|
||||
let to_eio_sockaddr_t {Unix.ai_family; ai_addr; ai_socktype; ai_protocol; _ } =
|
||||
@ -110,7 +136,7 @@ let listen ~reuse_addr ~reuse_port ~backlog ~sw (listen_addr : Eio.Net.Sockaddr.
|
||||
Unix.bind fd addr;
|
||||
Unix.listen fd backlog
|
||||
);
|
||||
listening_socket ~hook sock
|
||||
(listening_socket ~hook sock :> _ Eio.Net.listening_socket_ty r)
|
||||
|
||||
let connect ~sw connect_addr =
|
||||
let socket_type, addr =
|
||||
@ -123,7 +149,7 @@ let connect ~sw connect_addr =
|
||||
let sock = Low_level.socket ~sw (socket_domain_of connect_addr) socket_type 0 in
|
||||
try
|
||||
Low_level.connect sock addr;
|
||||
(Flow.of_fd sock :> Eio.Net.stream_socket)
|
||||
(Flow.of_fd sock :> _ Eio_unix.Net.stream_socket)
|
||||
with Unix.Unix_error (code, name, arg) -> raise (Err.wrap code name arg)
|
||||
|
||||
let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr =
|
||||
@ -140,13 +166,26 @@ let create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr =
|
||||
)
|
||||
| `UdpV4 | `UdpV6 -> ()
|
||||
end;
|
||||
(datagram_socket sock :> Eio.Net.datagram_socket)
|
||||
datagram_socket sock
|
||||
|
||||
let v = object
|
||||
inherit Eio_unix.Net.t
|
||||
module Impl = struct
|
||||
type t = unit
|
||||
type tag = [`Generic | `Unix]
|
||||
|
||||
method listen = listen
|
||||
method connect = connect
|
||||
method datagram_socket = create_datagram_socket
|
||||
method getaddrinfo = getaddrinfo
|
||||
let listen () = listen
|
||||
|
||||
let connect () ~sw addr =
|
||||
let socket = connect ~sw addr in
|
||||
(socket :> [`Generic | `Unix] Eio.Net.stream_socket_ty r)
|
||||
|
||||
let datagram_socket () ~reuse_addr ~reuse_port ~sw saddr =
|
||||
let socket = create_datagram_socket ~reuse_addr ~reuse_port ~sw saddr in
|
||||
(socket :> [`Generic | `Unix] Eio.Net.datagram_socket_ty r)
|
||||
|
||||
let getaddrinfo () = getaddrinfo
|
||||
let getnameinfo () = Eio_unix.Net.getnameinfo
|
||||
end
|
||||
|
||||
let v : Impl.tag Eio.Net.ty r =
|
||||
let handler = Eio.Net.Pi.network (module Impl) in
|
||||
Eio.Resource.T ((), handler)
|
||||
|
@ -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)
|
||||
|
@ -19,12 +19,13 @@ let ensure t n =
|
||||
(* The next data to be returned by `mock_flow`. `[]` to raise `End_of_file`: *)
|
||||
let next = ref []
|
||||
|
||||
let mock_flow = object
|
||||
inherit Eio.Flow.source
|
||||
let mock_flow =
|
||||
let module X = struct
|
||||
type t = unit
|
||||
|
||||
method read_methods = []
|
||||
let read_methods = []
|
||||
|
||||
method read_into buf =
|
||||
let single_read () buf =
|
||||
match !next with
|
||||
| [] ->
|
||||
traceln "mock_flow returning Eof";
|
||||
@ -36,7 +37,9 @@ let mock_flow = object
|
||||
let x' = String.sub x len (String.length x - len) in
|
||||
next := (if x' = "" then xs else x' :: xs);
|
||||
len
|
||||
end
|
||||
end in
|
||||
let ops = Eio.Flow.Pi.source (module X) in
|
||||
Eio.Resource.T ((), ops)
|
||||
|
||||
let read flow n =
|
||||
let buf = Cstruct.create n in
|
||||
@ -238,7 +241,7 @@ Exception: End_of_file.
|
||||
|
||||
```ocaml
|
||||
# let bflow = R.of_flow mock_flow ~max_size:100 |> R.as_flow;;
|
||||
val bflow : Eio.Flow.source = <obj>
|
||||
val bflow : Eio.Flow.source_ty Eio.Std.r = Eio__.Resource.T (<poly>, <abstr>)
|
||||
# next := ["foo"; "bar"]; read bflow 2;;
|
||||
+mock_flow returning 3 bytes
|
||||
+Read "fo"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -8,7 +8,7 @@
|
||||
```ocaml
|
||||
open Eio.Std
|
||||
|
||||
let run (fn : net:#Eio.Net.t -> Switch.t -> unit) =
|
||||
let run (fn : net:_ Eio.Net.t -> Switch.t -> unit) =
|
||||
Eio_main.run @@ fun env ->
|
||||
let net = Eio.Stdenv.net env in
|
||||
Switch.run (fn ~net)
|
||||
@ -361,8 +361,8 @@ Wrapping a Unix FD as an Eio stream socket:
|
||||
# Eio_main.run @@ fun _ ->
|
||||
Switch.run @@ fun sw ->
|
||||
let r, w = Unix.pipe () in
|
||||
let source = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true r :> Eio.Flow.source) in
|
||||
let sink = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true w :> Eio.Flow.sink) in
|
||||
let source = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true r :> _ Eio.Flow.source) in
|
||||
let sink = (Eio_unix.Net.import_socket_stream ~sw ~close_unix:true w :> _ Eio.Flow.sink) in
|
||||
Fiber.both
|
||||
(fun () -> Eio.Flow.copy_string "Hello\n!" sink)
|
||||
(fun () ->
|
||||
@ -998,3 +998,18 @@ Limiting to 2 concurrent connections:
|
||||
+flow3: closed
|
||||
- : unit = ()
|
||||
```
|
||||
|
||||
We keep the polymorphism when using a Unix network:
|
||||
|
||||
```ocaml
|
||||
let _check_types ~(net:Eio_unix.Net.t) =
|
||||
Switch.run @@ fun sw ->
|
||||
let addr = `Unix "/socket" in
|
||||
let server : [`Generic | `Unix] Eio.Net.listening_socket_ty r =
|
||||
Eio.Net.listen ~sw net addr ~backlog:5
|
||||
in
|
||||
Eio.Net.accept_fork ~sw ~on_error:raise server
|
||||
(fun (_flow : [`Generic | `Unix] Eio.Net.stream_socket_ty r) _addr -> assert false);
|
||||
let _client : [`Generic | `Unix] Eio.Net.stream_socket_ty r = Eio.Net.connect ~sw net addr in
|
||||
();;
|
||||
```
|
||||
|
Loading…
x
Reference in New Issue
Block a user