├── .gitignore ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── combinators ├── dune ├── mirage_flow_combinators.ml └── mirage_flow_combinators.mli ├── dune-project ├── mirage-flow-combinators.opam ├── mirage-flow-unix.opam ├── mirage-flow.opam ├── src ├── dune ├── mirage_flow.ml └── mirage_flow.mli ├── test ├── dune └── test.ml └── unix ├── dune ├── mirage_flow_unix.ml └── mirage_flow_unix.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *~ 3 | \.\#* 4 | \#*# 5 | *.merlin 6 | *.install 7 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### v4.0.2 (2024-02-08) 2 | 3 | - revert < coercion, shutdown is again 4 | ``shutdown : flow -> [ `read | `write | `read_write ] -> unit Lwt.t`` 5 | (@reynir @hannesm) 6 | 7 | ### v4.0.1 (2024-02-08) 8 | 9 | - move Mirage_flow.stats and pp_stats to Mirage_flow_combinators (#51 @hannesm) 10 | - improve documentation of expected semantics (when write promise is resolved, 11 | what is done to the underlying flow - addresses #4 @samoht), 12 | (#51 @reynir @dinosaure @hannesm) 13 | - add < coercion to shutdown: 14 | ``shutdown : flow -> [< `read | `write | `read_write ] -> unit Lwt.t`` 15 | (requested #50 @reynir, #52 @hannesm) 16 | 17 | ### v4.0.0 (2023-12-19) 18 | 19 | - Redefine `close` semantics, which no longer is a `` shutdown `read_write `` 20 | (#49 @hannesm) 21 | - Add ``shutdown : flow -> [ `read | `write | `read_write ] -> unit Lwt.t`` 22 | (@djs55 @hannesm #16 #18 #48) 23 | - Remove SHUTDOWNABLE signature (@djs55 #17, rebased into #48) 24 | 25 | ### v3.0.0 (2021-11-14) 26 | 27 | - Remove Mirage_flow_lwt module (#47 @hannesm) 28 | - Require fmt 0.8.7, cstruct 6.0.0 and avoid deprecated functions (#47 @hannesm) 29 | - Compatibility with alcotest 1.4 (eta expansion of Alcotest.fail) (#47 @hannesm) 30 | - Mirage_flow_combinators.forward has an additional unit argument to avoid 31 | unerasable optional argument warning (#47 @hannesm) 32 | 33 | ### v2.0.1 (2019-11-04) 34 | 35 | * provide deprecated Mirage_flow_lwt for smooth transition (#45 @hannesm) 36 | 37 | ### v2.0.0 (2019-10-23) 38 | 39 | * mirage-flow uses Lwt.t and Cstruct.t directly (#43 @hannesm) 40 | * mirage-flow-lwt was removed, combinators are now in mirage-flow-combinators (#43 @hannesm) 41 | * raise lower OCaml bound to 4.06.0 (#43 @hannesm) 42 | 43 | ### v1.6.0 (2019-04-24) 44 | 45 | * remove uses of `Result` (#40 @hannesm) 46 | * port opam metadata to 2.0 format (#41 @hannesm) 47 | * port build to dune from jbuilder (#41 @hannesm) 48 | 49 | ### v1.5.0 (2018-07-09) 50 | 51 | * remove Result module, work with `-safe-string` and require cstruct >=3.2.0 52 | 53 | ### v1.4.0 (2017-06-23) 54 | 55 | * mirage-flow-unix: add `Mirage_flow_unix.Fd` to wrap `Lwt_unix.file_descr` into 56 | a MirageOS flow (#34, #36, @samoht) 57 | * mirage-flow-lwt: add first class flow values of type `Mirage_flow_lwt.t` 58 | (#35, @samoht) 59 | 60 | ### v1.3.0 (2017-06-12) 61 | 62 | * Port to Jbuilder (#32 @djs55) 63 | 64 | ### v1.2.0 (2016-12-21) 65 | 66 | * Import `V1.FLOW` from `mirage-types` into `Mirage_flow.S` (@samoht) 67 | * Import `V1_LWT.FLOW` from `mirage-types-lwt` into `Mirage_flow_lwt.S` (@samoht) 68 | * Rename the existing `Mirage_flow` into `Mirage_flow_lwt` (@samoht) 69 | * Rename `Lwt_io_flow` into `Mirage_flow_unix` (@samoht) 70 | 71 | ### v1.1.0 (2016-01-27) 72 | 73 | * Add a new top-level interface `module Mirage_flow`. Existing `module Fflow` 74 | is still present. 75 | * Add `Mirage_flow.copy` to copy all the data in a flow to another 76 | * Add `Mirage_flow.proxy` to copy data bidirectionally between two flows 77 | 78 | ### v1.0.3 (2015-07-29) 79 | 80 | * Support lwt 2.5.0 81 | 82 | ### v1.0.2 (2015-06-30) 83 | 84 | * Add explicit dependency to OUnit 85 | 86 | ### v1.0.1 (2015-04-28) 87 | 88 | * Add `Fflow.error_message` to satisfay `mirage-types.2.3.0` 89 | 90 | ### v1.0.0 (2015-02-26) 91 | 92 | * Add `Fflow` (functional flows) 93 | * Add `Lwt_io_flow` to convert between Mirage and Lwt flows 94 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Permission to use, copy, modify, and distribute this software for any 2 | purpose with or without fee is hereby granted, provided that the above 3 | copyright notice and this permission notice appear in all copies. 4 | 5 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 6 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 7 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 8 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 9 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 10 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 11 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 12 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build clean test 2 | 3 | build: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | clean: 10 | dune clean 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## mirag-flow -- Flow implementations and combinators for MirageOS 2 | 3 | This repo contains generic operations over Mirage `FLOW` implementations. 4 | 5 | Please consult [the API documentation](https://mirage.github.io/mirage-flow/index.html). 6 | 7 | ### Example usage 8 | 9 | In a top-level like utop: 10 | ```ocaml 11 | # #require "mirage-flow";; 12 | # #require "mirage-clock-unix";; 13 | # #require "lwt.syntax";; 14 | 15 | # let a = Mirage_flow.Fun.(make ~input:(input_string "hellooooo") ());; 16 | val a : Mirage_flow.Fun.flow = 17 | 18 | # let buffer = String.make 20 ' ';; 19 | val buffer : bytes = " " 20 | # let b = Mirage_flow.Fun.(make ~output:(output_string buffer) ());; 21 | val b : Mirage_flow.Fun.flow = 22 | 23 | # lwt results = Mirage_flow.copy (module Clock) (module Mirage_flow.Fun) a (module Mirage_flow.Fun) b ();; 24 | val results : [ `Error of [ `Msg of bytes ] | `Ok of Mirage_flow.CopyStats.t ] = `Ok {Mirage_flow.CopyStats.read_bytes = 9L; read_ops = 1L; write_bytes = 9L; write_ops = 1L; duration = 6.9141387939453125e-06} 25 | # buffer;; 26 | - : bytes = "hellooooo " 27 | ``` 28 | -------------------------------------------------------------------------------- /combinators/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_flow_combinators) 3 | (public_name mirage-flow-combinators) 4 | (libraries lwt cstruct mirage-flow mirage-mtime logs) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /combinators/mirage_flow_combinators.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011-present Anil Madhavapeddy 3 | * Copyright (c) 2013-present Thomas Gazagnaire 4 | * Copyright (C) 2016-present David Scott 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Lwt.Infix 20 | 21 | let src = Logs.Src.create "mirage-flow-combinators" 22 | module Log = (val Logs.src_log src : Logs.LOG) 23 | 24 | type stats = { 25 | read_bytes: int64; 26 | read_ops: int64; 27 | write_bytes: int64; 28 | write_ops: int64; 29 | duration: int64; 30 | } 31 | 32 | let kib = 1024L 33 | let ( ** ) = Int64.mul 34 | let mib = kib ** 1024L 35 | let gib = mib ** 1024L 36 | let tib = gib ** 1024L 37 | 38 | let suffix = [ 39 | kib, "KiB"; 40 | mib, "MiB"; 41 | gib, "GiB"; 42 | tib, "TiB"; 43 | ] 44 | 45 | let add_suffix x = 46 | List.fold_left (fun acc (y, label) -> 47 | if Int64.div x y > 0L 48 | then Printf.sprintf "%.1f %s" Int64.((to_float x) /. (to_float y)) label 49 | else acc 50 | ) (Printf.sprintf "%Ld bytes" x) suffix 51 | 52 | let pp_stats ppf s = 53 | Fmt.pf ppf "%s bytes at %s/nanosec and %Lu IOPS/nanosec" 54 | (add_suffix s.read_bytes) 55 | (add_suffix Int64.(div s.read_bytes s.duration)) 56 | (Int64.div s.read_ops s.duration) 57 | 58 | module type CONCRETE = Mirage_flow.S 59 | with type error = [ `Msg of string ] 60 | and type write_error = [ Mirage_flow.write_error | `Msg of string ] 61 | 62 | module Concrete (S: Mirage_flow.S) = struct 63 | type error = [`Msg of string] 64 | type write_error = [ Mirage_flow.write_error | `Msg of string] 65 | type flow = S.flow 66 | 67 | let pp_error ppf = function 68 | | `Msg s -> Fmt.string ppf s 69 | 70 | let pp_write_error ppf = function 71 | | #error as e -> pp_error ppf e 72 | | `Closed -> Mirage_flow.pp_write_error ppf `Closed 73 | 74 | let lift_read = function 75 | | Ok x -> Ok x 76 | | Error e -> Error (`Msg (Fmt.str "%a" S.pp_error e)) 77 | 78 | let lift_write = function 79 | | Ok () -> Ok () 80 | | Error `Closed -> Error `Closed 81 | | Error e -> Error (`Msg (Fmt.str "%a" S.pp_write_error e)) 82 | 83 | let read t = S.read t >|= lift_read 84 | let write t b = S.write t b >|= lift_write 85 | let writev t bs = S.writev t bs >|= lift_write 86 | let shutdown t m = S.shutdown t m 87 | let close t = S.close t 88 | end 89 | 90 | type time = int64 91 | 92 | type 'a stats_lwt = { 93 | read_bytes: int64 ref; 94 | read_ops: int64 ref; 95 | write_bytes: int64 ref; 96 | write_ops: int64 ref; 97 | finish: time option ref; 98 | start: time; 99 | time: unit -> time; 100 | t: (unit, 'a) result Lwt.t; 101 | } 102 | 103 | let stats_lwt t = 104 | let duration : int64 = match !(t.finish) with 105 | | None -> Int64.sub (t.time ()) t.start 106 | | Some x -> Int64.sub x t.start 107 | in { 108 | read_bytes = !(t.read_bytes); 109 | read_ops = !(t.read_ops); 110 | write_bytes = !(t.write_bytes); 111 | write_ops = !(t.write_ops); 112 | duration; 113 | } 114 | 115 | module Copy (A: Mirage_flow.S) (B: Mirage_flow.S) = 116 | struct 117 | 118 | type error = [`A of A.error | `B of B.write_error] 119 | 120 | let pp_error ppf = function 121 | | `A e -> A.pp_error ppf e 122 | | `B e -> B.pp_write_error ppf e 123 | 124 | let start (a: A.flow) (b: B.flow) = 125 | let read_bytes = ref 0L in 126 | let read_ops = ref 0L in 127 | let write_bytes = ref 0L in 128 | let write_ops = ref 0L in 129 | let finish = ref None in 130 | let start = Mirage_mtime.elapsed_ns () in 131 | let rec loop () = 132 | A.read a >>= function 133 | | Error e -> 134 | finish := Some (Mirage_mtime.elapsed_ns ()); 135 | Lwt.return (Error (`A e)) 136 | | Ok `Eof -> 137 | finish := Some (Mirage_mtime.elapsed_ns ()); 138 | Lwt.return (Ok ()) 139 | | Ok (`Data buffer) -> 140 | read_ops := Int64.succ !read_ops; 141 | read_bytes := Int64.(add !read_bytes (of_int @@ Cstruct.length buffer)); 142 | B.write b buffer 143 | >>= function 144 | | Ok () -> 145 | write_ops := Int64.succ !write_ops; 146 | write_bytes := Int64.(add !write_bytes (of_int @@ Cstruct.length buffer)); 147 | loop () 148 | | Error e -> 149 | finish := Some (Mirage_mtime.elapsed_ns ()); 150 | Lwt.return (Error (`B e)) 151 | in 152 | { 153 | read_bytes; 154 | read_ops; 155 | write_bytes; 156 | write_ops; 157 | finish; 158 | start; 159 | time = (fun () -> Mirage_mtime.elapsed_ns ()); 160 | t = loop (); 161 | } 162 | 163 | let wait t = t.t 164 | 165 | let copy ~src:a ~dst:b = 166 | let t = start a b in 167 | wait t >|= function 168 | | Ok () -> Ok (stats_lwt t) 169 | | Error e -> Error e 170 | 171 | end 172 | 173 | module Proxy (A: Mirage_flow.S) (B: Mirage_flow.S) = 174 | struct 175 | 176 | module A_to_B = Copy(A)(B) 177 | module B_to_A = Copy(B)(A) 178 | 179 | type error = [ 180 | | `A of A_to_B.error 181 | | `B of B_to_A.error 182 | | `A_and_B of A_to_B.error * B_to_A.error 183 | ] 184 | 185 | let pp_error ppf = function 186 | | `A_and_B (e1, e2) -> 187 | Fmt.pf ppf "flow proxy a: %a; flow proxy b: %a" 188 | A_to_B.pp_error e1 B_to_A.pp_error e2 189 | | `A e -> Fmt.pf ppf "flow proxy a: %a" A_to_B.pp_error e 190 | | `B e -> Fmt.pf ppf "flow proxy b: %a" B_to_A.pp_error e 191 | 192 | let proxy a b = 193 | let a2b = 194 | let t = A_to_B.start a b in 195 | A_to_B.wait t >>= fun result -> 196 | A.shutdown a `read >>= fun () -> 197 | B.shutdown b `write >|= fun () -> 198 | let stats = stats_lwt t in 199 | match result with 200 | | Ok () -> Ok stats 201 | | Error e -> Error e 202 | in 203 | let b2a = 204 | let t = B_to_A.start b a in 205 | B_to_A.wait t >>= fun result -> 206 | B.shutdown b `read >>= fun () -> 207 | A.shutdown a `write >|= fun () -> 208 | let stats = stats_lwt t in 209 | match result with 210 | | Ok () -> Ok stats 211 | | Error e -> Error e 212 | in 213 | a2b >>= fun a_stats -> 214 | b2a >|= fun b_stats -> 215 | match a_stats, b_stats with 216 | | Ok a_stats, Ok b_stats -> Ok (a_stats, b_stats) 217 | | Error e1 , Error e2 -> Error (`A_and_B (e1, e2)) 218 | | Error e1 , _ -> Error (`A e1) 219 | | _ , Error e2 -> Error (`B e2) 220 | 221 | end 222 | 223 | module F = struct 224 | 225 | let (>>=) = Lwt.bind 226 | 227 | type refill = Cstruct.t -> int -> int -> int Lwt.t 228 | 229 | type error 230 | let pp_error ppf (_:error) = 231 | Fmt.string ppf "Mirage_flow_combinators.F.error" 232 | type write_error = Mirage_flow.write_error 233 | let pp_write_error = Mirage_flow.pp_write_error 234 | 235 | let seq f1 f2 buf off len = 236 | f1 buf off len >>= function 237 | | 0 -> f2 buf off len 238 | | n -> Lwt.return n 239 | 240 | let zero _buf _off _len = Lwt.return 0 241 | 242 | let rec iter fn = function 243 | | [] -> zero 244 | | h::t -> seq (fn h) (iter fn t) 245 | 246 | type flow = { 247 | close: unit -> unit Lwt.t; 248 | input: refill; 249 | output: refill; 250 | mutable buf: Cstruct.t; 251 | mutable ic_closed: bool; 252 | mutable oc_closed: bool; 253 | } 254 | 255 | let default_buffer_size = 4096 256 | 257 | let make ?(close=fun () -> Lwt.return_unit) ?input ?output () = 258 | let buf = Cstruct.create default_buffer_size in 259 | let ic_closed = input = None in 260 | let oc_closed = output = None in 261 | let input = match input with None -> zero | Some x -> x in 262 | let output = match output with None -> zero | Some x -> x in 263 | { close; input; output; buf; ic_closed; oc_closed; } 264 | 265 | let input_fn len blit str = 266 | let str_off = ref 0 in 267 | let str_len = len str in 268 | fun buf off len -> 269 | if !str_off >= str_len then Lwt.return 0 270 | else ( 271 | let len = min (str_len - !str_off) len in 272 | blit str !str_off buf off len; 273 | str_off := !str_off + len; 274 | Lwt.return len 275 | ) 276 | 277 | let output_fn len blit str = 278 | let str_off = ref 0 in 279 | let str_len = len str in 280 | fun buf off len -> 281 | if !str_off >= str_len then Lwt.return 0 282 | else ( 283 | let len = min (str_len - !str_off) len in 284 | blit buf off str !str_off len; 285 | str_off := !str_off + len; 286 | Lwt.return len 287 | ) 288 | 289 | let mk fn_i fn_o ?input ?output () = 290 | let input = match input with None -> None | Some x -> Some (fn_i x) in 291 | let output = match output with None -> None | Some x -> Some (fn_o x) in 292 | make ?input ?output () 293 | 294 | let input_string = input_fn String.length Cstruct.blit_from_string 295 | let output_bytes = output_fn Bytes.length Cstruct.blit_to_bytes 296 | let string = mk input_string output_bytes 297 | 298 | let input_cstruct = input_fn Cstruct.length Cstruct.blit 299 | let output_cstruct = output_fn Cstruct.length Cstruct.blit 300 | let cstruct = mk input_cstruct output_cstruct 301 | 302 | let input_strings = iter input_string 303 | let output_bytess = iter output_bytes 304 | let strings = mk input_strings output_bytess 305 | 306 | let input_cstructs = iter input_cstruct 307 | let output_cstructs = iter output_cstruct 308 | let cstructs = mk input_cstructs output_cstructs 309 | 310 | let refill ch = 311 | if Cstruct.length ch.buf = 0 then ( 312 | let buf = Cstruct.create default_buffer_size in 313 | ch.buf <- buf 314 | ) 315 | 316 | let read ch = 317 | if ch.ic_closed then Lwt.return @@ Ok `Eof 318 | else ( 319 | refill ch; 320 | ch.input ch.buf 0 default_buffer_size >>= fun n -> 321 | if n = 0 then ( 322 | ch.ic_closed <- true; 323 | Lwt.return (Ok `Eof); 324 | ) else ( 325 | let ret = Cstruct.sub ch.buf 0 n in 326 | let buf = Cstruct.shift ch.buf n in 327 | ch.buf <- buf; 328 | Lwt.return (Ok (`Data ret)) 329 | ) 330 | ) 331 | 332 | let write ch buf = 333 | if ch.oc_closed then Lwt.return @@ Error `Closed 334 | else ( 335 | let len = Cstruct.length buf in 336 | let rec aux off = 337 | if off = len then Lwt.return (Ok ()) 338 | else ( 339 | ch.output buf off (len - off) >>= fun n -> 340 | if n = 0 then ( 341 | ch.oc_closed <- true; 342 | Lwt.return @@ Error `Closed 343 | ) else aux (off+n) 344 | ) 345 | in 346 | aux 0 347 | ) 348 | 349 | let writev ch bufs = 350 | if ch.oc_closed then Lwt.return @@ Error `Closed 351 | else 352 | let rec aux = function 353 | | [] -> Lwt.return (Ok ()) 354 | | h::t -> 355 | write ch h >>= function 356 | | Error e -> Lwt.return (Error e) 357 | | Ok () -> aux t 358 | in 359 | aux bufs 360 | 361 | let shutdown ch mode = 362 | (match mode with 363 | | `read -> ch.ic_closed <- true 364 | | `write -> ch.oc_closed <- true 365 | | `read_write -> 366 | ch.ic_closed <- true; 367 | ch.oc_closed <- true); 368 | Lwt.return_unit 369 | 370 | let close ch = 371 | ch.ic_closed <- true; 372 | ch.oc_closed <- true; 373 | ch.close () 374 | 375 | end 376 | 377 | type error = [`Msg of string] 378 | type write_error = [ Mirage_flow.write_error | error ] 379 | let pp_error ppf (`Msg s) = Fmt.string ppf s 380 | 381 | let pp_write_error ppf = function 382 | | #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e 383 | | #error as e -> pp_error ppf e 384 | 385 | type flow = 386 | | Flow: string * (module CONCRETE with type flow = 'a) * 'a -> flow 387 | 388 | type t = flow 389 | 390 | let create (type a) (module M: Mirage_flow.S with type flow = a) t name = 391 | let m = (module Concrete(M): CONCRETE with type flow = a) in 392 | Flow (name, m , t) 393 | 394 | let read (Flow (_, (module F), flow)) = F.read flow 395 | let write (Flow (_, (module F), flow)) b = F.write flow b 396 | let writev (Flow (_, (module F), flow)) b = F.writev flow b 397 | let close (Flow (_, (module F), flow)) = F.close flow 398 | let shutdown (Flow (_, (module F), flow)) m = F.shutdown flow m 399 | let pp ppf (Flow (name, _, _)) = Fmt.string ppf name 400 | 401 | let forward ?(verbose=false) ~src ~dst () = 402 | let rec loop () = 403 | read src >>= function 404 | | Ok `Eof -> 405 | Log.err (fun l -> l "forward[%a => %a] EOF" pp src pp dst); 406 | Lwt.return_unit 407 | | Error e -> 408 | Log.err (fun l -> l "forward[%a => %a] %a" pp src pp dst pp_error e); 409 | Lwt.return_unit 410 | | Ok (`Data buf) -> 411 | Log.debug (fun l -> 412 | let payload = 413 | if verbose then Fmt.str "[%S]" @@ Cstruct.to_string buf 414 | else Fmt.str "%d bytes" (Cstruct.length buf) 415 | in 416 | l "forward[%a => %a] %s" pp src pp dst payload); 417 | write dst buf >>= function 418 | | Ok () -> loop () 419 | | Error e -> 420 | Log.err (fun l -> l "forward[%a => %a] %a" 421 | pp src pp dst pp_write_error e); 422 | Lwt.return_unit 423 | in 424 | loop () 425 | 426 | let proxy ?verbose f1 f2 = 427 | Lwt.join [ 428 | forward ?verbose ~src:f1 ~dst:f2 (); 429 | forward ?verbose ~src:f2 ~dst:f1 (); 430 | ] 431 | -------------------------------------------------------------------------------- /combinators/mirage_flow_combinators.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016-present David Scott 3 | * Copyright (c) 2011-present Anil Madhavapeddy 4 | * Copyright (c) 2013-present Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** {1 Flow-related devices using lwt} 20 | 21 | This module define flow-related devices for MirageOS, using lwt for I/O. 22 | 23 | {e Release %%VERSION%% } *) 24 | 25 | (** {1 Copy stats} *) 26 | 27 | type stats = { 28 | read_bytes: int64; 29 | read_ops: int64; 30 | write_bytes: int64; 31 | write_ops: int64; 32 | duration: int64; 33 | } 34 | (** The type for I/O statistics from a copy operation. *) 35 | 36 | val pp_stats: stats Fmt.t 37 | (** [pp_stats] is the pretty-printer for flow stats. *) 38 | 39 | (** [CONCRETE] expose the private row as [`Msg str] errors, using 40 | [pp_error] and [pp_write_error]. *) 41 | module type CONCRETE = Mirage_flow.S 42 | with type error = [ `Msg of string ] 43 | and type write_error = [ Mirage_flow.write_error | `Msg of string ] 44 | 45 | (** Functor to transform a {{!S}flow} signature using private rows for 46 | errors into concrete error types. *) 47 | module Concrete (S: Mirage_flow.S): CONCRETE with type flow = S.flow 48 | 49 | module Copy (A: Mirage_flow.S) (B: Mirage_flow.S): sig 50 | 51 | type error = [`A of A.error | `B of B.write_error] 52 | (** The type for copy errors. *) 53 | 54 | val pp_error: error Fmt.t 55 | (** [pp_error] pretty-prints errors. *) 56 | 57 | val copy: src:A.flow -> dst:B.flow -> (stats, error) result Lwt.t 58 | (** [copy source destination] copies data from [source] to 59 | [destination] using the clock to compute a transfer rate. On 60 | successful completion, some statistics are returned. On failure we 61 | return a printable error. *) 62 | 63 | end 64 | 65 | module Proxy (A: Mirage_flow.S) (B: Mirage_flow.S): 66 | sig 67 | 68 | type error 69 | (** The type for proxy errors. *) 70 | 71 | val pp_error: error Fmt.t 72 | (** [pp_error] pretty-prints errors. *) 73 | 74 | val proxy: A.flow -> B.flow -> 75 | ((stats * stats), error) result Lwt.t 76 | (** [proxy a b] proxies data between [a] and [b] until both 77 | sides close. If either direction encounters an error then so 78 | will [proxy]. If both directions succeed, then return I/O 79 | statistics. *) 80 | 81 | end 82 | 83 | module F: sig 84 | 85 | (** In-memory, function-based flows. *) 86 | 87 | include Mirage_flow.S 88 | 89 | type refill = Cstruct.t -> int -> int -> int Lwt.t 90 | (** The type for refill functions. *) 91 | 92 | val make: 93 | ?close:(unit -> unit Lwt.t) -> 94 | ?input:refill -> 95 | ?output:refill -> 96 | unit -> flow 97 | (** [make ~close ~input ~output ()] is a flow using [input] to 98 | refill its internal input buffer when needed and [output] to 99 | refill its external output buffer. It is using [close] to 100 | eventually clean-up other resources on close. *) 101 | 102 | (** {1 String flows} *) 103 | 104 | val input_string: string -> refill 105 | (** [input_string buf] is the refill function reading its inputs 106 | from the string [buf]. *) 107 | 108 | val output_bytes: bytes -> refill 109 | (** [output_bytes buf] is the refill function writing its outputs in 110 | the buffer [buf]. *) 111 | 112 | val string: ?input:string -> ?output:bytes -> unit -> flow 113 | (** The flow built using {!input_string} and {!output_bytes}. *) 114 | 115 | val input_strings: string list -> refill 116 | (** [input_strings bufs] is the refill function reading its inputs 117 | from the list of buffers [bufs]. Empty strings are ignored. *) 118 | 119 | val output_bytess: bytes list -> refill 120 | (** [output_bytess buf] is the refill function writing its outputs in 121 | the list of buffers [buf]. Empty strings are ignored. *) 122 | 123 | val strings: ?input:string list -> ?output:bytes list -> unit -> flow 124 | (** The flow built using {!input_strings} and {!output_bytess}. *) 125 | 126 | (** {1 Cstruct buffers flows} *) 127 | 128 | val input_cstruct: Cstruct.t -> refill 129 | (** Same as {!input_string} but for {!Cstruct.t} buffers. *) 130 | 131 | val output_cstruct: Cstruct.t -> refill 132 | (** Same as {!output_string} buf for {!Cstruct.t} buffers. *) 133 | 134 | val cstruct: ?input:Cstruct.t -> ?output:Cstruct.t -> unit -> flow 135 | (** Same as {!string} but for {!Cstruct.t} buffers. *) 136 | 137 | val input_cstructs: Cstruct.t list -> refill 138 | (** Same as {!input_strings} but for {!Cstruct.t} buffers. *) 139 | 140 | val output_cstructs: Cstruct.t list -> refill 141 | (** Same as {!output_strings} but for {!Cstruct.t} buffers. *) 142 | 143 | val cstructs: ?input:Cstruct.t list -> ?output:Cstruct.t list -> unit -> flow 144 | (** Same as {!strings} but for {!Cstruct.t} buffers. *) 145 | 146 | end 147 | 148 | type t 149 | (** The type for first-class flows. *) 150 | 151 | include Mirage_flow.S with type flow = t 152 | 153 | val create: (module Mirage_flow.S with type flow = 'a) -> 'a -> string -> t 154 | (** [create (module M) t name] is the flow representing [t] using the 155 | function defined in [M]. *) 156 | 157 | val pp: t Fmt.t 158 | (** [pp] is the pretty-printer for IO flows. *) 159 | 160 | val forward: ?verbose:bool -> src:t -> dst:t -> unit -> unit Lwt.t 161 | (** [forward ?verbose ~src ~dst ()] forwards writes from [src] to 162 | [dst]. Block until either [src] or [dst] is closed. If [verbose] 163 | is set (by default it is not), show the full flow contents in the debug 164 | messages. *) 165 | 166 | val proxy: ?verbose:bool -> t -> t -> unit Lwt.t 167 | (** [proxy ?verbose x y] is the same as [forward x y <*> forward y 168 | x]. Block until both flows are closed. If [verbose] is set (by 169 | default it is not), show the full flow contents in the debug 170 | messages. *) 171 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name mirage-flow) 3 | -------------------------------------------------------------------------------- /mirage-flow-combinators.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: ["Thomas Gazagnaire" "Dave Scott"] 4 | license: "ISC" 5 | tags: "org:mirage" 6 | homepage: "https://github.com/mirage/mirage-flow" 7 | doc: "https://mirage.github.io/mirage-flow/" 8 | bug-reports: "https://github.com/mirage/mirage-flow/issues" 9 | depends: [ 10 | "ocaml" {>= "4.08.0"} 11 | "dune" {>= "1.0"} 12 | "fmt" {>= "0.8.7"} 13 | "lwt" {>= "4.0.0"} 14 | "logs" 15 | "cstruct" {>= "6.0.0"} 16 | "mirage-mtime" {>= "4.0.0"} 17 | "mirage-flow" {= version} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | ["dune" "build" "-p" name "-j" jobs] 22 | ] 23 | dev-repo: "git+https://github.com/mirage/mirage-flow.git" 24 | synopsis: "Flow implementations and combinators for MirageOS specialized to lwt" 25 | description: """ 26 | This repo contains generic operations over Mirage `FLOW` implementations. 27 | 28 | Please consult [the API documentation](https://mirage.github.io/mirage-flow/index.html). 29 | """ 30 | x-maintenance-intent: ["(latest)"] 31 | -------------------------------------------------------------------------------- /mirage-flow-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: ["Thomas Gazagnaire" "Dave Scott"] 4 | license: "ISC" 5 | tags: "org:mirage" 6 | homepage: "https://github.com/mirage/mirage-flow" 7 | doc: "https://mirage.github.io/mirage-flow/" 8 | bug-reports: "https://github.com/mirage/mirage-flow/issues" 9 | depends: [ 10 | "ocaml" {>= "4.08.0"} 11 | "dune" {>= "1.0"} 12 | "fmt" {>= "0.8.7"} 13 | "logs" 14 | "mirage-flow" {= version} 15 | "lwt" {>= "4.0.0"} 16 | "cstruct" {>= "6.0.0"} 17 | "alcotest" {with-test} 18 | "mirage-flow-combinators" {with-test & = version} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | ["dune" "build" "-p" name "-j" jobs] 23 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 24 | ] 25 | dev-repo: "git+https://github.com/mirage/mirage-flow.git" 26 | synopsis: "Flow implementations and combinators for MirageOS on Unix" 27 | description: """ 28 | This repo contains generic operations over Mirage `FLOW` implementations. 29 | 30 | Please consult [the API documentation](https://mirage.github.io/mirage-flow/index.html). 31 | """ 32 | x-maintenance-intent: ["(latest)"] 33 | -------------------------------------------------------------------------------- /mirage-flow.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: ["Thomas Gazagnaire" "Dave Scott"] 4 | license: "ISC" 5 | tags: "org:mirage" 6 | homepage: "https://github.com/mirage/mirage-flow" 7 | doc: "https://mirage.github.io/mirage-flow/" 8 | bug-reports: "https://github.com/mirage/mirage-flow/issues" 9 | depends: [ 10 | "ocaml" {>= "4.08.0"} 11 | "dune" {>= "1.0"} 12 | "cstruct" {>= "4.0.0"} 13 | "fmt" 14 | "lwt" {>= "4.0.0"} 15 | ] 16 | build: [ 17 | ["dune" "subst"] {dev} 18 | ["dune" "build" "-p" name "-j" jobs] 19 | ] 20 | dev-repo: "git+https://github.com/mirage/mirage-flow.git" 21 | synopsis: "Flow implementations and combinators for MirageOS" 22 | description: """ 23 | This repo contains generic operations over Mirage `FLOW` implementations. 24 | 25 | Please consult [the API documentation](https://mirage.github.io/mirage-flow/index.html). 26 | """ 27 | x-maintenance-intent: ["(latest)"] 28 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_flow) 3 | (public_name mirage-flow) 4 | (libraries fmt lwt cstruct)) 5 | -------------------------------------------------------------------------------- /src/mirage_flow.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016-present David Scott 3 | * Copyright (c) 2011-present Anil Madhavapeddy 4 | * Copyright (c) 2013-present Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type write_error = [ `Closed ] 20 | 21 | let pp_write_error ppf = function 22 | | `Closed -> Fmt.pf ppf "attempted to write to a closed flow" 23 | 24 | type 'a or_eof = [`Data of 'a | `Eof ] 25 | 26 | let pp_or_eof d ppf = function 27 | | `Data a -> d ppf a 28 | | `Eof -> Fmt.string ppf "End-of-file" 29 | 30 | module type S = sig 31 | type error 32 | val pp_error: error Fmt.t 33 | type nonrec write_error = private [> write_error ] 34 | val pp_write_error: write_error Fmt.t 35 | type flow 36 | val read: flow -> (Cstruct.t or_eof, error) result Lwt.t 37 | val write: flow -> Cstruct.t -> (unit, write_error) result Lwt.t 38 | val writev: flow -> Cstruct.t list -> (unit, write_error) result Lwt.t 39 | val shutdown : flow -> [ `read | `write | `read_write ] -> unit Lwt.t 40 | val close: flow -> unit Lwt.t 41 | end 42 | -------------------------------------------------------------------------------- /src/mirage_flow.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011-2015 Anil Madhavapeddy 3 | * Copyright (c) 2013-2015 Thomas Gazagnaire 4 | * Copyright (c) 2013 Citrix Systems Inc 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** {1 Flow-related signatures} 20 | 21 | This module defines the flow signature for MirageOS. 22 | 23 | {e Release %%VERSION%% } *) 24 | 25 | type write_error = [ `Closed ] 26 | (** The type for generic write errors on flows. *) 27 | 28 | val pp_write_error: write_error Fmt.t 29 | (** [pp_write_error] is the pretty-printer for write errors. *) 30 | 31 | type 'a or_eof = [`Data of 'a | `Eof ] 32 | (** The type for read results on flows. *) 33 | 34 | val pp_or_eof: 'a Fmt.t -> 'a or_eof Fmt.t 35 | (** [pp_or_eof] is the pretty-printer for {!or_eof} values. *) 36 | 37 | (** Abstract flow signature. *) 38 | module type S = sig 39 | 40 | type error 41 | (** The type for flow errors. *) 42 | 43 | val pp_error: error Fmt.t 44 | (** [pp_error] is the pretty-printer for errors. *) 45 | 46 | type nonrec write_error = private [> write_error ] 47 | (** The type for write errors. *) 48 | 49 | val pp_write_error: write_error Fmt.t 50 | (** [pp_write_error] is the pretty-printer for write errors. *) 51 | 52 | type flow 53 | (** The type for flows. A flow represents the state of a single reliable 54 | stream that is connected to an endpoint. *) 55 | 56 | val read: flow -> (Cstruct.t or_eof, error) result Lwt.t 57 | (** [read flow] blocks until some data is available and returns a fresh buffer 58 | containing it. 59 | 60 | The returned buffer will be of a size convenient to the flow 61 | implementation, but will always have at least 1 byte. 62 | 63 | When [read] returns [`Eof] or an error, [close] (or [shutdown]) should be 64 | called on the [flow] by the client. Once [read] returned [`Eof] or an 65 | error, no subsequent [read] call will be successful. *) 66 | 67 | val write: flow -> Cstruct.t -> (unit, write_error) result Lwt.t 68 | (** [write flow buffer] writes a buffer to the flow. There is no indication 69 | when the buffer has actually been sent and, therefore, it must not be 70 | reused. The contents may be transmitted in separate packets, depending on 71 | the underlying transport. The result [Ok ()] indicates success, 72 | [Error `Closed] indicates that the connection is now closed and therefore 73 | the data could not be written. Other errors are possible. 74 | 75 | The promise is resolved when the buffer has been accepted by the 76 | implementation (if a partial write occured, [write] will wait until the 77 | remainder of the buffer has been accepted by the implementation). 78 | 79 | If [write] returns an error, [close] (or [shutdown]) should be called on 80 | the [flow] by the client. Once [write] returned an error, no subsequent 81 | [write] or [writev] call will be successful. *) 82 | 83 | val writev: flow -> Cstruct.t list -> (unit, write_error) result Lwt.t 84 | (** [writev flow buffers] writes a sequence of buffers to the flow. There is 85 | no indication when the buffers have actually been sent and, therefore, 86 | they must not be reused. The result [Ok ()] indicates success, 87 | [Error `Closed] indicates that the connection is now closed and therefore 88 | the data could not be written. Other errors are possible. 89 | 90 | The promise is resolved when the buffers have been accepted by the 91 | implementation (if a partial write occured, [writev] will wait until all 92 | buffers have been accepted by the implementation). 93 | 94 | If [writev] returns an error, [close] (or [shutdown]) should be called on 95 | the [flow] by the client. Once [writev] returned an error, no subsequent 96 | [writev] or [write] call will be successful. *) 97 | 98 | val shutdown : flow -> [ `read | `write | `read_write ] -> unit Lwt.t 99 | (** [shutdown flow mode] shuts down the [flow] for the specific [mode]: 100 | A flow which is [shutdown `read] (or [`read_write]) will never be [read] 101 | again (subsequent calls will return [`Eof]); a flow which is 102 | [shutdown `write] (or [`read_write]) flushes all pending writes and 103 | signals the remote endpoint there won't be any future [write] or [writev] 104 | calls (subsequent calls will return [`Closed]). E.g. in TCP, the 105 | signalling is done by sending a segment with the FIN flag. 106 | 107 | If this [flow] is layered upon another [flow'] (e.g. TLS over TCP), 108 | and the internal state after [shutdown] is [`Closed], [close] on the 109 | underlying [flow'] is executed. *) 110 | 111 | val close: flow -> unit Lwt.t 112 | (** [close flow] terminates the [flow] and frees all associated data. Any 113 | subsequent [read] or [write] will return an error. A subsequent [close] 114 | will not do anything (esp. not raising an exception), but it may log an 115 | error. 116 | 117 | If this [flow] is layered upon another [flow'] (e.g. TLS over TCP), 118 | [close] on the underlying [flow'] is executed. *) 119 | end 120 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package mirage-flow-unix) 4 | (libraries mirage-flow-combinators mirage-flow-unix alcotest)) 5 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt.Infix 18 | open Mirage_flow_combinators 19 | 20 | let pp_buf ppf buf = Fmt.string ppf (Cstruct.to_string buf) 21 | let eq_buf b1 b2 = Cstruct.to_string b1 = Cstruct.to_string b2 22 | 23 | let cstruct = Alcotest.testable pp_buf eq_buf 24 | let fail fmt = Fmt.kstr (fun s -> Alcotest.fail s) fmt 25 | 26 | let check_buffer = Alcotest.(check cstruct) 27 | let check_buffers = Alcotest.(check @@ list cstruct) 28 | 29 | let check_ok_buffer msg buf = function 30 | | Ok (`Data b) -> check_buffer msg buf b 31 | | Ok `Eof -> fail "%s: eof" msg 32 | | Error e -> fail "%s: error=%a" msg F.pp_error e 33 | 34 | let check_ok_unit msg = function 35 | | Ok () -> () 36 | | Error e -> fail "%s: error=%a" msg F.pp_error e 37 | 38 | let check_ok_write msg = function 39 | | Ok () -> () 40 | | Error e -> fail "%s: error=%a" msg F.pp_write_error e 41 | 42 | let check_closed msg = function 43 | | Ok () -> fail "%s: not closed" msg 44 | | Error `Closed -> () 45 | | Error e -> fail "%s: error=%a" msg F.pp_write_error e 46 | 47 | let check_eof msg = function 48 | | Ok `Eof -> () 49 | | Ok _ -> fail "%s: ok" msg 50 | | Error e -> fail "%s: error=%a" msg F.pp_error e 51 | 52 | let cs str = Cstruct.of_string str 53 | let cb str = Cstruct.of_bytes str 54 | 55 | let css = List.map cs 56 | let cbs = List.map cb 57 | 58 | let filter x = 59 | let zero = Cstruct.of_string "" in 60 | List.filter ((<>) zero) x 61 | 62 | let input_string () = 63 | let input = "xxxxxxxxxx" in 64 | let ic = F.string ~input () in 65 | F.read ic >>= fun x1 -> 66 | F.read ic >>= fun x2 -> 67 | F.write ic (cs "hihi") >>= fun r -> 68 | check_ok_buffer "read 1" (cs input) x1; 69 | check_eof "read 2" x2; 70 | check_closed "write" r; 71 | Lwt.return_unit 72 | 73 | let output_string () = 74 | let output = Bytes.of_string "xxxxxxxxxx" in 75 | let oc = F.string ~output () in 76 | F.write oc (cs "hell") >>= fun x1 -> 77 | F.write oc (cs "o! ") >>= fun x2 -> 78 | F.write oc (cs "world") >>= fun x3 -> 79 | F.read oc >>= fun r -> 80 | check_buffer "result" (cb output) (cs "hello! wor"); 81 | check_ok_write "write 1" x1; 82 | check_ok_write "write 2" x2; 83 | check_closed "write 3" x3; 84 | check_eof "read" r; 85 | Lwt.return_unit 86 | 87 | let input_strings () = 88 | let input = [ ""; "123"; "45"; "6789"; "0" ] in 89 | let ic = F.strings ~input () in 90 | F.read ic >>= fun x1 -> 91 | F.read ic >>= fun x2 -> 92 | F.read ic >>= fun x3 -> 93 | F.read ic >>= fun x4 -> 94 | F.read ic >>= fun y -> 95 | F.read ic >>= fun z -> 96 | F.write ic (cs "hihi") >>= fun w -> 97 | check_ok_buffer "read 1" (cs "123") x1; 98 | check_ok_buffer "read 2" (cs "45") x2; 99 | check_ok_buffer "read 3" (cs "6789") x3; 100 | check_ok_buffer "read 4" (cs "0") x4; 101 | check_eof "read 5" y; 102 | check_eof "read 6" z; 103 | check_closed "write" w; 104 | Lwt.return_unit 105 | 106 | let output_strings () = 107 | let output = List.map Bytes.of_string ["xxx"; ""; "xx"; "xxx"; ] in 108 | let oc = F.strings ~output () in 109 | F.write oc (cs "hell") >>= fun x1 -> 110 | F.write oc (cs "o! ") >>= fun x2 -> 111 | F.write oc (cs "world") >>= fun x3 -> 112 | F.read oc >>= fun r -> 113 | check_buffers "result" (filter (cbs output)) (css ["hel"; "lo"; "! w"]); 114 | check_ok_write "write 1" x1; 115 | check_ok_write "write 2" x2; 116 | check_closed "write 3" x3; 117 | check_eof "read" r; 118 | Lwt.return_unit 119 | 120 | let input_cstruct () = 121 | let input = Cstruct.of_string "xxxxxxxxxx" in 122 | let ic = F.cstruct ~input () in 123 | F.read ic >>= fun x1 -> 124 | F.read ic >>= fun x2 -> 125 | F.write ic (cs "hihi") >>= fun r -> 126 | check_ok_buffer "read 1" input x1; 127 | check_eof "read 2" x2; 128 | check_closed "write" r; 129 | Lwt.return_unit 130 | 131 | let output_cstruct () = 132 | let output = Cstruct.of_string "xxxxxxxxxx" in 133 | let oc = F.cstruct ~output () in 134 | F.write oc (cs "hell") >>= fun x1 -> 135 | F.write oc (cs "o! ") >>= fun x2 -> 136 | F.write oc (cs "world") >>= fun x3 -> 137 | F.read oc >>= fun r -> 138 | check_buffer "result" output (cs "hello! wor"); 139 | check_ok_write "write 1" x1; 140 | check_ok_write "write 2" x2; 141 | check_closed "write 3" x3; 142 | check_eof "read" r; 143 | Lwt.return_unit 144 | 145 | let input_cstructs () = 146 | let inputs = List.map cs [ "123"; "45"; ""; "6789"; "0" ] in 147 | let ic = F.cstructs ~input:inputs () in 148 | F.read ic >>= fun x1 -> 149 | F.read ic >>= fun x2 -> 150 | F.read ic >>= fun x3 -> 151 | F.read ic >>= fun x4 -> 152 | F.read ic >>= fun y -> 153 | F.read ic >>= fun z -> 154 | F.write ic (cs "hihi") >>= fun w -> 155 | check_ok_buffer "read 1" (cs "123") x1; 156 | check_ok_buffer "read 2" (cs "45") x2; 157 | check_ok_buffer "read 3" (cs "6789") x3; 158 | check_ok_buffer "read 4" (cs "0") x4; 159 | check_eof "read 5 "y; 160 | check_eof "read 6" z; 161 | check_closed "read 7" w; 162 | Lwt.return_unit 163 | 164 | let output_cstructs () = 165 | let output = List.map cs [ ""; "xxx"; "xx"; "xxx" ] in 166 | let oc = F.cstructs ~output () in 167 | F.write oc (cs "hell") >>= fun x1 -> 168 | F.write oc (cs "o! ") >>= fun x2 -> 169 | F.write oc (cs "world") >>= fun x3 -> 170 | F.read oc >>= fun r -> 171 | check_buffers "result" (filter output) (css ["hel"; "lo"; "! w"]); 172 | check_ok_write "write 1" x1; 173 | check_ok_write "write 2" x2; 174 | check_closed "write 3" x3; 175 | check_eof "read" r; 176 | Lwt.return_unit 177 | 178 | module Lwt_io_flow = Mirage_flow_unix.Make(F) 179 | 180 | let input_lwt_io () = 181 | let ic = F.strings ~input:["1"; "234"; "56"; "78\n90"] () in 182 | let lic = Lwt_io_flow.ic ic in 183 | Lwt_io.read_line lic >>= fun l -> 184 | check_buffer "result" (cs "12345678") (cs l); 185 | Lwt.return_unit 186 | 187 | let output_lwt_io () = 188 | let output = css ["xxxx";"xxxx"; "xxxxxx"] in 189 | let oc = F.cstructs ~output () in 190 | let loc = Lwt_io_flow.oc oc in 191 | Lwt_io.write_line loc "Hello world!" >>= fun () -> 192 | Lwt_io.flush loc >>= fun () -> 193 | check_buffers "result" (css ["Hell"; "o wo"; "rld!\nx"]) output; 194 | Lwt.return_unit 195 | 196 | let run f () = Lwt_main.run (f ()) 197 | 198 | let string = [ 199 | "input" , `Quick, run input_string; 200 | "output", `Quick, run output_string; 201 | ] 202 | 203 | let strings = [ 204 | "input" , `Quick, run input_strings; 205 | "output", `Quick, run output_strings; 206 | ] 207 | 208 | let cstruct = [ 209 | "input" , `Quick, run input_cstruct; 210 | "output", `Quick, run output_cstruct; 211 | ] 212 | 213 | let cstructs = [ 214 | "input" , `Quick, run input_cstructs; 215 | "output", `Quick, run output_cstructs; 216 | ] 217 | 218 | let lwt_io = [ 219 | "input" , `Quick, run input_lwt_io; 220 | "output", `Quick, run output_lwt_io; 221 | ] 222 | let () = 223 | Alcotest.run "mirage-flow" [ 224 | "string" , string; 225 | "strings" , strings; 226 | "cstruct" , cstruct; 227 | "cstructs", cstructs; 228 | "lwt-io" , lwt_io; 229 | ] 230 | -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_flow_unix) 3 | (public_name mirage-flow-unix) 4 | (libraries mirage-flow lwt.unix logs) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /unix/mirage_flow_unix.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015-present Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt.Infix 18 | 19 | let src = Logs.Src.create "mirage-flow-unix" 20 | module Log = (val Logs.src_log src : Logs.LOG) 21 | 22 | module Make (F: Mirage_flow.S) = struct 23 | 24 | let reader t = 25 | let frag = ref (Cstruct.create 0) in 26 | let rec aux buf ofs len = 27 | if len = 0 28 | then Lwt.return 0 29 | else 30 | let available = Cstruct.length !frag in 31 | if available = 0 then begin 32 | F.read t >>= function 33 | | Ok (`Data b) -> 34 | frag := b; 35 | aux buf ofs len 36 | | Ok `Eof -> Lwt.return 0 37 | | Error e -> 38 | Lwt.fail_with @@ Fmt.str "Lwt_io_flow.reader: %a" F.pp_error e 39 | end else begin 40 | let n = min available len in 41 | Cstruct.blit !frag 0 (Cstruct.of_bigarray buf) ofs n; 42 | frag := Cstruct.shift !frag n; 43 | Lwt.return n 44 | end in 45 | aux 46 | 47 | let writer t buf ofs len = 48 | let b = Cstruct.sub (Cstruct.of_bigarray buf) ofs len in 49 | F.write t b >>= function 50 | | Ok () -> Lwt.return len 51 | | Error `Closed -> Lwt.return 0 52 | | Error e -> 53 | Lwt.fail_with @@ Fmt.str "Lwt_io_flow.writer: %a" F.pp_write_error e 54 | 55 | let ic ?(buffer_size=1024) ?(close=true) t = 56 | let close () = if close then F.close t else Lwt.return_unit in 57 | let buffer = Lwt_bytes.create buffer_size in 58 | Lwt_io.make ~buffer ~mode:Lwt_io.input ~close (reader t) 59 | 60 | let oc ?(buffer_size=1024) ?(close=false) t = 61 | let close () = if close then F.close t else Lwt.return_unit in 62 | let buffer = Lwt_bytes.create buffer_size in 63 | Lwt_io.make ~buffer ~mode:Lwt_io.output ~close (writer t) 64 | 65 | end 66 | 67 | module Fd = struct 68 | 69 | type error = [`Msg of string] 70 | type write_error = [ Mirage_flow.write_error | error ] 71 | 72 | let pp_error ppf (`Msg s) = Fmt.string ppf s 73 | 74 | let pp_write_error ppf = function 75 | | #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e 76 | | #error as e -> pp_error ppf e 77 | 78 | type flow = Lwt_unix.file_descr 79 | 80 | let err e = Lwt.return (Error (`Msg (Printexc.to_string e))) 81 | 82 | let failf fmt = Fmt.kstr Lwt.fail_with fmt 83 | 84 | let pp_fd ppf (t:Lwt_unix.file_descr) = 85 | Fmt.int ppf (Obj.magic (Lwt_unix.unix_file_descr t): int) 86 | 87 | let rec really_write fd buf off len = 88 | match len with 89 | | 0 -> Lwt.return_unit 90 | | len -> 91 | Log.debug (fun l -> l "really_write %a off=%d len=%d" pp_fd fd off len); 92 | Lwt_unix.write fd buf off len >>= fun n -> 93 | if n = 0 then Lwt.fail_with "write 0" 94 | else really_write fd buf (off+n) (len-n) 95 | 96 | let write_all fd buf = really_write fd buf 0 (Bytes.length buf) 97 | 98 | let read_all fd = 99 | Log.debug (fun l -> l "read_all %a" pp_fd fd); 100 | let len = 16 * 1024 in 101 | let buf = Bytes.create len in 102 | let rec loop acc = 103 | Lwt_unix.read fd buf 0 len >>= fun n -> 104 | if n = 0 then failf "read %a: 0" pp_fd fd 105 | else 106 | let acc = Bytes.sub buf 0 n :: acc in 107 | if n <= len then Lwt.return (List.rev acc) 108 | else loop acc 109 | in 110 | loop [] >|= fun bufs -> 111 | Bytes.concat (Bytes.create 0) bufs 112 | 113 | let read t = 114 | Lwt.catch (fun () -> 115 | read_all t >|= fun buf -> Ok (`Data (Cstruct.of_bytes buf)) 116 | ) (function Failure _ -> Lwt.return (Ok `Eof) | e -> err e) 117 | 118 | let write t b = 119 | Lwt.catch (fun () -> 120 | write_all t (Cstruct.to_bytes b) >|= fun () -> Ok () 121 | ) (fun e -> err e) 122 | 123 | let close t = Lwt_unix.close t 124 | 125 | let shutdown t mode = 126 | let cmd = Lwt_unix.(match mode with 127 | | `read -> SHUTDOWN_RECEIVE 128 | | `write -> SHUTDOWN_SEND 129 | | `read_write -> SHUTDOWN_ALL) 130 | in 131 | Lwt.return (Lwt_unix.shutdown t cmd) 132 | 133 | let writev t bs = 134 | Lwt.catch (fun () -> 135 | Lwt_list.iter_s (fun b -> write_all t (Cstruct.to_bytes b)) bs 136 | >|= fun () -> Ok () 137 | ) (fun e -> err e) 138 | 139 | end 140 | -------------------------------------------------------------------------------- /unix/mirage_flow_unix.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015-present Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Conversion from mirage flows to Lwt_io channels. *) 18 | 19 | module Make (F: Mirage_flow.S): sig 20 | 21 | val ic: ?buffer_size:int -> ?close:bool -> F.flow -> Lwt_io.input_channel 22 | (** Build an [Lwt_io] input channel from a mirage flow. If [close] 23 | is omitted, the mirage flow will be closed when the input 24 | channel is closed. *) 25 | 26 | val oc: ?buffer_size:int -> ?close:bool -> F.flow -> Lwt_io.output_channel 27 | (** Build an [Lwt_io] output channel from a mirage flow. If [close] 28 | is omitted, the mirage flow will {e not} be closed when the 29 | output channel is closed. *) 30 | 31 | end 32 | 33 | module Fd: Mirage_flow.S with type flow = Lwt_unix.file_descr 34 | --------------------------------------------------------------------------------