├── .gitignore ├── .merlin ├── .ocamlinit ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── README.md ├── _tags ├── build ├── doc ├── api.odocl ├── dev.odocl └── style.css ├── lwt ├── .merlin ├── sendmsg_lwt.ml ├── sendmsg_lwt.mli └── sendmsg_lwt.mllib ├── myocamlbuild.ml ├── opam ├── pkg ├── META └── pkg.ml ├── src ├── libsendmsg_stubs.clib ├── native │ ├── sendmsg.c │ ├── sendmsg.h │ └── sendmsg_stubs.c ├── sendmsg.ml ├── sendmsg.mli └── sendmsg.mllib └── test ├── .merlin ├── test.ml └── test_lwt.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.install 7 | *.native 8 | *.byte 9 | 10 | rondom 11 | _tests 12 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | B _build/** 2 | FLG -w A-4-33-40-41-42-43-34-44-48 3 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | #require "unix" 2 | #directory "_build/src" 3 | #load "sendmsg.cma" 4 | #require "lwt.unix" 5 | #directory "_build/lwt" 6 | #load "sendmsg_lwt.cma" 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 3 | script: bash -ex .travis-opam.sh 4 | sudo: required 5 | env: 6 | global: 7 | - PACKAGE="sendmsg" 8 | matrix: 9 | - OCAML_VERSION=4.02 10 | - OCAML_VERSION=4.03 11 | - OCAML_VERSION=4.03 DEPOPTS=lwt 12 | - OCAML_VERSION=4.04 13 | notifications: 14 | email: false 15 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.0.2 2016-11-05 2 | 3 | * Fast-forward the C compiler by a couple of decades. 4 | 5 | ## v0.0.1 2016-11-04 6 | 7 | First release. 8 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 David Kaloper Meršinjak 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## sendmsg — π-calculus? In _my_ kernel? 2 | 3 | Higher-order sockets, oh my! 4 | 5 | %%VERSION%% 6 | 7 | sendmsg is a straightforward OCaml binding to POSIX `sendmsg(3)` and `recvmsg(3)` 8 | API. Provides scatter-gather IO and passing file descriptors as ancillary data. 9 | 10 | sendmsg is distributed under the ISC license. 11 | 12 | ## Documentation 13 | 14 | Interfaces are documented. [Online][doc] too. 15 | 16 | [doc]: https://pqwy.github.io/sendmsg/doc 17 | 18 | [![Build Status](https://travis-ci.org/pqwy/sendmsg.svg?branch=master)](https://travis-ci.org/pqwy/sendmsg) 19 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: color(always), bin_annot 2 | true: warn(A-4-29-33-40-41-42-43-34-44-48) 3 | true: package(bytes) 4 | not : safe_string 5 | 6 | : include 7 | : package(unix) 8 | : link_stubs(src/libsendmsg_stubs) 9 | : ccopt(-std=c99 -O3 -Wall -Wextra) 10 | 11 | : include 12 | : package(lwt.unix) 13 | 14 | : include 15 | : package(alcotest), use_sendmsg 16 | : package(lwt.unix) 17 | 18 | : -traverse 19 | -------------------------------------------------------------------------------- /build: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | function has { opam config var "${1}:installed"; } 4 | 5 | topkg build -- --with-lwt $(has 'lwt') 6 | -------------------------------------------------------------------------------- /doc/api.odocl: -------------------------------------------------------------------------------- 1 | Sendmsg 2 | Sendmsg_lwt 3 | -------------------------------------------------------------------------------- /doc/dev.odocl: -------------------------------------------------------------------------------- 1 | Sendmsg 2 | Sendmsg_lwt 3 | -------------------------------------------------------------------------------- /doc/style.css: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 2 | Distributed under the ISC license, see terms at the end of the file. */ 3 | 4 | /* Reset a few things. */ 5 | html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, 6 | a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, 7 | small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, 8 | form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td 9 | { margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; 10 | font-weight: inherit; font-style:inherit; font-family:inherit; 11 | line-height: inherit; vertical-align: baseline; text-align:inherit; 12 | color:inherit; background: transparent; } 13 | 14 | table { border-collapse: collapse; border-spacing: 0; } 15 | 16 | /* Basic page layout */ 17 | 18 | body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left; 19 | margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; 20 | color: black; background: transparent /* url(line-height-22.gif) */; } 21 | 22 | b { font-weight: bold } 23 | em { font-style: italic } 24 | 25 | tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; 26 | font-size: 1em; } 27 | pre code { font-size : inherit; } 28 | .codepre { margin-bottom:1.375em /* after code example we introduce space. */ } 29 | 30 | .superscript,.subscript 31 | { font-size : 0.813em; line-height:0; margin-left:0.4ex;} 32 | .superscript { vertical-align: super; } 33 | .subscript { vertical-align: sub; } 34 | 35 | /* ocamldoc markup workaround hacks */ 36 | 37 | hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br 38 | { display: none } /* annoying */ 39 | 40 | div.info + br { display:block} 41 | 42 | .codepre br + br { display: none } 43 | h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ 44 | 45 | /* Sections and document divisions */ 46 | 47 | /* .navbar { margin-bottom: -1.375em } */ 48 | h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ 49 | margin-top:0.917em; padding-top:0.875em; 50 | border-top-style:solid; border-width:1px; border-color:#AAA; } 51 | h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } 52 | h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 53 | h3 { font-weight: bold; font-size: 1em; margin-top: 1.375em} 54 | h4 { font-style: italic; } 55 | 56 | /* Used by OCaml's own library documentation. */ 57 | h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 58 | .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em } 59 | 60 | p { margin-top: 1.375em } 61 | pre { margin-top: 1.375em } 62 | .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ 63 | td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ 64 | 65 | ul, ol { margin-top:0.688em; padding-bottom:0.687em; 66 | list-style-position:outside} 67 | ul + p, ol + p { margin-top: 0em } 68 | ul { list-style-type: square } 69 | 70 | 71 | /* h2 + ul, h3 + ul, p + ul { } */ 72 | ul > li { margin-left: 1.375em; } 73 | ol > li { margin-left: 1.7em; } 74 | /* Links */ 75 | 76 | a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } 77 | a:hover { text-decoration : underline } 78 | *:target {background-color: #FFFF99;} /* anchor highlight */ 79 | 80 | /* Code */ 81 | 82 | .keyword { font-weight: bold; } 83 | .comment { color : red } 84 | .constructor { color : green } 85 | .string { color : brown } 86 | .warning { color : red ; font-weight : bold } 87 | 88 | /* Functors */ 89 | 90 | .paramstable { border-style : hidden ; padding-bottom:1.375em} 91 | .paramstable code { margin-left: 1ex; margin-right: 1ex } 92 | .sig_block {margin-left: 1em} 93 | 94 | /* Images */ 95 | 96 | img { margin-top: 1.375em } 97 | 98 | /*--------------------------------------------------------------------------- 99 | Copyright (c) 2016 Daniel C. Bünzli 100 | 101 | Permission to use, copy, modify, and/or distribute this software for any 102 | purpose with or without fee is hereby granted, provided that the above 103 | copyright notice and this permission notice appear in all copies. 104 | 105 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 106 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 107 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 108 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 109 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 110 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 111 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 112 | ---------------------------------------------------------------------------*/ 113 | -------------------------------------------------------------------------------- /lwt/.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt 2 | REC 3 | -------------------------------------------------------------------------------- /lwt/sendmsg_lwt.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Lwt 5 | open Lwt_unix 6 | 7 | let result = function 8 | | (n, Some fd) -> (n, Some (of_unix_file_descr fd)) 9 | | (n, None) -> (n, None) 10 | 11 | let usock = unix_file_descr 12 | 13 | let usocko = function Some fd -> Some (unix_file_descr fd) | _ -> None 14 | 15 | let send s ?fd buf i n = 16 | wrap_syscall Write s @@ fun () -> 17 | Sendmsg.send (usock s) ?fd:(usocko fd) buf i n 18 | 19 | let recv s buf i n = 20 | wrap_syscall Read s @@ fun () -> 21 | Sendmsg.recv (usock s) buf i n |> result 22 | 23 | let sendv s ?fd bufs = 24 | wrap_syscall Write s @@ fun () -> 25 | Sendmsg.sendv (usock s) ?fd:(usocko fd) bufs 26 | 27 | let recvv s bufs = 28 | wrap_syscall Read s @@ fun () -> 29 | Sendmsg.recvv (usock s) bufs |> result 30 | -------------------------------------------------------------------------------- /lwt/sendmsg_lwt.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** sendmsg(3) / recvmsg(3) with socket-passing for {!Lwt} 5 | 6 | This module mirrors {!Sendmsg}. Consult that interface for details. 7 | 8 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *) 9 | 10 | (** {1 Sendmsg_lwt} *) 11 | 12 | 13 | open Lwt_unix 14 | 15 | val send : file_descr -> ?fd:file_descr -> bytes -> int -> int -> int Lwt.t 16 | 17 | val recv : file_descr -> bytes -> int -> int -> (int * file_descr option) Lwt.t 18 | 19 | val sendv : file_descr -> ?fd:file_descr -> bytes array -> int Lwt.t 20 | 21 | val recvv : file_descr -> bytes array -> (int * file_descr option) Lwt.t 22 | -------------------------------------------------------------------------------- /lwt/sendmsg_lwt.mllib: -------------------------------------------------------------------------------- 1 | Sendmsg_lwt 2 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | let () = Ocamlbuild_plugin.dispatch Ocb_stubblr.init 2 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "David Kaloper Meršinjak " 3 | authors: ["David Kaloper Meršinjak "] 4 | homepage: "https://github.com/pqwy/sendmsg" 5 | doc: "https://pqwy.github.io/sendmsg/doc" 6 | license: "ISC" 7 | dev-repo: "https://github.com/pqwy/sendmsg.git" 8 | bug-reports: "https://github.com/pqwy/sendmsg/issues" 9 | tags: [] 10 | available: [ ocaml-version >= "4.02.0"] 11 | build: [ 12 | "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" 13 | "--with-lwt" "%{lwt:installed}%" 14 | ] 15 | depends: [ 16 | "ocamlfind" {build} 17 | "ocamlbuild" {build} 18 | "topkg" {build} 19 | "ocb-stubblr" {build} 20 | "alcotest" {test} ] 21 | depopts: [ "lwt" ] 22 | conflicts: [ "ocb-stubblr" {<"0.1.0"} ] 23 | 24 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "sendmsg(3) / recvmsg(3) with socket-passing" 2 | version = "%%VERSION%%" 3 | requires = "unix" 4 | archive(byte) = "sendmsg.cma" 5 | archive(native) = "sendmsg.cmxa" 6 | plugin(byte) = "sendmsg.cma" 7 | plugin(native) = "sendmsg.cmxs" 8 | 9 | package "lwt" ( 10 | version = "%%VERSION%%" 11 | description = "sendmsg(3) / recvmsg(3) with socket-passing" 12 | requires = "sendmsg lwt.unix" 13 | archive(byte) = "sendmsg_lwt.cma" 14 | archive(native) = "sendmsg_lwt.cmxa" 15 | plugin(byte) = "sendmsg_lwt.cma" 16 | plugin(native) = "sendmsg_lwt.cmxs" 17 | exists_if = "sendmsg_lwt.cma" 18 | ) 19 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | #require "ocb-stubblr.topkg" 5 | open Topkg 6 | open Ocb_stubblr_topkg 7 | 8 | let opams = [Pkg.opam_file ~lint_deps_excluding:(Some ["ocb-stubblr"]) "opam"] 9 | 10 | let lwt = Conf.with_pkg ~default:true "lwt" 11 | 12 | let () = Pkg.(describe "sendmsg" ~build:(build ~cmd ()) ~opams) @@ fun c -> 13 | let lwt = Conf.value c lwt in 14 | Ok [ Pkg.mllib "src/sendmsg.mllib"; 15 | Pkg.clib "src/libsendmsg_stubs.clib"; 16 | Pkg.mllib ~cond:lwt "lwt/sendmsg_lwt.mllib"; 17 | Pkg.test "test/test"; 18 | Pkg.test ~cond:lwt "test/test_lwt"; ] 19 | -------------------------------------------------------------------------------- /src/libsendmsg_stubs.clib: -------------------------------------------------------------------------------- 1 | native/sendmsg.o 2 | native/sendmsg_stubs.o 3 | -------------------------------------------------------------------------------- /src/native/sendmsg.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. */ 3 | 4 | #include 5 | 6 | #define ctrl_size (sizeof (struct cmsghdr) + sizeof (int)) 7 | 8 | ssize_t sendmsg_with_sock (int fd, int s, void **data, size_t *lenv, size_t n) { 9 | 10 | struct iovec iov[n]; 11 | char ctrl[ctrl_size]; 12 | struct msghdr msg = { 13 | .msg_iov = iov, 14 | .msg_iovlen = n, 15 | .msg_control = ctrl, 16 | .msg_controllen = 0, 17 | }; 18 | 19 | for (size_t i = 0; i < n; i++) { 20 | iov[i].iov_base = data[i]; 21 | iov[i].iov_len = lenv[i]; 22 | } 23 | 24 | if (s >= 0) { 25 | msg.msg_controllen = ctrl_size; 26 | 27 | struct cmsghdr *cmsg = (struct cmsghdr *) ctrl; 28 | cmsg->cmsg_len = ctrl_size; 29 | cmsg->cmsg_level = SOL_SOCKET; 30 | cmsg->cmsg_type = SCM_RIGHTS; 31 | int *cdata = (int *)CMSG_DATA(cmsg); 32 | *cdata = s; 33 | } 34 | 35 | return (sendmsg (fd, &msg, 0)); 36 | } 37 | 38 | ssize_t recvmsg_with_sock (int fd, int *s, void **data, size_t *lenv, size_t n) { 39 | 40 | struct iovec iov[n]; 41 | char ctrl[ctrl_size]; 42 | struct msghdr msg = { 43 | .msg_iov = iov, 44 | .msg_iovlen = n, 45 | .msg_control = ctrl, 46 | .msg_controllen = ctrl_size, 47 | }; 48 | 49 | struct cmsghdr *cmsg = (struct cmsghdr *) ctrl; 50 | cmsg->cmsg_len = ctrl_size; 51 | cmsg->cmsg_level = SOL_SOCKET; 52 | cmsg->cmsg_type = SCM_RIGHTS; 53 | 54 | for (size_t i = 0; i < n; i++) { 55 | iov[i].iov_base = data[i]; 56 | iov[i].iov_len = lenv[i]; 57 | } 58 | 59 | *s = -1; 60 | int res = recvmsg (fd, &msg, 0); 61 | if (res >= 0 && msg.msg_controllen == ctrl_size) { 62 | int *cdata = (int *)CMSG_DATA(cmsg); 63 | *s = *cdata; 64 | } 65 | 66 | return res; 67 | } 68 | -------------------------------------------------------------------------------- /src/native/sendmsg.h: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. */ 3 | 4 | #include 5 | 6 | /* Send a message, adding a socket to ancillary data, unless the socket is -1. 7 | * See sendmsg(3) for other parameters and the return. */ 8 | ssize_t sendmsg_with_sock (int fd, int s, void **data, size_t *lenv, size_t n); 9 | 10 | /* Send a message, adding a socket to ancillary data, unless the socket is -1. 11 | * See recvmsg(3) for other parameters and the return. */ 12 | ssize_t recvmsg_with_sock (int fd, int *s, void **data, size_t *lenv, size_t n); 13 | -------------------------------------------------------------------------------- /src/native/sendmsg_stubs.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. */ 3 | 4 | #include "sendmsg.h" 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #define __fid(name) static char fid[] = name; 13 | 14 | static inline int err (char *name, int res) { 15 | if (res == -1) { uerror (name, Nothing); } 16 | return res; 17 | } 18 | 19 | static inline value pair (value p1, value p2) { 20 | CAMLparam2 (p1, p2); 21 | CAMLlocal1 (res); 22 | res = caml_alloc_tuple (2); 23 | Field (res, 0) = p1; 24 | Field (res, 1) = p2; 25 | CAMLreturn (res); 26 | } 27 | 28 | static inline void from_buff_off_n (char *name, void **data, size_t *lenv, value buf, value voff, value vn) { 29 | int off = Int_val (voff), n = Int_val (vn); 30 | if (off < 0 || n < 0 || caml_string_length (buf) < (size_t) (off + n)) { 31 | caml_invalid_argument (name); 32 | } 33 | *data = String_val (buf) + off; 34 | *lenv = n; 35 | } 36 | 37 | static inline int Osock_val (value ofd) { 38 | return Is_block (ofd) ? Int_val (Field (ofd, 0)) : -1; 39 | } 40 | 41 | static inline value Val_osock (int fd) { 42 | CAMLparam0 (); 43 | CAMLlocal1 (ret); 44 | if (fd != -1) 45 | Field (ret = caml_alloc_tuple (1), 0) = Val_int (fd); 46 | CAMLreturn (ret); 47 | } 48 | 49 | CAMLprim value caml_sendmsg_send (value fd, value sock, value buf, value off, value n) { 50 | CAMLparam5 (fd, sock, buf, off, n); 51 | void *data; 52 | size_t lenv; 53 | __fid ("Sendmsg.send"); 54 | from_buff_off_n (fid, &data, &lenv, buf, off, n); 55 | int res = err (fid, sendmsg_with_sock ( 56 | Int_val (fd), Osock_val (sock), &data, &lenv, 1)); 57 | CAMLreturn (Val_int (res)); 58 | } 59 | 60 | CAMLprim value caml_sendmsg_recv (value fd, value buf, value off, value n) { 61 | CAMLparam4 (fd, buf, off, n); 62 | CAMLlocal1 (ret); 63 | void *data; 64 | size_t lenv; 65 | __fid ("Sendmsg.recv"); 66 | from_buff_off_n (fid, &data, &lenv, buf, off, n); 67 | int s, res = err (fid, recvmsg_with_sock ( 68 | Int_val (fd), &s, &data, &lenv, 1)); 69 | ret = pair (Val_int (res), Val_osock (s)); 70 | CAMLreturn (ret); 71 | } 72 | 73 | CAMLprim value caml_sendmsg_sendv (value fd, value sock, value bufv) { 74 | CAMLparam3 (fd, sock, bufv); 75 | size_t n = (size_t) caml_array_length (bufv); 76 | size_t lenv[n]; 77 | void *data[n]; 78 | __fid ("Sendmsg.sendv"); 79 | for (size_t i = 0; i < n; i++) { 80 | lenv[i] = caml_string_length (*((value *)bufv + i)); 81 | data[i] = String_val (*((value *)bufv + i)); 82 | } 83 | int res = err (fid, sendmsg_with_sock ( 84 | Int_val (fd), Osock_val (sock), data, lenv, n)); 85 | CAMLreturn (Val_int (res)); 86 | } 87 | 88 | CAMLprim value caml_sendmsg_recvv (value fd, value bufv) { 89 | CAMLparam2 (fd, bufv); 90 | CAMLlocal1 (ret); 91 | size_t n = (size_t) caml_array_length (bufv); 92 | size_t lenv[n]; 93 | void *data[n]; 94 | __fid ("Sendmsg.recvv"); 95 | for (size_t i = 0; i < n; i++) { 96 | lenv[i] = caml_string_length (*((value *)bufv + i)); 97 | data[i] = String_val (*((value *)bufv + i)); 98 | } 99 | int s, res = err (fid, recvmsg_with_sock (Int_val (fd), &s, data, lenv, n)); 100 | ret = pair (Val_int (res), Val_osock (s)); 101 | CAMLreturn (ret); 102 | } 103 | -------------------------------------------------------------------------------- /src/sendmsg.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | external send : Unix.file_descr -> ?fd:Unix.file_descr -> bytes -> int -> int -> int = "caml_sendmsg_send" 5 | external recv : Unix.file_descr -> bytes -> int -> int -> int * Unix.file_descr option = "caml_sendmsg_recv" 6 | external sendv : Unix.file_descr -> ?fd:Unix.file_descr -> bytes array -> int = "caml_sendmsg_sendv" 7 | external recvv : Unix.file_descr -> bytes array -> int * Unix.file_descr option = "caml_sendmsg_recvv" 8 | -------------------------------------------------------------------------------- /src/sendmsg.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** sendmsg(3) / recvmsg(3) with socket-passing 5 | 6 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *) 7 | 8 | (** {1 Sendmsg} 9 | 10 | For detailed semantics of these functions, consult the 11 | {{: https://linux.die.net/man/3/sendmsg}{b sendmsg(3)}} and 12 | {{: https://linux.die.net/man/3/recvmsg}{b recvmsg(3)}} 13 | man pages. 14 | 15 | In particular, the presence of ancillary data implies preservation of 16 | message boundaries: ancillary message will never be read together with bytes 17 | of an underlying message it was {e not} sent with. *) 18 | 19 | val send : Unix.file_descr -> ?fd:Unix.file_descr -> bytes -> int -> int -> int 20 | (** [send sock ?fd buf off n] sends up to [n] bytes of [buf], starting from 21 | [off], over [sock]. [fd] is attached as ancillary data. Returns the number 22 | of bytes sent. 23 | 24 | @raise Unix_error on {b ERRNO}. *) 25 | 26 | val recv : Unix.file_descr -> bytes -> int -> int -> int * Unix.file_descr option 27 | (** [recv sock ?fd off n] reads up to [n] bytes into [buf], starting from 28 | [off], from [sock]. Returns [(n, fd)], where [n] is the number of bytes 29 | read, and [fd] is the optional file descriptor attached to the message. 30 | 31 | @raise Unix_error on {b ERRNO}. *) 32 | 33 | val sendv : Unix.file_descr -> ?fd:Unix.file_descr -> bytes array -> int 34 | (** [sendv sock ?fd bytesv] is the scatter-gather version of {{!send}[send]}. 35 | It sends the contents of all bytes in [bytesv], in order. Returns the 36 | number of bytes sent. 37 | 38 | @raise Unix_error on {b ERRNO}. *) 39 | 40 | val recvv : Unix.file_descr -> bytes array -> int * Unix.file_descr option 41 | (** [recvv sock bytesv] is the scatter-gather version of {{!recv}[recv]}. 42 | Input is gathered into the arrays in [bytesv], in order. Returns the 43 | total number of bytes read, and an optional file descriptor. 44 | 45 | @raise Unix_error on {b ERRNO}. *) 46 | -------------------------------------------------------------------------------- /src/sendmsg.mllib: -------------------------------------------------------------------------------- 1 | Sendmsg 2 | -------------------------------------------------------------------------------- /test/.merlin: -------------------------------------------------------------------------------- 1 | PKG oUnit alcotest 2 | REC 3 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (* open OUnit2 *) 2 | open Unix 3 | open Alcotest 4 | 5 | 6 | let fd : file_descr testable = 7 | testable (fun ppf fd -> Fmt.pf ppf "fd:%d" (Obj.magic fd)) (=) 8 | 9 | let ret = pair int (option fd) 10 | 11 | let bracket ~init ~fini f = 12 | let x = init () in 13 | match f x with 14 | | res -> fini x; res 15 | | exception exn -> fini x; raise exn 16 | 17 | let with_socketpair f = bracket f 18 | ~init:(fun () -> socketpair PF_UNIX SOCK_STREAM 0) 19 | ~fini:(fun (s1, s2) -> close s1; close s2) 20 | 21 | let send ?fd s buf = Sendmsg.send ?fd s buf 0 (Bytes.length buf) 22 | 23 | let recv s = 24 | let buf = Bytes.create 64 in 25 | let (n, so) = Sendmsg.recv s buf 0 64 in 26 | (Bytes.sub buf 0 n, so) 27 | 28 | let t_send () = with_socketpair @@ fun (s1, s2) -> 29 | let b1 = "abcdef" and b2 = "......" in 30 | check int "send1" 4 (Sendmsg.send s1 b1 0 4); 31 | check ret "recv1" (4, None) (Sendmsg.recv s2 b2 0 4); 32 | check int "send2" 2 (Sendmsg.send s1 b1 4 2); 33 | check ret "recv2" (2, None) (Sendmsg.recv s2 b2 4 2); 34 | check string "final" b1 b2 35 | 36 | let t_sendv () = with_socketpair @@ fun (s1, s2) -> 37 | let b1 = [| "."; "." |] 38 | and b2 = [| "..."; "..." |] in 39 | Sendmsg.sendv s1 [| "ab"; "cd" |] |> check int "sendv1" 4; 40 | Sendmsg.sendv s1 [| "e"; "f" |] |> check int "sendv2" 2; 41 | Sendmsg.recvv s2 b1 |> check ret "recvv1" (2, None); 42 | Sendmsg.recvv s2 b2 |> check ret "recvv2" (4, None); 43 | check (array string) "b1" b1 [| "a"; "b" |]; 44 | check (array string) "b2" b2 [| "cde"; "f.." |] 45 | 46 | let pass_sock () = 47 | with_socketpair @@ fun (s1, s2) -> 48 | with_socketpair @@ fun (x1, x2) -> 49 | let b0 = "x.." in 50 | Sendmsg.send s1 ~fd:x1 b0 0 1 |> ignore; 51 | match Sendmsg.recv s2 b0 1 1 with 52 | | (n, Some fd) -> 53 | check int "recv 1" n 1; 54 | write fd b0 0 1 |> ignore; 55 | read x2 b0 2 1 |> ignore; 56 | close fd; 57 | check string "endgame" b0 ("xxx") 58 | | _ -> fail "socket not passed" 59 | 60 | let msg_boundaries () = with_socketpair @@ fun (s1, s2) -> 61 | let msgs = ["x"; "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy"; "z"] in 62 | msgs |> List.map (send s1 ~fd:stdout) |> ignore; 63 | msgs |> List.iter @@ fun msg -> 64 | match recv s2 with 65 | | (msg', Some s) -> close s; check string "recv" msg msg' 66 | | _ -> fail "no socket" 67 | 68 | let stress () = with_socketpair @@ fun (s1, s2) -> 69 | for _ = 1 to 100000 do 70 | Sendmsg.send s1 ~fd:stdout ("x") 0 1 |> ignore; 71 | match Sendmsg.recv s2 "." 0 1 with 72 | | (1, Some fd) -> close fd 73 | | _ -> Alcotest.fail "nope." 74 | done 75 | 76 | let () = run "sendmsg" [ 77 | "sendmsg", [ 78 | "send", `Quick, t_send; 79 | "sendv", `Quick, t_sendv; 80 | "passing sockets", `Quick, pass_sock; 81 | "message boundaries", `Quick, msg_boundaries; 82 | "stress", `Quick, stress; 83 | ] 84 | ] 85 | -------------------------------------------------------------------------------- /test/test_lwt.ml: -------------------------------------------------------------------------------- 1 | open Alcotest 2 | open Lwt.Infix 3 | 4 | let uncurry f (a, b) = f a b 5 | 6 | let closepair f1 f2 = Lwt_unix.(close f1 >>= fun _ -> close f2) 7 | 8 | let bracket ~init ~fini f = 9 | init () >>= fun x -> 10 | Lwt.catch (fun () -> f x >>= fun res -> fini x >|= fun _ -> res) 11 | (fun exn -> fini x >>= fun _ -> Lwt.fail exn) 12 | 13 | let with_socketpair f = 14 | let init () = Lwt_unix.(socketpair PF_UNIX SOCK_STREAM 0) |> Lwt.return in 15 | bracket ~init ~fini:(uncurry closepair) (uncurry f) 16 | 17 | let lim = 1024 18 | 19 | let wr fd buf = 20 | Lwt_unix.write fd (Bytes.unsafe_of_string buf) 0 (String.length buf) 21 | let rd fd = 22 | let buf = Bytes.create lim in 23 | Lwt_unix.read fd buf 0 lim >|= fun n -> 24 | Bytes.(sub buf 0 n |> unsafe_to_string) 25 | 26 | let sendmsg f ?fd buf = 27 | Sendmsg_lwt.send f ?fd (Bytes.unsafe_of_string buf) 0 (String.length buf) 28 | let recvmsg f = 29 | let buf = Bytes.create 1024 in 30 | Sendmsg_lwt.recv f buf 0 lim >|= fun (n, x) -> 31 | (Bytes.(sub buf 0 n |> unsafe_to_string), x) 32 | 33 | let pass n s1 s2 = 34 | let msg = "message-" ^ string_of_int n in 35 | let a1 = 36 | let (p2, p1) = Lwt_unix.pipe () in 37 | wr p1 "tag" >>= fun _ -> 38 | sendmsg s1 ~fd:p2 msg >>= fun _ -> 39 | closepair p1 p2 40 | and a2 = recvmsg s2 >>= function 41 | | (msg', Some p) -> 42 | check string "socket msg" msg msg'; 43 | rd p >>= fun msg -> 44 | check string "pipe msg" "tag" msg; Lwt_unix.close p 45 | | _ -> fail "didn't recv pipe" in 46 | a1 <&> a2 47 | 48 | let rec l1 s1 s2 = function 49 | | 0 -> Lwt.return_unit 50 | | n -> pass n s1 s2 >>= fun _ -> l1 s1 s2 (pred n) 51 | 52 | let rec l2 k = function 53 | | 0 -> Lwt.return_unit 54 | | n -> with_socketpair (fun s1 s2 -> l1 s1 s2 k) >>= fun _ -> l2 k (pred n) 55 | 56 | let pingpong () = Lwt_main.run (l2 100 100) 57 | 58 | let () = Alcotest.run "sendmsg lwt" [ 59 | "stress", [ "pingpong", `Slow, pingpong ] 60 | ] 61 | --------------------------------------------------------------------------------