├── .github └── workflows │ └── test.yml ├── .gitignore ├── LICENSE ├── META.faraday.template ├── Makefile ├── README.md ├── async ├── dune ├── faraday_async.ml └── faraday_async.mli ├── dune-project ├── examples ├── dune └── rFC7159.ml ├── faraday-async.opam ├── faraday-lwt-unix.opam ├── faraday-lwt.opam ├── faraday.opam ├── lib ├── dune ├── faraday.ml └── faraday.mli ├── lib_test ├── dune └── test_faraday.ml ├── lwt ├── dune ├── faraday_lwt.ml └── faraday_lwt.mli └── lwt_unix ├── dune ├── faraday_lwt_unix.ml └── faraday_lwt_unix.mli /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | builds: 9 | name: Earliest Supported Version 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | os: 14 | - ubuntu-latest 15 | ocaml-version: 16 | - 4.03.0 17 | 18 | runs-on: ${{ matrix.os }} 19 | 20 | steps: 21 | - name: Checkout code 22 | uses: actions/checkout@v2 23 | 24 | - name: Use OCaml ${{ matrix.ocaml-version }} 25 | uses: avsm/setup-ocaml@v1 26 | with: 27 | ocaml-version: ${{ matrix.ocaml-version }} 28 | 29 | - name: Deps 30 | run: | 31 | opam pin add -n faraday . 32 | opam install --deps-only faraday 33 | 34 | - name: Build 35 | run: opam exec -- dune build -p faraday 36 | 37 | tests: 38 | name: Tests 39 | strategy: 40 | fail-fast: false 41 | matrix: 42 | os: 43 | - ubuntu-latest 44 | ocaml-version: 45 | - 4.08.1 46 | - 4.10.2 47 | - 4.11.2 48 | - 4.12.0 49 | 50 | runs-on: ${{ matrix.os }} 51 | 52 | steps: 53 | - name: Checkout code 54 | uses: actions/checkout@v2 55 | 56 | - name: Use OCaml ${{ matrix.ocaml-version }} 57 | uses: avsm/setup-ocaml@v1 58 | with: 59 | ocaml-version: ${{ matrix.ocaml-version }} 60 | 61 | - name: Deps 62 | run: | 63 | opam pin add -n faraday . 64 | opam pin add -n faraday-async . 65 | opam pin add -n faraday-lwt . 66 | opam pin add -n faraday-lwt-unix . 67 | opam install -t --deps-only . 68 | 69 | - name: Build 70 | run: opam exec -- dune build 71 | 72 | - name: Test 73 | run: opam exec -- dune runtest 74 | 75 | - name: Examples 76 | run: | 77 | opam exec -- make examples 78 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.sw[a-z] 2 | *~ 3 | _build/ 4 | _tests/ 5 | lib_test/tests_ 6 | setup.log 7 | setup.data 8 | *.native 9 | *.byte 10 | *.docdir 11 | *.install 12 | .merlin 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Inhabited Type LLC 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /META.faraday.template: -------------------------------------------------------------------------------- 1 | # JBUILDER_GEN 2 | 3 | package "lwt" ( 4 | description = "Deprecated. Use faraday-lwt directly" 5 | requires = "faraday-lwt" 6 | ) 7 | 8 | package "lwt-unix" ( 9 | description = "Deprecated. Use faraday-lwt-unix directly" 10 | requires = "faraday-lwt-unix" 11 | ) 12 | 13 | package "async" ( 14 | description = "Deprecated. Use faraday-async directly" 15 | requires = "faraday-async" 16 | ) -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all build clean test examples 2 | 3 | build: 4 | dune build @install 5 | 6 | all: build 7 | 8 | doc: 9 | dune build @doc 10 | 11 | test: 12 | dune runtest 13 | 14 | examples: 15 | dune build @examples 16 | 17 | install: 18 | dune install 19 | 20 | uninstall: 21 | dune uninstall 22 | 23 | clean: 24 | rm -rf _build *.install 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Faraday 2 | 3 | Faraday is a library for writing fast and memory-efficient serializers. Its 4 | core type and related operation gives the user fine-grained control over 5 | copying and allocation behavior while serializing user-defined types, and 6 | presents the output in a form that makes it possible to use vectorized write 7 | operations, such as the [writev][] system call, or any other platform or 8 | application-specific output APIs. 9 | 10 | 11 | [![Build Status](https://github.com/inhabitedtype/faraday/workflows/build/badge.svg)](https://github.com/inhabitedtype/faraday/actions?query=workflow%3A%22build%22) 12 | 13 | [writev]: http://man7.org/linux/man-pages/man2/writev.2.html 14 | 15 | ## Installation 16 | 17 | Install the library and its depenencies via [OPAM][opam]: 18 | 19 | [opam]: http://opam.ocaml.org/ 20 | 21 | ```bash 22 | opam install faraday 23 | ``` 24 | 25 | ## Usage 26 | 27 | Like its sister project [Angstrom][], Faraday is written with network protocols 28 | and serialization formats in mind. As such, its source distribution inclues 29 | implementations of various RFCs that are illustrative of real-world 30 | applications of the library. This includes a [JSON serializer][json]. 31 | 32 | [angstrom]: https://github.com/inhabitedtype/angstrom 33 | [json]: https://github.com/inhabitedtype/faraday/blob/master/examples/rFC7159.ml 34 | 35 | In addition, it's appropriate here to include a serializer for the simple 36 | arithmetic expression language described in Angstrom's README. 37 | 38 | ```ocaml 39 | open Faraday 40 | 41 | type 'a binop = [ 42 | | `Sub of 'a * 'a 43 | | `Add of 'a * 'a 44 | | `Div of 'a * 'a 45 | | `Mul of 'a * 'a 46 | ] 47 | ;; 48 | 49 | type t = [ `Num of int | t binop ] 50 | 51 | let rec serialize ?(prec=0) t expr = 52 | match expr with 53 | | `Num n -> write_string t (Printf.sprintf "%d" n) 54 | | #binop as binop -> 55 | let prec', op, l, r = 56 | match binop with 57 | | `Sub(l, r) -> 2, '-', l, r 58 | | `Add(l, r) -> 3, '+', l, r 59 | | `Div(l, r) -> 4, '/', l, r 60 | | `Mul(l, r) -> 5, '*', l, r 61 | in 62 | if prec' < prec then write_char t '('; 63 | serialize t ~prec:prec' l; 64 | write_char t op; 65 | serialize t ~prec:prec' r; 66 | if prec' < prec then write_char t ')' 67 | 68 | let to_string expr = 69 | let t = create 0x1000 in 70 | serialize t expr; 71 | serialize_to_string t 72 | ``` 73 | 74 | ## Development 75 | 76 | To install development dependencies, pin the package from the root of the 77 | repository: 78 | 79 | ```bash 80 | opam pin add -n faraday . 81 | opam install --deps-only faraday 82 | ``` 83 | 84 | After this, you may install a development version of the library using the 85 | install command as usual. 86 | 87 | For building and running the tests during development, you will need to install 88 | the `alcotest` package: 89 | 90 | ```bash 91 | opam install alcotest 92 | make test 93 | ``` 94 | 95 | ## License 96 | 97 | BSD3, see LICENSE file for its text. 98 | -------------------------------------------------------------------------------- /async/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name faraday_async) 3 | (public_name faraday-async) 4 | (libraries faraday async core_unix) 5 | (flags (:standard -safe-string))) 6 | -------------------------------------------------------------------------------- /async/faraday_async.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | module Unix = Core_unix 5 | 6 | 7 | let serialize t ~yield ~writev = 8 | let shutdown () = 9 | Faraday.close t; 10 | (* It's necessary to drain the serializer in order to free any buffers that 11 | * be queued up. *) 12 | ignore (Faraday.drain t) 13 | in 14 | let rec loop t = 15 | match Faraday.operation t with 16 | | `Writev iovecs -> 17 | writev iovecs 18 | >>= (function 19 | | `Closed -> shutdown (); return () (* XXX(seliopou): this should be reported *) 20 | | `Ok n -> Faraday.shift t n; loop t) 21 | | `Yield -> 22 | yield t >>= fun () -> loop t 23 | | `Close -> return () 24 | in 25 | try_with 26 | ~rest:`Log (* consider [`Raise] instead *) 27 | ~run:`Schedule (* consider [`Now] instead *) 28 | ~extract_exn:true (fun () -> loop t) 29 | >>| function 30 | | Result.Ok () -> () 31 | | Result.Error exn -> 32 | shutdown (); 33 | raise exn 34 | 35 | let writev_of_fd fd = 36 | let badfd = 37 | failwithf "writev_of_fd got bad fd: %s" (Fd.to_string fd) 38 | in 39 | let finish result = 40 | let open Unix.Error in 41 | match result with 42 | | `Ok n -> return (`Ok n) 43 | | `Already_closed -> return `Closed 44 | | `Error (Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _)) -> 45 | begin Fd.ready_to fd `Write 46 | >>| function 47 | | `Bad_fd -> badfd () 48 | | `Closed -> `Closed 49 | | `Ready -> `Ok 0 50 | end 51 | | `Error (Unix.Unix_error (EBADF, _, _)) -> 52 | badfd () 53 | | `Error exn -> 54 | Deferred.don't_wait_for (Fd.close fd); 55 | raise exn 56 | in 57 | fun iovecs -> 58 | let iovecs = Array.of_list_map iovecs ~f:(fun iovec -> 59 | let { Faraday.buffer; off = pos; len } = iovec in 60 | Unix.IOVec.of_bigstring ~pos ~len buffer) 61 | in 62 | if Fd.supports_nonblock fd then 63 | finish 64 | (Fd.syscall fd ~nonblocking:true 65 | (fun file_descr -> 66 | Bigstring_unix.writev_assume_fd_is_nonblocking file_descr iovecs)) 67 | else 68 | Fd.syscall_in_thread fd ~name:"writev" 69 | (fun file_descr -> Bigstring_unix.writev file_descr iovecs) 70 | >>= finish 71 | -------------------------------------------------------------------------------- /async/faraday_async.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Async 3 | 4 | open Faraday 5 | 6 | 7 | val serialize 8 | : Faraday.t 9 | -> yield : (t -> unit Deferred.t) 10 | -> writev : (bigstring iovec list -> [ `Ok of int | `Closed ] Deferred.t) 11 | -> unit Deferred.t 12 | 13 | val writev_of_fd 14 | : Fd.t 15 | -> bigstring iovec list -> [ `Ok of int | `Closed ] Deferred.t 16 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.11) 2 | (name faraday) 3 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name RFC7159) 3 | (modules RFC7159) 4 | (libraries faraday)) 5 | 6 | (alias 7 | (name examples) 8 | (deps RFC7159.cmxa)) 9 | -------------------------------------------------------------------------------- /examples/rFC7159.ml: -------------------------------------------------------------------------------- 1 | open Faraday 2 | 3 | type json = 4 | [ `Null 5 | | `False 6 | | `True 7 | | `String of string 8 | | `Number of float 9 | | `Object of (string * json) list 10 | | `Array of json list ] 11 | 12 | let to_hex_digit i = 13 | Char.unsafe_chr (if i < 10 then i + 48 else i + 87) 14 | 15 | let serialize_string t s = 16 | (* TODO: Implement proper unicode verification. *) 17 | let flush ~off ~len = 18 | if len <> 0 then write_string t ~off ~len s in 19 | let rec go ~off ~len = 20 | if String.length s = off + len 21 | then flush ~off ~len 22 | else 23 | let i = off + len in 24 | match String.get s i with 25 | | c when c <= '\031' -> (* non-visible characters have to be escaped *) 26 | let i = Char.code c in 27 | flush ~off ~len; 28 | write_string t "\\u00"; 29 | write_char t (to_hex_digit (i lsr 4)); 30 | write_char t (to_hex_digit (i land 0xf)); 31 | go ~off:(i+1) ~len:0 32 | | '"' -> flush ~off ~len; write_string t "\\" ; go ~off:(i+1) ~len:0 33 | | '/' -> flush ~off ~len; write_string t "\\/" ; go ~off:(i+1) ~len:0 34 | | '\b' -> flush ~off ~len; write_string t "\\b" ; go ~off:(i+1) ~len:0 35 | | '\012' -> flush ~off ~len; write_string t "\\f" ; go ~off:(i+1) ~len:0 36 | | '\n' -> flush ~off ~len; write_string t "\\n" ; go ~off:(i+1) ~len:0 37 | | '\r' -> flush ~off ~len; write_string t "\\r" ; go ~off:(i+1) ~len:0 38 | | '\t' -> flush ~off ~len; write_string t "\\t" ; go ~off:(i+1) ~len:0 39 | | '\\' -> flush ~off ~len; write_string t "\\\\"; go ~off:(i+1) ~len:0 40 | | _ -> go ~off ~len:(len + 1) 41 | in 42 | write_char t '"'; 43 | go ~off:0 ~len:0; 44 | write_char t '"' 45 | 46 | let serialize_number t f = 47 | let f = string_of_float f in 48 | let len = String.length f in 49 | let len = if String.get f (len - 1) = '.' then len - 1 else len in 50 | write_string t ~len f 51 | 52 | let rec serialize_json t json = 53 | match json with 54 | | `Null -> write_string t "null" 55 | | `True -> write_string t "true" 56 | | `False -> write_string t "false" 57 | | `Number n -> serialize_number t n 58 | | `String s -> serialize_string t s 59 | | `Object [] -> write_string t "{}" 60 | | `Object ((k, v)::kvs) -> 61 | write_char t '{'; 62 | serialize_kv t k v; 63 | List.iter (fun (k, v) -> 64 | write_char t ','; 65 | serialize_kv t k v) 66 | kvs; 67 | write_char t '}'; 68 | | `Array [] -> write_string t "[]" 69 | | `Array (v::vs) -> 70 | write_char t '['; 71 | serialize_json t v; 72 | List.iter (fun v -> 73 | write_char t ','; 74 | serialize_json t v) 75 | vs; 76 | write_char t ']' 77 | 78 | and serialize_kv t k v = 79 | serialize_string t k; 80 | write_char t ':'; 81 | serialize_json t v 82 | -------------------------------------------------------------------------------- /faraday-async.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Spiros Eliopoulos " 3 | authors: [ "Spiros Eliopoulos " ] 4 | license: "BSD-3-clause" 5 | homepage: "https://github.com/inhabitedtype/faraday" 6 | bug-reports: "https://github.com/inhabitedtype/faraday/issues" 7 | dev-repo: "git+https://github.com/inhabitedtype/faraday.git" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.08.0"} 15 | "dune" {>= "1.11"} 16 | "faraday" {>= "0.5.0"} 17 | "core" {>= "v0.14.0"} 18 | "core_unix" {>= "v0.14.0"} 19 | "async" {>= "v0.14.0"} 20 | ] 21 | synopsis: "Async support for Faraday" 22 | -------------------------------------------------------------------------------- /faraday-lwt-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Spiros Eliopoulos " 3 | authors: [ "Spiros Eliopoulos " ] 4 | license: "BSD-3-clause" 5 | homepage: "https://github.com/inhabitedtype/faraday" 6 | bug-reports: "https://github.com/inhabitedtype/faraday/issues" 7 | dev-repo: "git+https://github.com/inhabitedtype/faraday.git" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.03.0"} 15 | "dune" {>= "1.11"} 16 | "faraday-lwt" 17 | "lwt" {>= "2.7.0"} 18 | "base-unix" 19 | ] 20 | synopsis: "Lwt_unix support for Faraday" 21 | -------------------------------------------------------------------------------- /faraday-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Spiros Eliopoulos " 3 | authors: [ "Spiros Eliopoulos " ] 4 | license: "BSD-3-clause" 5 | homepage: "https://github.com/inhabitedtype/faraday" 6 | bug-reports: "https://github.com/inhabitedtype/faraday/issues" 7 | dev-repo: "git+https://github.com/inhabitedtype/faraday.git" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.03.0"} 15 | "dune" {>= "1.11"} 16 | "faraday" {>= "0.5.0"} 17 | "lwt" 18 | ] 19 | synopsis: "Lwt support for Faraday" 20 | -------------------------------------------------------------------------------- /faraday.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Spiros Eliopoulos " 3 | authors: [ "Spiros Eliopoulos " ] 4 | license: "BSD-3-clause" 5 | homepage: "https://github.com/inhabitedtype/faraday" 6 | bug-reports: "https://github.com/inhabitedtype/faraday/issues" 7 | dev-repo: "git+https://github.com/inhabitedtype/faraday.git" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.03.0"} 15 | "dune" {>= "1.11"} 16 | "alcotest" {with-test & >= "0.4.1"} 17 | "bigstringaf" 18 | ] 19 | synopsis: "A library for writing fast and memory-efficient serializers" 20 | description: """ 21 | Faraday is a library for writing fast and memory-efficient serializers. Its 22 | core type and related operation gives the user fine-grained control over 23 | copying and allocation behavior while serializing user-defined types, and 24 | presents the output in a form that makes it possible to use vectorized write 25 | operations, such as the writev system call, or any other platform or 26 | application-specific output APIs.""" 27 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name faraday) 3 | (public_name faraday) 4 | (libraries bigstringaf) 5 | (flags (:standard -safe-string))) 6 | -------------------------------------------------------------------------------- /lib/faraday.ml: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2016 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | 35 | type bigstring = Bigstringaf.t 36 | 37 | type 'a iovec = 38 | { buffer : 'a 39 | ; off : int 40 | ; len : int } 41 | 42 | exception Dequeue_empty 43 | 44 | module Deque(T:sig type t val sentinel : t end) : sig 45 | type elem = T.t 46 | 47 | type t 48 | 49 | val create : int -> t 50 | 51 | val is_empty : t -> bool 52 | 53 | val enqueue : elem -> t -> unit 54 | val dequeue_exn : t -> elem 55 | val enqueue_front : elem -> t -> unit 56 | 57 | val map_to_list : t -> f:(elem -> 'b) -> 'b list 58 | end = struct 59 | type elem = T.t 60 | 61 | type t = 62 | { mutable elements : elem array 63 | ; mutable front : int 64 | ; mutable back : int } 65 | 66 | let sentinel = T.sentinel 67 | 68 | let create size = 69 | { elements = Array.make size sentinel; front = 0; back = 0 } 70 | 71 | let is_empty t = 72 | t.front = t.back 73 | 74 | let ensure_space t = 75 | if t.back = Array.length t.elements - 1 then begin 76 | let len = t.back - t.front in 77 | if t.front > 0 then begin 78 | (* Shift everything to the front of the array and then clear out 79 | * dangling pointers to elements from their previous locations. *) 80 | Array.blit t.elements t.front t.elements 0 len; 81 | Array.fill t.elements len t.front sentinel 82 | end else begin 83 | let old = t.elements in 84 | let new_ = Array.(make (2 * length old) sentinel) in 85 | Array.blit old t.front new_ 0 len; 86 | t.elements <- new_ 87 | end; 88 | t.front <- 0; 89 | t.back <- len 90 | end 91 | 92 | let enqueue e t = 93 | ensure_space t; 94 | t.elements.(t.back) <- e; 95 | t.back <- t.back + 1 96 | 97 | let dequeue_exn t = 98 | if is_empty t then 99 | raise_notrace Dequeue_empty 100 | else 101 | let result = Array.unsafe_get t.elements t.front in 102 | Array.unsafe_set t.elements t.front sentinel; 103 | t.front <- t.front + 1; 104 | result 105 | 106 | let enqueue_front e t = 107 | (* This is in general not true for Deque data structures, but the usage 108 | * below ensures that there is always space to push an element back on the 109 | * front. An [enqueue_front] is always preceded by a [dequeue], with no 110 | * intervening operations. *) 111 | assert (t.front > 0); 112 | t.front <- t.front - 1; 113 | t.elements.(t.front) <- e 114 | 115 | let map_to_list t ~f = 116 | let result = ref [] in 117 | for i = t.back - 1 downto t.front do 118 | result := f t.elements.(i) :: !result 119 | done; 120 | !result 121 | end 122 | 123 | module IOVec = struct 124 | let create buffer ~off ~len = 125 | { buffer; off; len } 126 | 127 | let length t = 128 | t.len 129 | 130 | let shift { buffer; off; len } n = 131 | assert (n < len); 132 | { buffer; off = off + n; len = len - n } 133 | 134 | let lengthv ts = 135 | let rec loop ts acc = 136 | match ts with 137 | | [] -> acc 138 | | iovec::ts -> loop ts (length iovec + acc) 139 | in 140 | loop ts 0 141 | end 142 | 143 | module Flushed_reason = struct 144 | type t = Shift | Drain | Nothing_pending 145 | end 146 | 147 | module Buffers = Deque(struct 148 | type t = bigstring iovec 149 | let sentinel = 150 | let deadbeef = "\222\173\190\239" in 151 | let len = String.length deadbeef in 152 | let buffer = Bigstringaf.create len in 153 | String.iteri (Bigstringaf.unsafe_set buffer) deadbeef; 154 | { buffer; off = 0; len } 155 | end) 156 | module Flushes = Deque(struct 157 | type t = int * (Flushed_reason.t -> unit) 158 | let sentinel = 0, fun _ -> () 159 | end) 160 | 161 | type t = 162 | { mutable buffer : bigstring 163 | ; mutable scheduled_pos : int 164 | ; mutable write_pos : int 165 | ; scheduled : Buffers.t 166 | ; flushed : Flushes.t 167 | ; mutable bytes_received : int 168 | ; mutable bytes_written : int 169 | ; mutable closed : bool 170 | ; mutable yield : bool 171 | } 172 | 173 | type operation = [ 174 | | `Writev of bigstring iovec list 175 | | `Yield 176 | | `Close 177 | ] 178 | 179 | let of_bigstring buffer = 180 | { buffer 181 | ; write_pos = 0 182 | ; scheduled_pos = 0 183 | ; scheduled = Buffers.create 4 184 | ; flushed = Flushes.create 1 185 | ; bytes_received = 0 186 | ; bytes_written = 0 187 | ; closed = false 188 | ; yield = false } 189 | 190 | let create size = 191 | of_bigstring (Bigstringaf.create size) 192 | 193 | let writable_exn t = 194 | if t.closed then 195 | failwith "cannot write to closed writer" 196 | 197 | let schedule_iovec t ?(off=0) ~len buffer = 198 | t.bytes_received <- t.bytes_received + len; 199 | Buffers.enqueue (IOVec.create buffer ~off ~len) t.scheduled 200 | 201 | let flush_buffer t = 202 | let len = t.write_pos - t.scheduled_pos in 203 | if len > 0 then begin 204 | let off = t.scheduled_pos in 205 | schedule_iovec t ~off ~len t.buffer; 206 | t.scheduled_pos <- t.write_pos 207 | end 208 | 209 | let flush_with_reason t f = 210 | t.yield <- false; 211 | flush_buffer t; 212 | if Buffers.is_empty t.scheduled then f Flushed_reason.Nothing_pending 213 | else Flushes.enqueue (t.bytes_received, f) t.flushed 214 | 215 | let flush t f = flush_with_reason t (fun _ -> f ()) 216 | 217 | let free_bytes_in_buffer t = 218 | let buf_len = Bigstringaf.length t.buffer in 219 | buf_len - t.write_pos 220 | 221 | let schedule_bigstring t ?(off=0) ?len a = 222 | writable_exn t; 223 | flush_buffer t; 224 | let len = 225 | match len with 226 | | None -> Bigstringaf.length a - off 227 | | Some len -> len 228 | in 229 | if len > 0 then schedule_iovec t ~off ~len a 230 | 231 | let ensure_space t len = 232 | if free_bytes_in_buffer t < len then begin 233 | flush_buffer t; 234 | t.buffer <- Bigstringaf.create (max (Bigstringaf.length t.buffer) len); 235 | t.write_pos <- 0; 236 | t.scheduled_pos <- 0 237 | end 238 | 239 | let write_gen t ~length ~blit ?(off=0) ?len a = 240 | writable_exn t; 241 | let len = 242 | match len with 243 | | None -> length a - off 244 | | Some len -> len 245 | in 246 | ensure_space t len; 247 | blit a ~src_off:off t.buffer ~dst_off:t.write_pos ~len; 248 | t.write_pos <- t.write_pos + len 249 | 250 | let write_string = 251 | let length = String.length in 252 | let blit = Bigstringaf.unsafe_blit_from_string in 253 | fun t ?off ?len a -> write_gen t ~length ~blit ?off ?len a 254 | 255 | let write_bytes = 256 | let length = Bytes.length in 257 | let blit = Bigstringaf.unsafe_blit_from_bytes in 258 | fun t ?off ?len a -> write_gen t ~length ~blit ?off ?len a 259 | 260 | let write_bigstring = 261 | let length = Bigstringaf.length in 262 | let blit = Bigstringaf.unsafe_blit in 263 | fun t ?off ?len a -> write_gen t ~length ~blit ?off ?len a 264 | 265 | let write_char t c = 266 | writable_exn t; 267 | ensure_space t 1; 268 | Bigstringaf.unsafe_set t.buffer t.write_pos c; 269 | t.write_pos <- t.write_pos + 1 270 | 271 | let write_uint8 t b = 272 | writable_exn t; 273 | ensure_space t 1; 274 | Bigstringaf.unsafe_set t.buffer t.write_pos (Char.unsafe_chr b); 275 | t.write_pos <- t.write_pos + 1 276 | 277 | module BE = struct 278 | let write_uint16 t i = 279 | writable_exn t; 280 | ensure_space t 2; 281 | Bigstringaf.unsafe_set_int16_be t.buffer t.write_pos i; 282 | t.write_pos <- t.write_pos + 2 283 | 284 | let write_uint32 t i = 285 | writable_exn t; 286 | ensure_space t 4; 287 | Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos i; 288 | t.write_pos <- t.write_pos + 4 289 | 290 | let write_uint48 t i = 291 | writable_exn t; 292 | ensure_space t 6; 293 | Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos 294 | Int64.(to_int32 (shift_right_logical i 4)); 295 | Bigstringaf.unsafe_set_int16_be t.buffer (t.write_pos + 2) 296 | Int64.(to_int i); 297 | t.write_pos <- t.write_pos + 6 298 | 299 | let write_uint64 t i = 300 | writable_exn t; 301 | ensure_space t 8; 302 | Bigstringaf.unsafe_set_int64_be t.buffer t.write_pos i; 303 | t.write_pos <- t.write_pos + 8 304 | 305 | let write_float t f = 306 | writable_exn t; 307 | ensure_space t 4; 308 | Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos (Int32.bits_of_float f); 309 | t.write_pos <- t.write_pos + 4 310 | 311 | let write_double t d = 312 | writable_exn t; 313 | ensure_space t 8; 314 | Bigstringaf.unsafe_set_int64_be t.buffer t.write_pos (Int64.bits_of_float d); 315 | t.write_pos <- t.write_pos + 8 316 | end 317 | 318 | module LE = struct 319 | let write_uint16 t i = 320 | writable_exn t; 321 | ensure_space t 2; 322 | Bigstringaf.unsafe_set_int16_le t.buffer t.write_pos i; 323 | t.write_pos <- t.write_pos + 2 324 | 325 | let write_uint32 t i = 326 | writable_exn t; 327 | ensure_space t 4; 328 | Bigstringaf.unsafe_set_int32_le t.buffer t.write_pos i; 329 | t.write_pos <- t.write_pos + 4 330 | 331 | let write_uint48 t i = 332 | writable_exn t; 333 | ensure_space t 6; 334 | Bigstringaf.unsafe_set_int16_le t.buffer t.write_pos 335 | Int64.(to_int i); 336 | Bigstringaf.unsafe_set_int32_le t.buffer (t.write_pos + 2) 337 | Int64.(to_int32 (shift_right_logical i 2)); 338 | t.write_pos <- t.write_pos + 6 339 | 340 | let write_uint64 t i = 341 | writable_exn t; 342 | ensure_space t 8; 343 | Bigstringaf.unsafe_set_int64_le t.buffer t.write_pos i; 344 | t.write_pos <- t.write_pos + 8 345 | 346 | let write_float t f = 347 | writable_exn t; 348 | ensure_space t 4; 349 | Bigstringaf.unsafe_set_int32_le t.buffer t.write_pos (Int32.bits_of_float f); 350 | t.write_pos <- t.write_pos + 4 351 | 352 | let write_double t d = 353 | writable_exn t; 354 | ensure_space t 8; 355 | Bigstringaf.unsafe_set_int64_le t.buffer t.write_pos (Int64.bits_of_float d); 356 | t.write_pos <- t.write_pos + 8 357 | end 358 | 359 | let close t = 360 | t.closed <- true; 361 | flush_buffer t 362 | 363 | let is_closed t = 364 | t.closed 365 | 366 | let pending_bytes t = 367 | (t.write_pos - t.scheduled_pos) + (t.bytes_received - t.bytes_written) 368 | 369 | let has_pending_output t = 370 | pending_bytes t <> 0 371 | 372 | let yield t = 373 | t.yield <- true 374 | 375 | let rec shift_buffers t written = 376 | match Buffers.dequeue_exn t.scheduled with 377 | | exception Dequeue_empty -> 378 | assert (written = 0); 379 | if t.scheduled_pos = t.write_pos then begin 380 | t.scheduled_pos <- 0; 381 | t.write_pos <- 0 382 | end 383 | | { len; _ } as iovec -> 384 | if len <= written then begin 385 | shift_buffers t (written - len) 386 | end else 387 | Buffers.enqueue_front (IOVec.shift iovec written) t.scheduled 388 | 389 | let rec shift_flushes t ~reason = 390 | match Flushes.dequeue_exn t.flushed with 391 | | exception Dequeue_empty -> () 392 | | (threshold, f) as flush -> 393 | (* Edited notes from @dinosaure: 394 | * 395 | * The quantities [t.bytes_written] and [threshold] are always going to be 396 | * positive integers. Therefore, we can treat them as unsinged integers for 397 | * the purposes of comparision. Doing so allows us to handle overflows in 398 | * either quantity as long as they're both within one overflow of each other. 399 | * We can accomplish this by subracting [min_int] from both quantities before 400 | * comparision. This shift a quantity that has not overflowed into the 401 | * negative integer range while shifting a quantity that has overflow into 402 | * the positive integer range. 403 | * 404 | * This effectively restablishes the relative difference when an overflow 405 | * has occurred, and otherwise just compares numbers that haven't 406 | * overflowed as similarly, just shifted down a bit. 407 | *) 408 | if t.bytes_written - min_int >= threshold - min_int 409 | then begin f reason; shift_flushes t ~reason end 410 | else Flushes.enqueue_front flush t.flushed 411 | 412 | let shift_internal t written ~reason = 413 | shift_buffers t written; 414 | t.bytes_written <- t.bytes_written + written; 415 | shift_flushes t ~reason 416 | ;; 417 | 418 | let shift t written = shift_internal t written ~reason:Shift 419 | 420 | let operation t = 421 | if t.closed then begin 422 | t.yield <- false 423 | end; 424 | flush_buffer t; 425 | let nothing_to_do = not (has_pending_output t) in 426 | if t.closed && nothing_to_do then 427 | `Close 428 | else if t.yield || nothing_to_do then begin 429 | t.yield <- false; 430 | `Yield 431 | end else begin 432 | let iovecs = Buffers.map_to_list t.scheduled ~f:(fun x -> x) in 433 | `Writev iovecs 434 | end 435 | 436 | let rec serialize t writev = 437 | match operation t with 438 | | `Writev iovecs -> 439 | begin match writev iovecs with 440 | | `Ok n -> shift t n; if not (Buffers.is_empty t.scheduled) then yield t 441 | | `Closed -> close t 442 | end; 443 | serialize t writev 444 | | (`Close|`Yield) as next -> next 445 | 446 | let serialize_to_string t = 447 | close t; 448 | match operation t with 449 | | `Writev iovecs -> 450 | let len = IOVec.lengthv iovecs in 451 | let bytes = Bytes.create len in 452 | let pos = ref 0 in 453 | List.iter (function 454 | | { buffer; off; len } -> 455 | Bigstringaf.unsafe_blit_to_bytes buffer ~src_off:off bytes ~dst_off:!pos ~len; 456 | pos := !pos + len) 457 | iovecs; 458 | shift t len; 459 | assert (operation t = `Close); 460 | Bytes.unsafe_to_string bytes 461 | | `Close -> "" 462 | | `Yield -> assert false 463 | 464 | let serialize_to_bigstring t = 465 | close t; 466 | match operation t with 467 | | `Writev iovecs -> 468 | let len = IOVec.lengthv iovecs in 469 | let bs = Bigstringaf.create len in 470 | let pos = ref 0 in 471 | List.iter (function 472 | | { buffer; off; len } -> 473 | Bigstringaf.unsafe_blit buffer ~src_off:off bs ~dst_off:!pos ~len; 474 | pos := !pos + len) 475 | iovecs; 476 | shift t len; 477 | assert (operation t = `Close); 478 | bs 479 | | `Close -> Bigstringaf.create 0 480 | | `Yield -> assert false 481 | 482 | let drain = 483 | let rec loop t acc = 484 | match operation t with 485 | | `Writev iovecs -> 486 | let len = IOVec.lengthv iovecs in 487 | shift_internal t len ~reason:Drain; 488 | loop t (len + acc) 489 | | `Close -> acc 490 | | `Yield -> loop t acc 491 | in 492 | fun t -> loop t 0 493 | -------------------------------------------------------------------------------- /lib/faraday.mli: -------------------------------------------------------------------------------- 1 | (*---------------------------------------------------------------------------- 2 | Copyright (c) 2016 Inhabited Type LLC. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the author nor the names of his contributors 18 | may be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 22 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 25 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | ----------------------------------------------------------------------------*) 33 | 34 | (** Serialization primitives built for speed an memory-efficiency. 35 | 36 | 37 | Faraday is a library for writing fast and memory-efficient serializers. Its 38 | core type and related operation gives the user fine-grained control over 39 | copying and allocation behavior while serializing user-defined types, and 40 | presents the output in a form that makes it possible to use vectorized 41 | write operations, such as the [writev][] system call, or any other platform 42 | or application-specific output APIs. 43 | 44 | A Faraday serializer manages an internal buffer and a queue of output 45 | buffers. The output bufferes may be a sub range of the serializer's 46 | internal buffer or one that is user-provided. Buffered writes such as 47 | {!write_string}, {!write_char}, {!write_bigstring}, etc., copy the source 48 | bytes into the serializer's internal buffer. Unbuffered writes such as 49 | {!schedule_string}, {!schedule_bigstring}, etc., on the other hand perform 50 | no copying. Instead, they enqueue the source bytes into the serializer's 51 | write queue directly. *) 52 | 53 | 54 | type bigstring = 55 | (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 56 | 57 | type t 58 | (** The type of a serializer. *) 59 | 60 | 61 | (** {2 Constructors} *) 62 | 63 | val create : int -> t 64 | (** [create len] creates a serializer with a fixed-length internal buffer of 65 | length [len]. See the Buffered writes section for details about what happens 66 | when [len] is not large enough to support a write. *) 67 | 68 | val of_bigstring : bigstring -> t 69 | (** [of_bigstring buf] creates a serializer, using [buf] as its internal 70 | buffer. The serializer takes ownership of [buf] until the serializer has 71 | been closed and flushed of all output. *) 72 | 73 | 74 | (** {2 Buffered Writes} 75 | 76 | A serializer manages an internal buffer for coalescing small writes. The 77 | size of this buffer is determined when the serializer is created. If the 78 | buffer does not contain sufficient space to service a caller's buffered 79 | write, the serializer will allocate a new buffer of the sufficient size and 80 | use it for the current and subsequent writes. The old buffer will be 81 | garbage collected once all of its contents have been {!flush}ed. *) 82 | 83 | val write_string : t -> ?off:int -> ?len:int -> string -> unit 84 | (** [write_string t ?off ?len str] copies [str] into the serializer's 85 | internal buffer. *) 86 | 87 | val write_bytes : t -> ?off:int -> ?len:int -> Bytes.t -> unit 88 | (** [write_bytes t ?off ?len bytes] copies [bytes] into the serializer's 89 | internal buffer. It is safe to modify [bytes] after this call returns. *) 90 | 91 | val write_bigstring : t -> ?off:int -> ?len:int -> bigstring -> unit 92 | (** [write_bigstring t ?off ?len bigstring] copies [bigstring] into the 93 | serializer's internal buffer. It is safe to modify [bigstring] after this 94 | call returns. *) 95 | 96 | val write_gen 97 | : t 98 | -> length:('a -> int) 99 | -> blit:('a -> src_off:int -> bigstring -> dst_off:int -> len:int -> unit) 100 | -> ?off:int 101 | -> ?len:int 102 | -> 'a -> unit 103 | (** [write_gen t ~length ~blit ?off ?len x] copies [x] into the serializer's 104 | internal buffer using the provided [length] and [blit] operations. 105 | See {!Bigstring.blit} for documentation of the arguments. *) 106 | 107 | val write_char : t -> char -> unit 108 | (** [write_char t char] copies [char] into the serializer's internal buffer. *) 109 | 110 | val write_uint8 : t -> int -> unit 111 | (** [write_uint8 t n] copies the lower 8 bits of [n] into the serializer's 112 | internal buffer. *) 113 | 114 | 115 | (** Big endian serializers *) 116 | module BE : sig 117 | val write_uint16 : t -> int -> unit 118 | (** [write_uint16 t n] copies the lower 16 bits of [n] into the serializer's 119 | internal buffer in big-endian byte order. *) 120 | 121 | val write_uint32 : t -> int32 -> unit 122 | (** [write_uint32 t n] copies [n] into the serializer's internal buffer in 123 | big-endian byte order. *) 124 | 125 | val write_uint48 : t -> int64 -> unit 126 | (** [write_uint48 t n] copies the lower 48 bits of [n] into the serializer's 127 | internal buffer in big-endian byte order. *) 128 | 129 | val write_uint64 : t -> int64 -> unit 130 | (** [write_uint64 t n] copies [n] into the serializer's internal buffer in 131 | big-endian byte order. *) 132 | 133 | val write_float : t -> float -> unit 134 | (** [write_float t n] copies the lower 32 bits of [n] into the serializer's 135 | internal buffer in big-endian byte order. *) 136 | 137 | val write_double : t -> float -> unit 138 | (** [write_double t n] copies [n] into the serializer's internal buffer in 139 | big-endian byte order. *) 140 | end 141 | 142 | 143 | (** Little endian serializers *) 144 | module LE : sig 145 | val write_uint16 : t -> int -> unit 146 | (** [write_uint16 t n] copies the lower 16 bits of [n] into the 147 | serializer's internal buffer in little-endian byte order. *) 148 | 149 | val write_uint32 : t -> int32 -> unit 150 | (** [write_uint32 t n] copies [n] into the serializer's internal buffer in 151 | little-endian byte order. *) 152 | 153 | val write_uint48 : t -> int64 -> unit 154 | (** [write_uint48 t n] copies the lower 48 bits of [n] into the serializer's 155 | internal buffer in little-endian byte order. *) 156 | 157 | val write_uint64 : t -> int64 -> unit 158 | (** [write_uint64 t n] copies [n] into the serializer's internal buffer in 159 | little-endian byte order. *) 160 | 161 | val write_float : t -> float -> unit 162 | (** [write_float t n] copies the lower 32 bits of [n] into the serializer's 163 | internal buffer in little-endian byte order. *) 164 | 165 | val write_double : t -> float -> unit 166 | (** [write_double t n] copies [n] into the serializer's internal buffer in 167 | little-endian byte order. *) 168 | end 169 | 170 | 171 | (** {2 Unbuffered Writes} 172 | 173 | Unbuffered writes do not involve copying bytes to the serializers internal 174 | buffer. *) 175 | 176 | val schedule_bigstring : t -> ?off:int -> ?len:int -> bigstring -> unit 177 | (** [schedule_bigstring t ?off ?len bigstring] schedules [bigstring] to 178 | be written the next time the serializer surfaces writes to the user. 179 | [bigstring] is not copied in this process, so [bigstring] should only be 180 | modified after [t] has been {!flush}ed. *) 181 | 182 | 183 | (** {2 Querying A Serializer's State} *) 184 | 185 | val free_bytes_in_buffer : t -> int 186 | (** [free_bytes_in_buffer t] returns the free space, in bytes, of the 187 | serializer's write buffer. If a [write_*] call has a length that exceeds 188 | this value, the serializer will allocate a new buffer that will replace the 189 | serializer's internal buffer for that and subsequent calls. *) 190 | 191 | val has_pending_output : t -> bool 192 | (** [has_pending_output t] is [true] if [t]'s output queue is non-empty. It may 193 | be the case that [t]'s queued output is being serviced by some other thread 194 | of control, but has not yet completed. *) 195 | 196 | val pending_bytes : t -> int 197 | (** [pending_bytes t] is the size of the next write, in bytes, that [t] will 198 | surface to the caller as a [`Writev]. *) 199 | 200 | 201 | (** {2 Control Operations} *) 202 | 203 | val yield : t -> unit 204 | (** [yield t] causes [t] to delay surfacing writes to the user, instead 205 | returning a [`Yield]. This gives the serializer an opportunity to collect 206 | additional writes before sending them to the underlying device, which will 207 | increase the write batch size. 208 | 209 | As one example, code may want to call this function if it's about to 210 | release the OCaml lock and perform a blocking system call, but would like 211 | to batch output across that system call. To hint to the thread of control 212 | that is performing the writes on behalf of the serializer, the code might 213 | call [yield t] before releasing the lock. *) 214 | 215 | val flush : t -> (unit -> unit) -> unit 216 | (** [flush t f] registers [f] to be called when all prior writes have been 217 | successfully completed. If [t] has no pending writes, then [f] will be 218 | called immediately. If {!yield} was recently called on [t], then the effect 219 | of the [yield] will be ignored so that client code has an opportunity to 220 | write pending output, regardless of how it handles [`Yield] operations. *) 221 | 222 | module Flushed_reason : sig 223 | (** Indicates why a flush callback was called. *) 224 | type t = 225 | | Shift 226 | (** [shift t] was called, normally indicating that bytes were written successfully. *) 227 | | Drain 228 | (** [drain t] was called, normally indicating that the downstream consumer of [t]'s 229 | bytes stopped accepting new input. *) 230 | | Nothing_pending 231 | (** Passed to [f] when [flush_with_reason t f] is called when there is not any pending 232 | output, so [t] is considered immediately flushed. *) 233 | end 234 | 235 | val flush_with_reason : t -> (Flushed_reason.t -> unit) -> unit 236 | (** [flush_with_reason t f] is like [flush t f], but [f] is suppplied with the reason that 237 | the callback was triggered. *) 238 | 239 | val close : t -> unit 240 | (** [close t] closes [t]. All subsequent write calls will raise, and any 241 | pending or subsequent {!yield} calls will be ignored. If the serializer has 242 | any pending writes, user code will have an opportunity to service them 243 | before it receives the [Close] operation. Flush callbacks will continue to 244 | be invoked while output is {!shift}ed out of [t] as needed. *) 245 | 246 | val is_closed : t -> bool 247 | (** [is_closed t] is [true] if [close] has been called on [t] and [false] 248 | otherwise. A closed [t] may still have pending output. *) 249 | 250 | val shift : t -> int -> unit 251 | (** [shift t n] removes the first [n] bytes in [t]'s write queue. Any flush 252 | callbacks registered with [t] within this span of the write queue will be 253 | called. *) 254 | 255 | val drain : t -> int 256 | (** [drain t] removes all pending writes from [t], returning the number of 257 | bytes that were enqueued to be written and freeing any scheduled 258 | buffers in the process. *) 259 | 260 | 261 | (** {2 Running} 262 | 263 | Low-level operations for runing a serializer. For production use-cases, 264 | consider the Async and Lwt support that this library includes before 265 | attempting to use this these operations directly. *) 266 | 267 | type 'a iovec = 268 | { buffer : 'a 269 | ; off : int 270 | ; len : int } 271 | (** A view into {!iovec.buffer} starting at {!iovec.off} and with length 272 | {!iovec.len}. *) 273 | 274 | type operation = [ 275 | | `Writev of bigstring iovec list 276 | | `Yield 277 | | `Close ] 278 | (** The type of operations that the serialier may wish to perform. 279 | {ul 280 | 281 | {li [`Writev iovecs]: Write the bytes in {!iovecs}s reporting the actual 282 | number of bytes written by calling {!shift}. You must accurately report the 283 | number of bytes written. Failure to do so will result in the same bytes being 284 | surfaced in a [`Writev] operation multiple times.} 285 | 286 | {li [`Yield]: Yield to other threads of control, waiting for additional 287 | output before procedding. The method for achieving this is 288 | application-specific, but once complete, the caller can proceed with 289 | serialization by simply making another call to {!val:operation} or 290 | {!serialize}.} 291 | 292 | {li [`Close]: Serialization is complete. No further output will generated. 293 | The action to take as a result, if any, is application-specific.}} *) 294 | 295 | 296 | val operation : t -> operation 297 | (** [operation t] is the next operation that the caller must perform on behalf 298 | of the serializer [t]. Users should consider using {!serialize} before this 299 | function. See the documentation for the {!type:operation} type for details 300 | on how callers should handle these operations. *) 301 | 302 | val serialize : t -> (bigstring iovec list -> [`Ok of int | `Closed]) -> [`Yield | `Close] 303 | (** [serialize t writev] sufaces the next operation of [t] to the caller, 304 | handling a [`Writev] operation with [writev] function and performing an 305 | additional bookkeeping on the caller's behalf. In the event that [writev] 306 | indicates a partial write, {!serialize} will call {!yield} on the 307 | serializer rather than attempting successive [writev] calls. *) 308 | 309 | 310 | (** {2 Convenience Functions} 311 | 312 | These functions are included for testing, debugging, and general 313 | development. They are not the suggested way of driving a serializer in a 314 | production setting. *) 315 | 316 | val serialize_to_string : t -> string 317 | (** [serialize_to_string t] runs [t], collecting the output into a string and 318 | returning it. [serialzie_to_string t] immediately closes [t] and ignores 319 | any calls to {!yield} on [t]. *) 320 | 321 | val serialize_to_bigstring : t -> bigstring 322 | (** [serialize_to_string t] runs [t], collecting the output into a bigstring 323 | and returning it. [serialzie_to_bigstring t] immediately closes [t] and 324 | ignores any calls to {!yield} on [t]. *) 325 | -------------------------------------------------------------------------------- /lib_test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (libraries alcotest faraday) 3 | (modules test_faraday) 4 | (names test_faraday)) 5 | 6 | (alias 7 | (name runtest) 8 | (package faraday) 9 | (deps test_faraday.exe) 10 | (action (run %{deps}))) 11 | -------------------------------------------------------------------------------- /lib_test/test_faraday.ml: -------------------------------------------------------------------------------- 1 | open Faraday 2 | 3 | module Operation = struct 4 | type t = 5 | [ `Writev of Bigstringaf.t iovec list 6 | | `Yield 7 | | `Close ] 8 | 9 | let pp_hum fmt t = 10 | match t with 11 | | `Yield -> Format.pp_print_string fmt "Yield" 12 | | `Close -> Format.pp_print_string fmt "Close" 13 | | `Writev iovecs -> 14 | let writev_len = List.length iovecs in 15 | Format.pp_print_string fmt "Writev ["; 16 | List.iteri (fun i { off; len; buffer } -> 17 | Format.fprintf fmt "%S" (Bigstringaf.substring ~off ~len buffer); 18 | if i < writev_len - 1 then Format.pp_print_string fmt ", ") 19 | iovecs; 20 | Format.pp_print_string fmt "]"; 21 | ;; 22 | 23 | let equal x y = 24 | match x, y with 25 | | `Yield, `Yield -> true 26 | | `Close, `Close -> true 27 | | `Writev xs, `Writev ys -> 28 | let to_string { off; len; buffer } = Bigstringaf.substring ~off ~len buffer in 29 | let xs = List.map to_string xs in 30 | let ys = List.map to_string ys in 31 | xs = ys 32 | | _, _ -> false 33 | ;; 34 | 35 | let writev ss = 36 | `Writev 37 | (List.map (fun s -> 38 | let len = String.length s in 39 | { off = 0; len; buffer = Bigstringaf.of_string ~off:0 ~len s }) 40 | ss) 41 | ;; 42 | end 43 | 44 | module Flushed_reason = struct 45 | type t = Flushed_reason.t 46 | 47 | let pp_hum fmt (t:t) = 48 | match t with 49 | | Shift -> Format.pp_print_string fmt "Shift" 50 | | Drain -> Format.pp_print_string fmt "Drain" 51 | | Nothing_pending -> Format.pp_print_string fmt "Nothing_pending" 52 | 53 | let equal (t:t) (t':t) = 54 | match t, t' with 55 | | Shift, Shift | Drain, Drain | Nothing_pending, Nothing_pending -> true 56 | | _ -> false 57 | end 58 | 59 | module Alcotest = struct 60 | include Alcotest 61 | 62 | let operation : Operation.t testable = testable Operation.pp_hum Operation.equal 63 | let flush_reason : Flushed_reason.t testable = testable Flushed_reason.pp_hum Flushed_reason.equal 64 | end 65 | 66 | let test ?(buf_size=0x100) f = 67 | let t = create buf_size in 68 | f t; 69 | operation t 70 | ;; 71 | 72 | let noop () = 73 | Alcotest.(check operation) "noop" 74 | `Yield (test ignore); 75 | ;; 76 | 77 | let yield () = 78 | Alcotest.(check operation) "yield" 79 | `Yield (test yield) 80 | ;; 81 | 82 | let empty_writes () = 83 | Alcotest.(check operation) "empty string" 84 | `Yield (test (fun t -> write_string t "")); 85 | Alcotest.(check operation) "empty bytes" 86 | `Yield (test (fun t -> write_bytes t (Bytes.make 0 '\000'))); 87 | Alcotest.(check operation) "empty bigstring" 88 | `Yield (test (fun t -> write_bigstring t (Bigstringaf.create 0))); 89 | ;; 90 | 91 | let empty_schedule () = 92 | Alcotest.(check operation) "empty schedule" 93 | `Yield (test (fun t -> schedule_bigstring t (Bigstringaf.create 0))); 94 | ;; 95 | 96 | let empty = 97 | [ "noop" , `Quick, noop 98 | ; "yield" , `Quick, yield 99 | ; "empty writes" , `Quick, empty_writes 100 | ; "empty schedule", `Quick, empty_schedule 101 | ] 102 | ;; 103 | 104 | let endianness () = 105 | Alcotest.(check operation) "unit16 le" 106 | (Operation.writev ["\005\000"]) 107 | (test (fun t -> LE.write_uint16 t 5)); 108 | Alcotest.(check operation) "unit16 be" 109 | (Operation.writev ["\000\005"]) 110 | (test (fun t -> BE.write_uint16 t 5)); 111 | ;; 112 | 113 | let endian = 114 | [ "endian", `Quick, endianness ] 115 | 116 | let write ?buf_size () = 117 | let check msg f = 118 | Alcotest.(check operation) msg 119 | (Operation.writev [ "test" ]) 120 | (test ?buf_size f) 121 | in 122 | check "string" (fun t -> write_string t "test"); 123 | check "bytes" (fun t -> write_bytes t (Bytes.of_string "test")); 124 | check "bigstring" (fun t -> write_bigstring t (Bigstringaf.of_string ~off:0 ~len:4 "test")) 125 | 126 | let char () = 127 | Alcotest.(check operation) "char" 128 | (Operation.writev [ "A" ]) 129 | (test (fun t -> write_char t 'A')); 130 | ;; 131 | 132 | let write_multiple () = 133 | let f t = 134 | write_string t "te"; 135 | write_string t "st"; 136 | write_string t "te"; 137 | write_string t "st"; 138 | write_char t 't'; 139 | write_char t 'e' 140 | in 141 | Alcotest.(check operation) "with room" 142 | (Operation.writev ["testtestte"]) 143 | (test f); 144 | Alcotest.(check operation) "with room" 145 | (Operation.writev ["te"; "st"; "te"; "st"; "te"]) 146 | (test ~buf_size:1 f); 147 | ;; 148 | 149 | let write = 150 | [ "char" , `Quick, char 151 | ; "single w/ room" , `Quick, (write : unit -> unit) 152 | ; "single w/o room", `Quick, write ~buf_size:1 153 | ; "multiple" , `Quick, write_multiple 154 | ] 155 | 156 | let schedule () = 157 | let check msg f = 158 | Alcotest.(check operation) msg 159 | (Operation.writev ["one"; "two"]) 160 | (test f) 161 | in 162 | check "schedule first" (fun t -> 163 | schedule_bigstring t (Bigstringaf.of_string ~off:0 ~len:3 "one"); 164 | write_string t "two"); 165 | check "schedule last" (fun t -> 166 | write_string t "one"; 167 | schedule_bigstring t (Bigstringaf.of_string ~off:0 ~len:3 "two")); 168 | ;; 169 | 170 | let schedule = 171 | [ "single", `Quick, schedule ] 172 | 173 | let rec cross xs ys = 174 | match xs with 175 | | [] -> [] 176 | | x::xs' -> List.(map (fun y -> [x; y]) ys) @ (cross xs' ys) 177 | 178 | let string_of_bigstring b = 179 | Bigstringaf.substring ~off:0 ~len:(Bigstringaf.length b) b 180 | 181 | let serialize_to_bigstring' t = 182 | serialize_to_bigstring t 183 | |> string_of_bigstring 184 | 185 | let check ?(buf_size=0x100) ?(serialize=serialize_to_string) ~iovecs ~msg ops result = 186 | let bigstring_of_string str = 187 | Bigstringaf.of_string ~off:0 ~len:(String.length str) str 188 | in 189 | let t = create buf_size in 190 | List.iter (function 191 | | `Write_le i -> LE.write_uint16 t i 192 | | `Write_be i -> BE.write_uint16 t i 193 | | `Write_string s -> write_string t s 194 | | `Write_bytes s -> write_bytes t (Bytes.unsafe_of_string s) 195 | | `Write_bigstring s -> write_bigstring t (bigstring_of_string s) 196 | | `Write_char c -> write_char t c 197 | | `Schedule_bigstring s -> schedule_bigstring t (bigstring_of_string s) 198 | | `Yield -> Faraday.yield t) 199 | ops; 200 | Alcotest.(check int) "iovec count" iovecs 201 | (match operation t with 202 | | `Writev iovecs -> List.length iovecs 203 | | _ -> 0); 204 | Alcotest.(check string) msg result (serialize t) 205 | 206 | let interleaved serialize = 207 | (* XXX(seliopou): Replace with property-based testing. The property should 208 | really be: Given a string, for any partition of that string and for any 209 | assignment of writes and schedules on the partition, the output will be 210 | the same as the input. *) 211 | [ "write_then_schedule", `Quick, begin fun () -> 212 | List.iteri (fun i ops -> 213 | check ~iovecs:2 ~serialize ~msg:(Printf.sprintf "write_then_schedule: %d" i) ops "test") 214 | (cross 215 | [`Write_string "te"; `Write_bytes "te"; `Write_bigstring "te"] 216 | [`Schedule_bigstring "st"]); 217 | List.iter (fun ops -> 218 | check ~iovecs:2 ~serialize ~msg:"write_then_schedule: char" ops "test") 219 | (cross 220 | [`Write_char 't'; `Write_string "t"; `Write_bytes "t"] 221 | [`Schedule_bigstring "est"]) 222 | end 223 | ; "schedule_then_write", `Quick, begin fun () -> 224 | List.iteri (fun i ops -> 225 | check ~iovecs:2 ~serialize ~msg:(Printf.sprintf "schedule_then_write: %d" i) ops "stte") 226 | (cross 227 | [`Schedule_bigstring "st"] 228 | [`Write_string "te"; `Write_bytes "te"; `Write_bigstring "te"]); 229 | List.iter (fun ops -> 230 | check ~iovecs:2 ~serialize ~msg:"schedule_then_write: char" ops "estt") 231 | (cross 232 | [`Schedule_bigstring "est"] 233 | [`Write_char 't'; `Write_bytes "t"; `Write_string "t"]) 234 | end ] 235 | 236 | let test_flush () = 237 | let t = create 0x100 in 238 | 239 | let set_up_flush () = 240 | let flush_reason = ref None in 241 | flush_with_reason t (fun reason -> flush_reason := Some reason); 242 | flush_reason 243 | in 244 | 245 | let flush_reason = set_up_flush () in 246 | Alcotest.(check (option flush_reason)) 247 | "flushes resolved immediately if no waiting bytes" 248 | (Some Nothing_pending) 249 | !flush_reason; 250 | 251 | write_string t "hello world"; 252 | let flush_reason = set_up_flush () in 253 | shift t 5; 254 | Alcotest.(check (option flush_reason)) 255 | "flush not yet resolved as not enough bytes shifted" 256 | None 257 | !flush_reason; 258 | shift t 6; 259 | Alcotest.(check (option flush_reason)) 260 | "flush during shift" 261 | (Some Shift) 262 | !flush_reason; 263 | 264 | write_string t "one"; 265 | let flush_reason1 = set_up_flush () in 266 | write_string t "two"; 267 | let flush_reason2 = set_up_flush () in 268 | shift t 6; 269 | Alcotest.(check (option flush_reason)) 270 | "flush during shift past the flush point" 271 | (Some Shift) 272 | !flush_reason1; 273 | Alcotest.(check (option flush_reason)) 274 | "flush during shift past the flush point" 275 | (Some Shift) 276 | !flush_reason2; 277 | 278 | write_string t "hello world"; 279 | close t; 280 | let flush_reason = set_up_flush () in 281 | ignore (drain t : int); 282 | Alcotest.(check (option flush_reason)) 283 | "flush during drain" 284 | (Some Drain) 285 | !flush_reason; 286 | ;; 287 | 288 | let flush = [ "flush", `Quick, test_flush ] 289 | 290 | let () = 291 | Alcotest.run "test suite" 292 | [ "empty output" , empty 293 | ; "endianness" , endian 294 | ; "write" , write 295 | ; "single schedule" , schedule 296 | ; "interleaved calls (string)" , interleaved serialize_to_string 297 | ; "interleaved calls (bigstring)" , interleaved serialize_to_bigstring' 298 | ; "flush" , flush 299 | ] 300 | -------------------------------------------------------------------------------- /lwt/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name faraday_lwt) 3 | (public_name faraday-lwt) 4 | (libraries faraday lwt) 5 | (flags (:standard -safe-string))) 6 | -------------------------------------------------------------------------------- /lwt/faraday_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | let serialize t ~yield ~writev = 4 | let shutdown () = 5 | Faraday.close t; 6 | (* It's necessary to drain the serializer in order to free any buffers that 7 | * may be be queued up. *) 8 | ignore (Faraday.drain t); 9 | in 10 | let rec loop t = 11 | match Faraday.operation t with 12 | | `Writev iovecs -> 13 | writev iovecs 14 | >>= (function 15 | | `Closed -> shutdown (); return () (* XXX(seliopou): this should be reported *) 16 | | `Ok n -> Faraday.shift t n; loop t) 17 | | `Yield -> 18 | yield t >>= fun () -> loop t 19 | | `Close -> return () 20 | in 21 | catch 22 | (fun () -> loop t) 23 | (fun exn -> 24 | shutdown (); 25 | fail exn) 26 | -------------------------------------------------------------------------------- /lwt/faraday_lwt.mli: -------------------------------------------------------------------------------- 1 | open Faraday 2 | 3 | 4 | val serialize 5 | : t 6 | -> yield : (t -> unit Lwt.t) 7 | -> writev : (bigstring iovec list -> [ `Ok of int | `Closed ] Lwt.t) 8 | -> unit Lwt.t 9 | -------------------------------------------------------------------------------- /lwt_unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name faraday_lwt_unix) 3 | (public_name faraday-lwt-unix) 4 | (libraries faraday lwt lwt.unix faraday-lwt) 5 | (flags (:standard -safe-string))) 6 | -------------------------------------------------------------------------------- /lwt_unix/faraday_lwt_unix.ml: -------------------------------------------------------------------------------- 1 | include Faraday_lwt 2 | 3 | open Lwt.Infix 4 | 5 | let writev_of_fd fd = 6 | fun iovecs -> 7 | let lwt_iovecs = Lwt_unix.IO_vectors.create () in 8 | iovecs |> List.iter (fun {Faraday.buffer; off; len} -> 9 | Lwt_unix.IO_vectors.append_bigarray lwt_iovecs buffer off len); 10 | 11 | Lwt.catch 12 | (fun () -> 13 | Lwt_unix.writev fd lwt_iovecs 14 | >|= fun n -> `Ok n) 15 | (function 16 | | Unix.Unix_error (Unix.EBADF, "check_descriptor", _) 17 | | Unix.Unix_error (Unix.EPIPE, _, _) -> 18 | Lwt.return `Closed 19 | | exn -> 20 | Lwt.fail exn) 21 | -------------------------------------------------------------------------------- /lwt_unix/faraday_lwt_unix.mli: -------------------------------------------------------------------------------- 1 | open Faraday 2 | 3 | 4 | include module type of Faraday_lwt 5 | 6 | val writev_of_fd 7 | : Lwt_unix.file_descr 8 | -> bigstring iovec list -> [ `Ok of int | `Closed ] Lwt.t 9 | --------------------------------------------------------------------------------