├── .gitignore ├── .merlin ├── CHANGES ├── LICENSE ├── README.md ├── _oasis ├── lib ├── nanomsg.ml ├── nanomsg.mli ├── nanomsg_async.ml ├── nanomsg_async.mli ├── nanomsg_lwt.ml ├── nanomsg_lwt.mli └── nanomsg_utils.ml ├── lib_gen ├── nanomsg_bindgen.ml └── nanomsg_bindings.ml ├── lib_test ├── base_suite.ml └── lwt_suite.ml ├── myocamlbuild.ml ├── opam └── pkg ├── META ├── build.ml └── topkg.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.byte 2 | *.native 3 | _build/** 4 | *.log 5 | *.data 6 | *.vim 7 | *.old 8 | *.native 9 | _obuild/** 10 | ocp-build.root 11 | *.install 12 | configure 13 | api.odocl 14 | lib/META 15 | **/*.clib 16 | **/*.mllib 17 | **/*.mldylib 18 | setup.ml 19 | Makefile 20 | _tags -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG ctypes 2 | PKG ctypes.stubs 3 | PKG ipaddr 4 | PKG lwt.unix 5 | PKG lwt.ppx 6 | PKG oUnit 7 | PKG result 8 | PKG bigstring 9 | PKG ppx_deriving.std 10 | PKG async 11 | 12 | S lib 13 | S lib_gen 14 | S lib_test 15 | S examples 16 | 17 | B _build/lib 18 | B _build/lib_gen 19 | B _build/lib_test 20 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | 1.0 (2015-01-12): 2 | 3 | * Rewritten most of the bindings. 4 | * Polling support via Lwt. 5 | * Build system is now topkg. 6 | * Better handling of addresses through a polymorphic variant. 7 | * Added an oUnit test suite. 8 | 9 | 0.1 (2013-11-12): 10 | 11 | * First released version. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE 2 | Version 2, December 2004 3 | 4 | Copyright (C) 2013 Rudi Grinberg 5 | Copyright (C) 2014 Vincent Bernardoff 6 | 7 | Everyone is permitted to copy and distribute verbatim or modified 8 | copies of this license document, and changing it is allowed as long 9 | as the name is changed. 10 | 11 | DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE 12 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 13 | 14 | 0. You just DO WHAT THE FUCK YOU WANT TO. 15 | 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ONanomsg 2 | 3 | `ctypes`-based bindings to [nanomsg](https://github.com/250bpm/nanomsg) for OCaml 4 | 5 | ## Installation 6 | 7 | The dependencies are: 8 | * cstruct 9 | * ctypes > 0.2 10 | * ppx_deriving 11 | * ipaddr 12 | * [nanomsg](https://github.com/250bpm/nanomsg) 13 | * (optional) lwt > 2.4.6 14 | 15 | 16 | ``` 17 | opam pin add . 18 | ``` 19 | 20 | ## Examples 21 | 22 | See `lib_test/suite.ml` 23 | 24 | ## Overview 25 | 26 | For now these bindings are as close possible to the C interface but that is 27 | likely to change in the future. 28 | 29 | ## TODO 30 | 31 | - Add support for devices 32 | 33 | ## License 34 | 35 | ONanomsg is licensed under the [WTFPL](http://www.wtfpl.net/). See LICENSE. 36 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat : 0.4 2 | Name : nanomsg 3 | Version : 1.1 4 | Synopsis : nanomsg bindings for OCaml 5 | Authors : Vincent Bernardoff, Rudi Grinberg 6 | License : WTFPL 7 | Plugins : DevFiles (0.4), META (0.4) 8 | BuildTools : ocamlbuild 9 | Maintainers : Vincent Bernardoff 10 | Homepage : https://github.com/rgrinberg/onanomsg 11 | 12 | Flag lwt 13 | Description: build the Lwt library 14 | Default: false 15 | 16 | Flag async 17 | Description: build the Async library 18 | Default: false 19 | 20 | Library "nanomsg" 21 | Path: lib 22 | Modules: Nanomsg 23 | InternalModules: Nanomsg_utils, Nanomsg_bindings, Nanomsg_generated 24 | CSources: nanomsg_stubs.c 25 | CCLib: -lnanomsg 26 | CCOpt: -I $pkg_ctypes_stubs 27 | BuildDepends: bytes, ctypes.stubs, result, bigstring, ipaddr, ppx_deriving.std 28 | BuildTools: nanomsg_bindgen 29 | 30 | Library "nanomsg_lwt" 31 | Path: lib 32 | Modules: Nanomsg_lwt 33 | FindlibParent: nanomsg 34 | FindlibName: lwt 35 | Build$: flag(lwt) 36 | Install$: flag(lwt) 37 | BuildDepends: nanomsg, lwt.unix 38 | 39 | Library "nanomsg_async" 40 | Path: lib 41 | Modules: Nanomsg_async 42 | FindlibParent: nanomsg 43 | FindlibName: async 44 | Build$: flag(async) 45 | Install$: flag(async) 46 | BuildDepends: nanomsg, core, async, threads 47 | 48 | Executable "nanomsg_bindgen" 49 | Install: false 50 | Path: lib_gen 51 | MainIs: nanomsg_bindgen.ml 52 | BuildDepends: ctypes.stubs 53 | 54 | Executable "base_suite" 55 | Build$: flag(tests) 56 | Install: false 57 | Path: lib_test 58 | MainIs: base_suite.ml 59 | BuildDepends: nanomsg, oUnit (>= 2.0) 60 | CompiledObject: best 61 | 62 | Executable "lwt_suite" 63 | Build$: flag(tests) && flag(lwt) 64 | Install: false 65 | Path: lib_test 66 | MainIs: lwt_suite.ml 67 | BuildDepends: nanomsg.lwt, oUnit (>= 2.0) 68 | CompiledObject: best 69 | 70 | Test "nanomsg" 71 | Command: $base_suite 72 | 73 | Test "nanomsg_lwt" 74 | Command: $lwt_suite 75 | 76 | AlphaFeatures: ocamlbuild_more_args 77 | Document "api" 78 | Type: ocamlbuild (0.4) 79 | BuildTools: ocamldoc 80 | Title: API reference for Nanomsg 81 | 82 | XOCamlbuildPath: . 83 | XOCamlbuildExtraArgs: "-docflags '-colorize-code -short-functors -charset utf-8'" 84 | XOCamlbuildLibraries: nanomsg 85 | 86 | SourceRepository "master" 87 | Type: git 88 | Location: https://github.com/rgrinberg/onanomsg.git 89 | Branch: master 90 | Browser: https://github.com/rgrinberg/onanomsg 91 | -------------------------------------------------------------------------------- /lib/nanomsg.ml: -------------------------------------------------------------------------------- 1 | open Nanomsg_utils 2 | 3 | type error = string * string 4 | type socket = int 5 | 6 | type domain = 7 | | AF_SP [@value 1] 8 | | AF_SP_RAW 9 | [@@deriving enum, show] 10 | 11 | type proto = 12 | | Pair [@value 16] 13 | | Pub [@value 32] 14 | | Sub [@value 33] 15 | | Req [@value 48] 16 | | Rep [@value 49] 17 | | Push [@value 80] 18 | | Pull [@value 81] 19 | | Surveyor [@value 98] 20 | | Respondent [@value 99] 21 | | Bus [@value 112] 22 | [@@deriving enum, show] 23 | 24 | module Addr = struct 25 | module V4 = struct 26 | include Ipaddr.V4 27 | let pp = pp 28 | end 29 | 30 | module V6 = struct 31 | include Ipaddr.V6 32 | let pp = pp 33 | end 34 | 35 | type bind = [ 36 | | `All 37 | | `V4 of V4.t 38 | | `V6 of V6.t 39 | | `Iface of string ] 40 | [@@deriving show] 41 | 42 | type connect = 43 | ([`V4 of V4.t | `V6 of V6.t | `Dns of string] * 44 | [`V4 of V4.t | `V6 of V6.t | `Iface of string] option) 45 | [@@deriving show] 46 | 47 | type 'a t = [ 48 | | `Inproc of string 49 | | `Ipc of string 50 | | `Tcp of 'a * int 51 | ] [@@deriving show] 52 | 53 | let bind_iface_of_string = function 54 | | "*" -> `All 55 | | s when String.contains s ':' -> `V6 (Ipaddr.V6.of_string_exn s) 56 | | s -> try `V4 (Ipaddr.V4.of_string_exn s) with _ -> `Iface s 57 | 58 | let connect_iface_of_string = function 59 | | s when String.contains s ':' -> `V6 (Ipaddr.V6.of_string_exn s) 60 | | s -> try `V4 (Ipaddr.V4.of_string_exn s) with _ -> `Iface s 61 | 62 | let iface_to_string = function 63 | | `All -> "*" 64 | | `V4 v4 -> Ipaddr.V4.to_string v4 65 | | `V6 v6 -> Ipaddr.V6.to_string v6 66 | | `Iface ifname -> ifname 67 | 68 | let addr_of_string = function 69 | | s when String.contains s ':' -> `V6 (Ipaddr.V6.of_string_exn s) 70 | | s -> try `V4 (Ipaddr.V4.of_string_exn s) with _ -> `Dns s 71 | 72 | let addr_to_string = function 73 | | `V4 v4 -> Ipaddr.V4.to_string v4 74 | | `V6 v6 -> Ipaddr.V6.to_string v6 75 | | `Dns n -> n 76 | 77 | let bind_to_string = function 78 | | `Inproc a -> "inproc://" ^ a 79 | | `Ipc a -> "ipc://" ^ a 80 | | `Tcp (bind, port) -> 81 | let interface = iface_to_string bind in 82 | "tcp://" ^ interface ^ ":" ^ string_of_int port 83 | 84 | let connect_to_string = function 85 | | `Inproc a -> "inproc://" ^ a 86 | | `Ipc a -> "ipc://" ^ a 87 | | `Tcp ((addr, iface), port) -> 88 | let iface = Opt.map iface_to_string iface in 89 | let addr = addr_to_string addr in 90 | "tcp://" ^ 91 | (match iface with Some i -> i ^ ";" | None -> "") 92 | ^ addr ^ ":" ^ string_of_int port 93 | 94 | let of_string s = 95 | let len = String.length s in 96 | let addr_start = String.index s '/' + 2 in 97 | let addr_len = len - addr_start in 98 | match String.sub s 0 (addr_start - 3) with 99 | | "inproc" -> `Inproc (String.sub s addr_start addr_len) 100 | | "ipc" -> `Ipc (String.sub s addr_start addr_len) 101 | | "tcp" -> 102 | let port_start = String.rindex s ':' + 1 in 103 | let port = String.sub s port_start (len - port_start) in 104 | let port, port_len = int_of_string port, String.length port in 105 | let addr = String.sub s addr_start (addr_len - port_len - 1) in 106 | `Tcp (addr, port) 107 | | _ -> invalid_arg "addr_of_string" 108 | 109 | let bind_of_string s = match of_string s with 110 | | `Inproc _ | `Ipc _ as s -> s 111 | | `Tcp (addr, port) -> 112 | let iface = bind_iface_of_string addr in 113 | `Tcp (iface, port) 114 | 115 | let connect_of_string s = match of_string s with 116 | | `Inproc _ | `Ipc _ as s -> s 117 | | `Tcp (iface_addr, port) -> 118 | if String.contains iface_addr ';' then 119 | let len = String.length iface_addr in 120 | let addr_start = String.index iface_addr ';' + 1 in 121 | let addr = String.sub iface_addr addr_start (len - addr_start) in 122 | let iface = String.(sub iface_addr 0 @@ addr_start - 1) in 123 | `Tcp ((addr_of_string addr, Some (connect_iface_of_string iface)), port) 124 | else 125 | `Tcp ((addr_of_string iface_addr, None), port) 126 | end 127 | 128 | 129 | type eid = int 130 | 131 | let socket ?(domain=AF_SP) proto = 132 | error_if_negative (fun () -> 133 | C.nn_socket (domain_to_enum domain) (proto_to_enum proto)) 134 | 135 | let socket_exn ?(domain=AF_SP) proto = 136 | socket ~domain proto |> Res.get_exn 137 | 138 | let bind sock addr = 139 | error_if_negative (fun () -> C.nn_bind sock @@ Addr.bind_to_string addr) 140 | 141 | let bind_exn sock addr = 142 | bind sock addr |> Res.get_exn 143 | 144 | let connect sock addr = 145 | error_if_negative (fun () -> C.nn_connect sock @@ Addr.connect_to_string addr) 146 | 147 | let connect_exn sock addr = connect sock addr |> Res.get_exn 148 | 149 | let shutdown s e = 150 | Res.map ignore @@ 151 | error_if_notequal 0 (fun () -> C.nn_shutdown s e) 152 | 153 | let shutdown_exn s e = shutdown s e |> Res.get_exn 154 | 155 | let close sock = 156 | Res.map ignore @@ 157 | error_if_notequal 0 (fun () -> C.nn_close sock) 158 | 159 | let close_exn sock = close sock |> Res.get_exn 160 | 161 | (* getsockopt *) 162 | 163 | let getsockopt ~typ ~init sock level opt = 164 | let open Res in 165 | let open Ctypes in 166 | let p = allocate typ init in 167 | let size = allocate size_t @@ Unsigned.Size_t.of_int (sizeof typ) in 168 | error_if_notequal 0 (fun () -> 169 | C.nn_getsockopt sock 170 | Symbol.(value_of_name_exn level) 171 | Symbol.(value_of_name_exn opt) 172 | (to_voidp p) size 173 | ) >|= fun _ -> !@ p 174 | 175 | let getsockopt_int = getsockopt ~typ:Ctypes.int ~init:0 176 | 177 | let domain sock = 178 | let open Res in 179 | getsockopt_int sock "NN_SOL_SOCKET" "NN_DOMAIN" >>= fun v -> 180 | match domain_of_enum v with 181 | | Some v -> Result.Ok v 182 | | None -> Result.Error ("Internal", "domain_of_enum") 183 | 184 | let proto sock = 185 | let open Res in 186 | getsockopt_int sock "NN_SOL_SOCKET" "NN_PROTOCOL" >>= fun v -> 187 | match proto_of_enum v with 188 | | Some v -> Result.Ok v 189 | | None -> Result.Error ("Internal", "proto_of_enum") 190 | 191 | let get_linger sock = 192 | Res.map (fun n -> if n < 0 then `Inf else `Ms n) @@ 193 | getsockopt_int sock "NN_SOL_SOCKET" "NN_LINGER" 194 | 195 | let get_send_bufsize sock = 196 | getsockopt_int sock "NN_SOL_SOCKET" "NN_SNDBUF" 197 | 198 | let get_recv_bufsize sock = 199 | getsockopt_int sock "NN_SOL_SOCKET" "NN_RCVBUF" 200 | 201 | let get_send_timeout sock = 202 | Res.map (fun n -> if n < 0 then `Inf else `Ms n) @@ 203 | getsockopt_int sock "NN_SOL_SOCKET" "NN_SNDTIMEO" 204 | 205 | let get_recv_timeout sock = 206 | Res.map (fun n -> if n < 0 then `Inf else `Ms n) @@ 207 | getsockopt_int sock "NN_SOL_SOCKET" "NN_RCVTIMEO" 208 | 209 | let get_reconnect_ival sock = 210 | getsockopt_int sock "NN_SOL_SOCKET" "NN_RECONNECT_IVL" 211 | 212 | let get_reconnect_ival_max sock = 213 | getsockopt_int sock "NN_SOL_SOCKET" "NN_RECONNECT_IVL_MAX" 214 | 215 | let get_send_prio sock = 216 | getsockopt_int sock "NN_SOL_SOCKET" "NN_SNDPRIO" 217 | 218 | let get_recv_prio sock = 219 | getsockopt_int sock "NN_SOL_SOCKET" "NN_RCVPRIO" 220 | 221 | let get_ipv4only sock = 222 | Res.map bool_of_int @@ 223 | getsockopt_int sock "NN_SOL_SOCKET" "NN_IPV4ONLY" 224 | 225 | let send_fd sock = 226 | let open Res in 227 | getsockopt_int sock "NN_SOL_SOCKET" "NN_SNDFD" >|= fun fd -> 228 | (Obj.magic fd : Unix.file_descr) 229 | 230 | let recv_fd sock = 231 | let open Res in 232 | getsockopt_int sock "NN_SOL_SOCKET" "NN_RCVFD" >|= fun fd -> 233 | (Obj.magic fd : Unix.file_descr) 234 | 235 | let send_bigstring_buf ?(block=true) sock buf pos len = 236 | if pos < 0 || len < 0 || pos + len > Bigstring.size buf 237 | then invalid_arg "bounds"; 238 | let nn_buf = C.nn_allocmsg (Unsigned.Size_t.of_int len) 0 in 239 | match nn_buf with 240 | | None -> error () 241 | | Some nn_buf -> 242 | let nn_buf_p = Ctypes.(allocate (ptr void) nn_buf) in 243 | let ba = Ctypes.(bigarray_of_ptr array1 len 244 | Bigarray.char @@ from_voidp char nn_buf) in 245 | Bigstring.blit buf pos ba 0 len; 246 | Res.map ignore @@ 247 | error_if_notequal len 248 | (fun () -> C.nn_send sock nn_buf_p 249 | (Unsigned.Size_t.of_int (-1)) (int_of_bool @@ not block)) 250 | 251 | let send_bigstring ?(block=true) sock buf = 252 | send_bigstring_buf ~block sock buf 0 @@ Bigstring.size buf 253 | 254 | let send_bytes_buf ?(block=true) sock buf pos len = 255 | if pos < 0 || len < 0 || pos + len > Bytes.length buf 256 | then invalid_arg "bounds"; 257 | let nn_buf = C.nn_allocmsg (Unsigned.Size_t.of_int len) 0 in 258 | match nn_buf with 259 | | None -> error () 260 | | Some nn_buf -> 261 | let nn_buf_p = Ctypes.(allocate (ptr void) nn_buf) in 262 | let ba = Ctypes.(bigarray_of_ptr array1 len 263 | Bigarray.char @@ from_voidp char nn_buf) in 264 | Bigstring.blit_of_bytes buf pos ba 0 len; 265 | Res.map ignore @@ 266 | error_if_notequal len 267 | (fun () -> C.nn_send sock nn_buf_p 268 | (Unsigned.Size_t.of_int (-1)) (int_of_bool @@ not block)) 269 | 270 | let send_bytes ?(block=true) sock b = 271 | send_bytes_buf ~block sock b 0 @@ Bytes.length b 272 | 273 | let send_string_buf ?(block=true) sock s pos len = 274 | send_bytes_buf ~block sock (Bytes.unsafe_of_string s) pos len 275 | 276 | let send_string ?(block=true) sock s = 277 | send_bytes_buf ~block sock (Bytes.unsafe_of_string s) 0 (String.length s) 278 | 279 | let recv ?(block=true) sock f = 280 | let open Ctypes in 281 | let ba_start_p = allocate (ptr void) null in 282 | let nb_recv = 283 | error_if_negative 284 | (fun () -> C.nn_recv sock ba_start_p 285 | (Unsigned.Size_t.of_int (-1)) (int_of_bool @@ not block)) in 286 | let ba_start = !@ ba_start_p in 287 | Res.map 288 | (fun nb_recv -> 289 | let ba = bigarray_of_ptr array1 nb_recv 290 | Bigarray.char (from_voidp char ba_start) in 291 | let res = f ba in 292 | let (_:int) = C.nn_freemsg ba_start in 293 | res) nb_recv 294 | 295 | let recv_bytes_buf ?(block=true) sock buf pos = 296 | recv ~block sock 297 | (fun ba -> 298 | let len = Bigstring.size ba in 299 | Bigstring.(blit_to_bytes ba 0 buf pos len); 300 | len 301 | ) 302 | 303 | let recv_bytes ?(block=true) sock = 304 | recv ~block sock (fun ba -> 305 | let len = Bigstring.size ba in 306 | let buf = Bytes.create len in 307 | Bigstring.blit_to_bytes ba 0 buf 0 len; 308 | buf) 309 | 310 | let recv_string ?(block=true) sock = 311 | Res.map Bytes.unsafe_to_string @@ recv_bytes ~block sock 312 | 313 | let setsockopt sock level opt optval optvalsize = 314 | let open Ctypes in 315 | error_if_negative_ign (fun () -> 316 | C.nn_setsockopt sock 317 | (Symbol.value_of_name_exn level) 318 | (Symbol.value_of_name_exn opt) 319 | (to_voidp optval) 320 | (Unsigned.Size_t.of_int optvalsize) 321 | ) 322 | 323 | let setsockopt_int sock level opt v = 324 | let open Ctypes in 325 | setsockopt sock level opt (allocate int v) (sizeof int) 326 | 327 | let subscribe sock topic = 328 | setsockopt sock "NN_SUB" "NN_SUB_SUBSCRIBE" 329 | Ctypes.(allocate string topic) (String.length topic) 330 | 331 | let unsubscribe sock topic = 332 | setsockopt sock "NN_SUB" "NN_SUB_UNSUBSCRIBE" 333 | Ctypes.(allocate string topic) (String.length topic) 334 | 335 | 336 | let set_linger sock duration = 337 | setsockopt_int sock "NN_SOL_SOCKET" "NN_LINGER" (int_of_duration duration) 338 | 339 | let set_send_bufsize sock size = 340 | setsockopt_int sock "NN_SOL_SOCKET" "NN_SNDBUF" size 341 | 342 | let set_recv_bufsize sock size = 343 | setsockopt_int sock "NN_SOL_SOCKET" "NN_RCVBUF" size 344 | 345 | let set_send_timeout sock duration = 346 | setsockopt_int sock "NN_SOL_SOCKET" "NN_SNDTIMEO" (int_of_duration duration) 347 | 348 | let set_recv_timeout sock duration = 349 | setsockopt_int sock "NN_SOL_SOCKET" "NN_RCVTIMEO" (int_of_duration duration) 350 | 351 | let set_reconnect_ival sock ival = 352 | setsockopt_int sock "NN_SOL_SOCKET" "NN_RECONNECT_IVL" ival 353 | 354 | let set_reconnect_ival_max sock ival = 355 | setsockopt_int sock "NN_SOL_SOCKET" "NN_RECONNECT_IVL_MAX" ival 356 | 357 | let set_send_prio sock priority = 358 | if priority < 1 || priority > 16 then invalid_arg "set_send_priority"; 359 | setsockopt_int sock "NN_SOL_SOCKET" "NN_SNDPRIO" priority 360 | 361 | let set_recv_prio sock priority = 362 | if priority < 1 || priority > 16 then invalid_arg "set_recv_priority"; 363 | setsockopt_int sock "NN_SOL_SOCKET" "NN_RCVPRIO" priority 364 | 365 | let set_ipv4_only sock b = 366 | setsockopt_int sock "NN_SOL_SOCKET" "NN_IPV4ONLY" (int_of_bool b) 367 | 368 | let term = C.nn_term 369 | 370 | let device s1 s2 = 371 | (fun () -> C.nn_device s1 s2) 372 | |> error_if_negative 373 | |> Res.map ignore 374 | -------------------------------------------------------------------------------- /lib/nanomsg.mli: -------------------------------------------------------------------------------- 1 | type domain = 2 | | AF_SP 3 | | AF_SP_RAW 4 | [@@deriving show] 5 | 6 | type proto = 7 | | Pair 8 | | Pub 9 | | Sub 10 | | Req 11 | | Rep 12 | | Push 13 | | Pull 14 | | Surveyor 15 | | Respondent 16 | | Bus 17 | [@@deriving show] 18 | 19 | type socket 20 | 21 | module Addr : sig 22 | type bind = [ 23 | | `All 24 | | `V4 of Ipaddr.V4.t 25 | | `V6 of Ipaddr.V6.t 26 | | `Iface of string ] 27 | [@@deriving show] 28 | 29 | type connect = 30 | [`V4 of Ipaddr.V4.t | `V6 of Ipaddr.V6.t | `Dns of string] * 31 | [`V4 of Ipaddr.V4.t | `V6 of Ipaddr.V6.t | `Iface of string] option 32 | [@@deriving show] 33 | 34 | type 'a t = [ 35 | | `Inproc of string 36 | | `Ipc of string 37 | | `Tcp of 'a * int 38 | ] [@@deriving show] 39 | 40 | val bind_of_string : string -> bind t 41 | val bind_to_string : bind t -> string 42 | val connect_of_string : string -> connect t 43 | val connect_to_string : connect t -> string 44 | end 45 | 46 | type eid 47 | 48 | (** {1 Exceptions} *) 49 | 50 | (** {1 Socket management } *) 51 | type error = string * string 52 | val socket : ?domain:domain -> proto -> (socket, error) Result.result 53 | val socket_exn : ?domain:domain -> proto -> socket 54 | val bind : socket -> Addr.bind Addr.t -> (eid, error) Result.result 55 | val bind_exn : socket -> Addr.bind Addr.t -> eid 56 | val connect : socket -> Addr.connect Addr.t -> (eid, error) Result.result 57 | val connect_exn : socket -> Addr.connect Addr.t -> eid 58 | val shutdown : socket -> eid -> (unit, error) Result.result 59 | val shutdown_exn : socket -> eid -> unit 60 | val close : socket -> (unit, error) Result.result 61 | val close_exn : socket -> unit 62 | val device : socket -> socket -> (unit, error) Result.result 63 | 64 | (** {1 I/O } *) 65 | 66 | (** {2 Zero-copy I/O} *) 67 | 68 | val send_bigstring : ?block:bool -> socket -> Bigstring.t -> (unit, error) Result.result 69 | val send_bigstring_buf : ?block:bool -> socket -> Bigstring.t -> int -> int -> (unit, error) Result.result 70 | val send_string : ?block:bool -> socket -> string -> (unit, error) Result.result 71 | val send_string_buf : ?block:bool -> socket -> string -> int -> int -> (unit, error) Result.result 72 | val send_bytes : ?block:bool -> socket -> Bytes.t -> (unit, error) Result.result 73 | val send_bytes_buf : ?block:bool -> socket -> Bytes.t -> int -> int -> (unit, error) Result.result 74 | 75 | val recv : ?block:bool -> socket -> (Bigstring.t -> 'a) -> ('a, error) Result.result 76 | (** [recv ?block sock f] applies [f] to the received message. The 77 | argument of [f] gets unallocated after [f] returns, so make sure 78 | [f] {b never} let a reference to its argument escape. *) 79 | 80 | (** {2 Legacy I/O} *) 81 | 82 | val recv_string : ?block:bool -> socket -> (string, error) Result.result 83 | val recv_bytes : ?block:bool -> socket -> (Bytes.t, error) Result.result 84 | val recv_bytes_buf :?block:bool -> socket -> Bytes.t -> int -> (int, error) Result.result 85 | 86 | (** {1 Get socket options} *) 87 | 88 | val domain : socket -> (domain, error) Result.result 89 | val proto : socket -> (proto, error) Result.result 90 | val send_fd : socket -> (Unix.file_descr, error) Result.result 91 | val recv_fd : socket -> (Unix.file_descr, error) Result.result 92 | 93 | val get_linger : socket -> ([`Inf | `Ms of int], error) Result.result 94 | val get_send_bufsize : socket -> (int, error) Result.result 95 | val get_recv_bufsize : socket -> (int, error) Result.result 96 | val get_send_timeout : socket -> ([`Inf | `Ms of int], error) Result.result 97 | val get_recv_timeout : socket -> ([`Inf | `Ms of int], error) Result.result 98 | val get_reconnect_ival : socket -> (int, error) Result.result 99 | val get_reconnect_ival_max : socket -> (int, error) Result.result 100 | val get_send_prio : socket -> (int, error) Result.result 101 | val get_recv_prio : socket -> (int, error) Result.result 102 | val get_ipv4only : socket -> (bool, error) Result.result 103 | 104 | (** {1 Set socket options} *) 105 | 106 | (** {2 General} *) 107 | 108 | val set_linger : socket -> [`Inf | `Ms of int] -> (unit, error) Result.result 109 | val set_send_bufsize : socket -> int -> (unit, error) Result.result 110 | val set_recv_bufsize : socket -> int -> (unit, error) Result.result 111 | val set_send_timeout : socket -> [`Inf | `Ms of int] -> (unit, error) Result.result 112 | val set_recv_timeout : socket -> [`Inf | `Ms of int] -> (unit, error) Result.result 113 | val set_reconnect_ival : socket -> int -> (unit, error) Result.result 114 | val set_reconnect_ival_max : socket -> int -> (unit, error) Result.result 115 | val set_send_prio : socket -> int -> (unit, error) Result.result 116 | val set_recv_prio : socket -> int -> (unit, error) Result.result 117 | val set_ipv4_only : socket -> bool -> (unit, error) Result.result 118 | 119 | (** {2 PubSub} *) 120 | 121 | val subscribe : socket -> string -> (unit, error) Result.result 122 | val unsubscribe : socket -> string -> (unit, error) Result.result 123 | 124 | (** {1 Termination} *) 125 | 126 | val term : unit -> unit 127 | -------------------------------------------------------------------------------- /lib/nanomsg_async.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | module Bytes = Caml.Bytes 5 | 6 | open Nanomsg_utils 7 | open Nanomsg 8 | 9 | let ready sock io_event = 10 | let f = match io_event with 11 | | `Write -> send_fd 12 | | `Read -> recv_fd 13 | in 14 | f sock |> function 15 | | Error _ -> return @@ `Bad_fd 16 | | Ok fd -> 17 | let fd = Fd.create ~avoid_nonblock_if_possible:true 18 | (Fd.Kind.Socket `Passive) fd 19 | Info.(of_string "nanomsg pollfd") in 20 | Fd.ready_to fd io_event 21 | 22 | let send_buf blitf lenf sock buf pos len = 23 | if pos < 0 || len < 0 || pos + len > lenf buf 24 | then return @@ Result.Error ("Internal", "bounds") 25 | else 26 | C.nn_allocmsg (Unsigned.Size_t.of_int len) 0 |> function 27 | | None -> return @@ error () 28 | | Some nn_buf -> 29 | let nn_buf_p = Ctypes.(allocate (ptr void) nn_buf) in 30 | let ba = Ctypes.(bigarray_of_ptr array1 len 31 | Bigarray.char @@ from_voidp char nn_buf) in 32 | blitf ~src:buf ~src_pos:pos ~dst:ba ~dst_pos:0 ~len; 33 | ready sock `Write >>| function 34 | | `Bad_fd | `Closed -> Result.Error ("Internal", "`Bad_fd | `Closed") 35 | | `Ready -> 36 | let _ = 37 | C.nn_send (Obj.magic sock : int) 38 | nn_buf_p (Unsigned.Size_t.of_int (-1)) 39 | Symbol.(value_of_name_exn "NN_DONTWAIT") in 40 | Result.Ok () 41 | 42 | let send_bigstring_buf = send_buf Bigstring.blit Bigstring.length 43 | let send_bytes_buf = send_buf Bigstring.From_string.blit Bytes.length 44 | 45 | let send_bigstring sock buf = 46 | send_bigstring_buf sock buf 0 @@ Bigstring.length buf 47 | 48 | let send_bytes sock b = 49 | send_bytes_buf sock b 0 (Bytes.length b) 50 | 51 | let send_string_buf sock s pos len = 52 | send_bytes_buf sock (Bytes.unsafe_of_string s) pos len 53 | 54 | let send_string sock s = 55 | send_bytes_buf sock (Bytes.unsafe_of_string s) 0 (String.length s) 56 | 57 | let recv sock f = 58 | let open Ctypes in 59 | let ba_start_p = allocate (ptr void) null in 60 | ready sock `Read >>= function 61 | | `Bad_fd | `Closed -> 62 | return @@ Result.Error ("Internal", "`Bad_fd | `Closed") 63 | | `Ready -> 64 | let nb_recv = C.nn_recv (Obj.magic sock : int) 65 | ba_start_p (Unsigned.Size_t.of_int (-1)) 66 | Symbol.(value_of_name_exn "NN_DONTWAIT") in 67 | let ba_start = !@ ba_start_p in 68 | let ba = bigarray_of_ptr array1 nb_recv 69 | Bigarray.char (from_voidp char ba_start) in 70 | f ba >>| fun res -> 71 | let (_:int) = C.nn_freemsg ba_start in 72 | Result.Ok res 73 | 74 | let recv_bytes_buf sock buf pos = 75 | recv sock (fun ba -> 76 | let len = Bigstring.length ba in 77 | Bigstring.To_string.blit ba 0 buf pos len; 78 | return len 79 | ) 80 | 81 | let recv_bytes sock = 82 | recv sock (fun ba -> 83 | let len = Bigstring.length ba in 84 | let buf = Bytes.create len in 85 | Bigstring.To_string.blit ~src:ba ~src_pos:0 ~dst:buf ~dst_pos:0 ~len; 86 | return buf 87 | ) 88 | 89 | let recv_string sock = 90 | recv_bytes sock >>| Nanomsg_utils.Res.map Bytes.unsafe_to_string 91 | 92 | -------------------------------------------------------------------------------- /lib/nanomsg_async.mli: -------------------------------------------------------------------------------- 1 | open Async 2 | open Nanomsg 3 | 4 | (** {1 Asynchronous I/O} *) 5 | 6 | (** {2 Zero-copy I/O} *) 7 | 8 | val send_bigstring : socket -> Bigstring.t -> 9 | (unit, error) Result.result Deferred.t 10 | 11 | val send_bigstring_buf : socket -> Bigstring.t -> int -> int -> 12 | (unit, error) Result.result Deferred.t 13 | 14 | val send_string : socket -> string -> (unit, error) Result.result Deferred.t 15 | 16 | val send_string_buf : socket -> string -> int -> int -> 17 | (unit, error) Result.result Deferred.t 18 | 19 | val send_bytes : socket -> Bytes.t -> (unit, error) Result.result Deferred.t 20 | 21 | val send_bytes_buf : socket -> Bytes.t -> int -> int -> 22 | (unit, error) Result.result Deferred.t 23 | 24 | val recv : socket -> (Bigstring.t -> 'a Deferred.t) -> ('a, error) Result.result Deferred.t 25 | (** [recv sock f] applies [f] to the received message. The 26 | argument of [f] gets unallocated after [f] returns, so make sure 27 | [f] {b never} let a reference to its argument escape. *) 28 | 29 | (** {2 Legacy I/O} *) 30 | 31 | val recv_string : socket -> (string, error) Result.result Deferred.t 32 | val recv_bytes : socket -> (Bytes.t, error) Result.result Deferred.t 33 | val recv_bytes_buf : socket -> Bytes.t -> int -> (int, error) Result.result Deferred.t 34 | -------------------------------------------------------------------------------- /lib/nanomsg_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | open Nanomsg_utils 4 | open Nanomsg 5 | 6 | exception Error of string * string 7 | 8 | let wrap_error = function 9 | | Result.Error (name, descr) -> Lwt.fail (Error (name, descr)) 10 | | Result.Ok a -> Lwt.return a 11 | 12 | let bind_error f = function 13 | | Result.Error (name, descr) -> Lwt.fail (Error (name, descr)) 14 | | Result.Ok a -> f a 15 | 16 | let map_error f = function 17 | | Result.Error (name, descr) -> Lwt.fail (Error (name, descr)) 18 | | Result.Ok a -> Lwt.return (f a) 19 | 20 | let throw () = 21 | let code = C.nn_errno () in 22 | let err_string = C.nn_strerror code in 23 | let err_value = 24 | if code > 156384712 25 | then Symbol.errvalue_of_errno_exn code 26 | else "" in 27 | Lwt.fail (Error (err_value, err_string)) 28 | 29 | let fail_if sock io_event cond f = 30 | bind_error 31 | (fun fd -> 32 | Lwt_unix.(wrap_syscall io_event (of_unix_file_descr fd) f) >>= fun res -> 33 | if cond res then throw () else Lwt.return res 34 | ) 35 | (match io_event with 36 | | Lwt_unix.Write -> send_fd sock 37 | | Lwt_unix.Read -> recv_fd sock 38 | ) 39 | 40 | 41 | let fail_negative sock io_event f = fail_if sock io_event (fun x -> x < 0) f 42 | let fail_notequal sock io_event v f = fail_if sock io_event (fun x -> x <> v) f 43 | 44 | let send_buf ?(pos=0) ?len blitf lenf sock buf = 45 | let len = match len with 46 | | None -> lenf buf 47 | | Some len -> len 48 | in 49 | if pos < 0 || len < 0 || pos + len > lenf buf 50 | then Lwt.fail (Error ("Internal", "bounds")) 51 | else 52 | let nn_buf = C.nn_allocmsg (Unsigned.Size_t.of_int len) 0 in 53 | match nn_buf with 54 | | None -> throw () 55 | | Some nn_buf -> 56 | let nn_buf_p = Ctypes.(allocate (ptr void) nn_buf) in 57 | let ba = Ctypes.(bigarray_of_ptr array1 len 58 | Bigarray.char @@ from_voidp char nn_buf) in 59 | blitf buf pos ba 0 len; 60 | fail_notequal sock Lwt_unix.Write len 61 | (fun () -> C.nn_send (Obj.magic sock : int) 62 | nn_buf_p (Unsigned.Size_t.of_int (-1)) 63 | Symbol.(value_of_name_exn "NN_DONTWAIT")) >|= fun nb_written -> 64 | ignore nb_written 65 | 66 | let send_bigstring ?pos ?len sock buf = 67 | send_buf ?pos ?len Bigstring.blit Bigstring.size sock buf 68 | let send_bytes ?pos ?len sock buf = 69 | send_buf ?pos ?len Bigstring.blit_of_bytes Bytes.length sock buf 70 | let send_string ?pos ?len sock s = 71 | send_buf ?pos ?len Bigstring.blit_of_bytes Bytes.length sock (Bytes.unsafe_of_string s) 72 | 73 | let recv sock f = 74 | let open Lwt_unix in 75 | let open Ctypes in 76 | let ba_start_p = allocate (ptr void) null in 77 | fail_negative sock Lwt_unix.Read 78 | (fun () -> C.nn_recv (Obj.magic sock : int) 79 | ba_start_p (Unsigned.Size_t.of_int (-1)) 80 | Symbol.(value_of_name_exn "NN_DONTWAIT")) >>= fun nb_recv -> 81 | let ba_start = !@ ba_start_p in 82 | let ba = bigarray_of_ptr array1 nb_recv 83 | Bigarray.char (from_voidp char ba_start) in 84 | f ba >|= fun res -> 85 | let (_:int) = C.nn_freemsg ba_start in 86 | res 87 | 88 | let recv_buf ?(pos=0) sock buf = 89 | recv sock (fun ba -> 90 | let len = Bigstring.size ba in 91 | Bigstring.blit_to_bytes ba 0 buf pos len; 92 | Lwt.return len 93 | ) 94 | 95 | let recv_bytes sock = 96 | recv sock (fun ba -> 97 | let len = Bigstring.size ba in 98 | let buf = Bytes.create len in 99 | Bigstring.blit_to_bytes ba 0 buf 0 len; 100 | Lwt.return buf 101 | ) 102 | 103 | let recv_string sock = recv_bytes sock >|= Bytes.unsafe_to_string 104 | 105 | -------------------------------------------------------------------------------- /lib/nanomsg_lwt.mli: -------------------------------------------------------------------------------- 1 | open Nanomsg 2 | 3 | exception Error of string * string 4 | 5 | val wrap_error : ('a, error) Result.result -> 'a Lwt.t 6 | val bind_error : ('a -> 'b Lwt.t) -> ('a, error) Result.result -> 'b Lwt.t 7 | val map_error : ('a -> 'b) -> ('a, error) Result.result -> 'b Lwt.t 8 | 9 | (** {1 Asynchronous I/O} *) 10 | 11 | (** {2 Zero-copy I/O} *) 12 | 13 | val send_bigstring : ?pos:int -> ?len:int -> socket -> Bigstring.t -> unit Lwt.t 14 | val send_string : ?pos:int -> ?len:int -> socket -> string -> unit Lwt.t 15 | val send_bytes : ?pos:int -> ?len:int -> socket -> Bytes.t -> unit Lwt.t 16 | 17 | val recv : socket -> (Bigstring.t -> 'a Lwt.t) -> 'a Lwt.t 18 | (** [recv sock f] applies [f] to the received message. The 19 | argument of [f] gets unallocated after [f] returns, so make sure 20 | [f] {b never} let a reference to its argument escape. *) 21 | 22 | (** {2 Legacy I/O} *) 23 | 24 | val recv_buf : ?pos:int -> socket -> Bytes.t -> int Lwt.t 25 | val recv_string : socket -> string Lwt.t 26 | val recv_bytes : socket -> Bytes.t Lwt.t 27 | -------------------------------------------------------------------------------- /lib/nanomsg_utils.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | module C = Nanomsg_bindings.C(Nanomsg_generated) 3 | 4 | let int_of_duration = function `Inf -> -1 | `Ms x -> x 5 | let int_of_bool = function false -> 0 | true -> 1 6 | let bool_of_int = function 0 -> false | _ -> true 7 | 8 | module Opt = struct 9 | let map f = function 10 | | None -> None 11 | | Some x -> Some (f x) 12 | end 13 | 14 | module Res = struct 15 | open Result 16 | 17 | let get_exn = function 18 | | Ok x -> x 19 | | Error _ -> invalid_arg "Result.get_exn" 20 | let map f = function 21 | | Ok x -> Ok (f x) 22 | | Error e -> Error e 23 | let (>|=) e f = map f e 24 | let (>>=) x f = match x with 25 | | Error e -> Error e 26 | | Ok x -> f x 27 | let catch x ~ok ~err = match x with 28 | | Error e -> err e 29 | | Ok y -> ok y 30 | end 31 | 32 | module Ipaddr = struct 33 | include Ipaddr 34 | let pp = pp 35 | end 36 | 37 | module Symbol = struct 38 | type t = { 39 | sp_value: int; 40 | sp_name: string; 41 | sp_ns: int; 42 | sp_type: int; 43 | sp_unit: int; 44 | } 45 | 46 | let table = Hashtbl.create 13 47 | 48 | (* This will be run at program start. *) 49 | let () = 50 | let rec inner i = 51 | let open C in 52 | let sp = make nn_symbol_properties in 53 | let ret = nn_symbol_info i (addr sp) (sizeof nn_symbol_properties) in 54 | if ret = 0 then () else 55 | let sp' = 56 | { 57 | sp_value = getf sp nnsym_value; 58 | sp_name = getf sp nnsym_name; 59 | sp_ns = getf sp nnsym_ns; 60 | sp_type = getf sp nnsym_type; 61 | sp_unit = getf sp nnsym_unit; 62 | } in 63 | Hashtbl.add table sp'.sp_name sp'; 64 | inner @@ succ i 65 | in inner 0 66 | 67 | let value_of_name_exn name = let sp = Hashtbl.find table name in sp.sp_value 68 | let value_of_name name = try Some (value_of_name_exn name) with _ -> None 69 | let of_name_exn = Hashtbl.find table 70 | let of_name name = try Some (of_name_exn name) with _ -> None 71 | let errvalue_of_errno_exn errno = 72 | try 73 | Hashtbl.iter (fun k v -> 74 | if v.sp_value = errno then failwith v.sp_name) 75 | table; raise Not_found 76 | with Failure name -> name 77 | let errvalue_of_errno errno = 78 | try Some (errvalue_of_errno_exn errno) with Not_found -> None 79 | end 80 | 81 | let error () = 82 | let code = C.nn_errno () in 83 | let err_string = C.nn_strerror code in 84 | let err_value = 85 | if code > 156384712 86 | then Symbol.errvalue_of_errno_exn code 87 | else "" in 88 | Result.Error (err_value, err_string) 89 | 90 | let maybe_error cond f = 91 | let res = f () in 92 | if cond res then error () else Result.Ok res 93 | 94 | let maybe_error_ign cond f = 95 | let res = f () in 96 | if cond res then error () else Result.Ok () 97 | 98 | let error_if_negative = maybe_error (fun x -> x < 0) 99 | let error_if_notequal v = maybe_error (fun x -> x <> v) 100 | let error_if_negative_ign = maybe_error_ign (fun x -> x < 0) 101 | let error_if_notequal_ign v = maybe_error_ign (fun x -> x <> v) 102 | -------------------------------------------------------------------------------- /lib_gen/nanomsg_bindgen.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | let _ = 4 | let fmt = Format.formatter_of_out_channel (open_out "lib/nanomsg_stubs.c") in 5 | Format.fprintf fmt "#include @."; 6 | Format.fprintf fmt "#include @."; 7 | Cstubs.write_c fmt ~prefix:"caml_" (module Nanomsg_bindings.C); 8 | 9 | let fmt = Format.formatter_of_out_channel (open_out "lib/nanomsg_generated.ml") in 10 | Cstubs.write_ml fmt ~prefix:"caml_" (module Nanomsg_bindings.C) 11 | -------------------------------------------------------------------------------- /lib_gen/nanomsg_bindings.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | module C(F: Cstubs.FOREIGN) = struct 4 | type nn_iovec 5 | let nn_iovec : nn_iovec structure typ = structure "nn_iovec" 6 | let iov_base = field nn_iovec "iov_base" (ptr void) 7 | let iov_len = field nn_iovec "iov_len" size_t 8 | let () = seal nn_iovec 9 | 10 | type nn_msghdr 11 | let nn_msghdr : nn_msghdr structure typ = structure "nn_msghdr" 12 | let msg_iov = field nn_msghdr "msg_iov" (ptr nn_iovec) 13 | let msg_iovlen = field nn_msghdr "msg_iovlen" int 14 | let msg_control = field nn_msghdr "msg_control" (ptr void) 15 | let msg_controllen = field nn_msghdr "msg_controllen" size_t 16 | let () = seal nn_msghdr 17 | 18 | type nn_cmsghdr 19 | let nn_cmsghdr : nn_cmsghdr structure typ = structure "nn_cmsghdr" 20 | let cmsg_len = field nn_cmsghdr "cmsg_len" size_t 21 | let cmsg_level = field nn_cmsghdr "cmsg_level" int 22 | let cmsg_type = field nn_cmsghdr "cmsg_type" int 23 | let () = seal nn_cmsghdr 24 | 25 | type nn_symbol_properties 26 | let nn_symbol_properties : nn_symbol_properties structure typ = 27 | structure "nn_symbol_properties" 28 | let nnsym_value = field nn_symbol_properties "value" int 29 | let nnsym_name = field nn_symbol_properties "name" string 30 | let nnsym_ns = field nn_symbol_properties "ns" int 31 | let nnsym_type = field nn_symbol_properties "type" int 32 | let nnsym_unit = field nn_symbol_properties "unit" int 33 | let () = seal nn_symbol_properties 34 | 35 | let nn_errno = F.(foreign "nn_errno" (void @-> returning int)) 36 | let nn_strerror = F.(foreign "nn_strerror" (int @-> returning string)) 37 | let nn_term = F.(foreign "nn_term" (void @-> returning void)) 38 | let nn_device = F.(foreign "nn_device" (int @-> int @-> returning int)) 39 | 40 | let nn_socket = F.(foreign "nn_socket" (int @-> int @-> returning int)) 41 | let nn_close = F.(foreign "nn_close" (int @-> returning int)) 42 | let nn_bind = F.(foreign "nn_bind" (int @-> string @-> returning int)) 43 | let nn_connect = F.(foreign "nn_connect" (int @-> string @-> returning int)) 44 | let nn_shutdown = F.(foreign "nn_shutdown" (int @-> int @-> returning int)) 45 | 46 | (** Message allocation *) 47 | 48 | let nn_allocmsg = F.(foreign "nn_allocmsg" 49 | (size_t @-> int @-> returning (ptr_opt void))) 50 | let nn_reallocmsg = F.(foreign "nn_reallocmsg" 51 | (ptr void @-> size_t @-> returning (ptr_opt void))) 52 | let nn_freemsg = F.(foreign "nn_freemsg" 53 | (ptr void @-> returning int)) 54 | 55 | (** Send / Recv *) 56 | 57 | let nn_send = F.(foreign "nn_send" 58 | (int @-> ptr (ptr void) @-> size_t @-> int @-> returning int)) 59 | let nn_recv = F.(foreign "nn_recv" 60 | (int @-> ptr (ptr void) @-> size_t @-> int @-> returning int)) 61 | let nn_sendmsg = F.(foreign "nn_sendmsg" 62 | (int @-> ptr nn_msghdr @-> int @-> returning int)) 63 | let nn_recvmsg = F.(foreign "nn_recvmsg" 64 | (int @-> ptr nn_msghdr @-> int @-> returning int)) 65 | 66 | (** Setsockopt / Getsockopt *) 67 | 68 | let nn_getsockopt = F.(foreign "nn_getsockopt" 69 | (int @-> int @-> int @-> (ptr void) @-> (ptr size_t) @-> returning int)) 70 | let nn_setsockopt = F.(foreign "nn_setsockopt" 71 | (int @-> int @-> int @-> (ptr void) @-> size_t @-> returning int)) 72 | 73 | (** Runtime access to nanomsg's symbols *) 74 | 75 | let nn_symbol = F.(foreign "nn_symbol" 76 | (int @-> ptr int @-> returning string)) 77 | let nn_symbol_info = F.(foreign "nn_symbol_info" 78 | (int @-> ptr nn_symbol_properties @-> int @-> returning int)) 79 | end 80 | -------------------------------------------------------------------------------- /lib_test/base_suite.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Nanomsg 3 | 4 | let bind_addr_test ctx = 5 | let open Addr in 6 | assert_equal (`Inproc "9786/+-auieauie7658%=`!!") 7 | (bind_of_string "inproc://9786/+-auieauie7658%=`!!"); 8 | assert_equal (`Ipc "9786/+-auieauie7658%=`!!") 9 | (bind_of_string "ipc://9786/+-auieauie7658%=`!!"); 10 | assert_equal (`Tcp (`All, 1234)) 11 | (bind_of_string "tcp://*:1234"); 12 | assert_equal (`Tcp (`V4 Ipaddr.V4.localhost, 1234)) 13 | (bind_of_string "tcp://127.0.0.1:1234"); 14 | assert_equal ~msg:"ipv6" (`Tcp (`V6 Ipaddr.V6.localhost, 1234)) 15 | (bind_of_string "tcp://::1:1234"); 16 | assert_equal ~msg:"ifname" (`Tcp (`Iface "eth0", 1234)) 17 | (bind_of_string "tcp://eth0:1234") 18 | 19 | let connect_of_string_test ctx = 20 | let open Addr in 21 | assert_equal (`Inproc "9786/+-auieauie7658%=`!!") 22 | (connect_of_string "inproc://9786/+-auieauie7658%=`!!"); 23 | assert_equal (`Ipc "9786/+-auieauie7658%=`!!") 24 | (connect_of_string "ipc://9786/+-auieauie7658%=`!!"); 25 | assert_equal 26 | ~printer:(Addr.show Addr.pp_connect) ~msg:"tcp_with_iface" 27 | (`Tcp ((`V4 Ipaddr.V4.localhost, Some (`Iface "eth0")), 1234)) 28 | (connect_of_string "tcp://eth0;127.0.0.1:1234"); 29 | assert_equal 30 | ~printer:(Addr.show Addr.pp_connect) ~msg:"tcp_without_iface" 31 | (`Tcp ((`V4 Ipaddr.V4.localhost, None), 1234)) 32 | (connect_of_string "tcp://127.0.0.1:1234"); 33 | assert_equal 34 | ~printer:(Addr.show Addr.pp_connect) ~msg:"dns" 35 | (`Tcp ((`Dns "localhost", None), 1234)) 36 | (connect_of_string "tcp://localhost:1234"); 37 | assert_equal 38 | ~printer:(Addr.show Addr.pp_connect) ~msg:"::1_none" 39 | (`Tcp ((`V6 (Ipaddr.V6.localhost), None), 1234)) 40 | (connect_of_string "tcp://::1:1234"); 41 | assert_equal 42 | ~printer:(Addr.show Addr.pp_connect) ~msg:"dns_with_iface" 43 | (`Tcp ((`Dns "localhost", Some (`Iface "lo0")), 1234)) 44 | (connect_of_string "tcp://lo0;localhost:1234"); 45 | assert_equal 46 | ~printer:(Addr.show Addr.pp_connect) ~msg:"ipv6_iface_with_ipv6_addr" 47 | (`Tcp ((`V6 (Ipaddr.V6.of_string_exn "dead::beef"), Some (`V6 Ipaddr.V6.localhost)), 1234)) 48 | (connect_of_string "tcp://::1;dead::beef:1234"); 49 | assert_equal 50 | ~printer:(Addr.show Addr.pp_connect) ~msg:"ipv6_addr_wo_iface" 51 | (`Tcp ((`V6 (Ipaddr.V6.of_string_exn "dead::beef"), None), 1234)) 52 | (connect_of_string "tcp://dead::beef:1234") 53 | 54 | let connect_to_string_test ctx = 55 | let open Addr in 56 | assert_equal 57 | (connect_of_string "inproc://9786/+-auieauie7658%=`!!") 58 | (`Inproc "9786/+-auieauie7658%=`!!"); 59 | assert_equal 60 | (connect_of_string "ipc://9786/+-auieauie7658%=`!!") 61 | (`Ipc "9786/+-auieauie7658%=`!!"); 62 | assert_equal 63 | ~printer:(Addr.show Addr.pp_connect) ~msg:"tcp_with_iface" 64 | (connect_of_string "tcp://eth0;127.0.0.1:1234") 65 | (`Tcp ((`V4 Ipaddr.V4.localhost, Some (`Iface "eth0")), 1234)); 66 | assert_equal 67 | ~printer:(Addr.show Addr.pp_connect) ~msg:"tcp_without_iface" 68 | (connect_of_string "tcp://127.0.0.1:1234") 69 | (`Tcp ((`V4 Ipaddr.V4.localhost, None), 1234)); 70 | assert_equal 71 | ~printer:(Addr.show Addr.pp_connect) ~msg:"dns" 72 | (connect_of_string "tcp://localhost:1234") 73 | (`Tcp ((`Dns "localhost", None), 1234)); 74 | assert_equal 75 | ~printer:(Addr.show Addr.pp_connect) ~msg:"::1_none" 76 | (connect_of_string "tcp://::1:1234") 77 | (`Tcp ((`V6 (Ipaddr.V6.localhost), None), 1234)); 78 | assert_equal 79 | ~printer:(Addr.show Addr.pp_connect) ~msg:"dns_with_iface" 80 | (connect_of_string "tcp://lo0;localhost:1234") 81 | (`Tcp ((`Dns "localhost", Some (`Iface "lo0")), 1234)); 82 | assert_equal 83 | ~printer:(Addr.show Addr.pp_connect) ~msg:"ipv6_iface_with_ipv6_addr" 84 | (connect_of_string "tcp://::1;dead::beef:1234") 85 | (`Tcp ((`V6 (Ipaddr.V6.of_string_exn "dead::beef"), Some (`V6 Ipaddr.V6.localhost)), 1234)); 86 | assert_equal 87 | ~printer:(Addr.show Addr.pp_connect) ~msg:"ipv6_addr_wo_iface" 88 | (connect_of_string "tcp://dead::beef:1234") 89 | (`Tcp ((`V6 (Ipaddr.V6.of_string_exn "dead::beef"), None), 1234)) 90 | 91 | let (>>=?) m msg f = 92 | match m with 93 | | `Ok v -> f v 94 | | `Error (s1, s2) -> 95 | assert_failure (Printf.sprintf "%s: '%s' '%s'" msg s1 s2) 96 | 97 | let socket_test ctx = 98 | let domains = [AF_SP; AF_SP_RAW] in 99 | let protos = [Pair; Pub; Sub; Req; Rep; Push; Pull; Surveyor; Respondent; Bus] in 100 | List.iter (fun d -> 101 | List.iter (fun p -> 102 | let open Nanomsg_utils.Res in 103 | catch 104 | (socket ~domain:d p >>= fun sock -> 105 | domain sock >>= fun sock_domain -> 106 | proto sock >>= fun sock_proto -> 107 | get_linger sock >>= fun sock_linger -> 108 | assert_equal d sock_domain; 109 | assert_equal p sock_proto; 110 | assert_equal (`Ms 1000) sock_linger; 111 | set_linger sock `Inf >>= fun () -> 112 | get_linger sock >>= fun sock_linger -> 113 | assert_equal `Inf sock_linger; 114 | set_send_bufsize sock 256 >>= fun () -> 115 | set_recv_bufsize sock 256 >>= fun () -> 116 | get_send_bufsize sock >>= fun send_bufsize -> 117 | get_recv_bufsize sock >>= fun recv_bufsize -> 118 | assert_equal 256 send_bufsize; 119 | assert_equal 256 recv_bufsize; 120 | close sock) 121 | ~ok:(fun () -> ()) 122 | ~err:(fun (e, m) -> failwith m); 123 | ) protos 124 | ) domains 125 | 126 | let device_test ctx = 127 | (* int s1 = nn_socket (AF_SP_RAW, NN_REQ); *) 128 | (* nn_bind (s1, "tcp://eth0:5555"); *) 129 | (* int s2 = nn_socket (AF_SP_RAW, NN_REP); *) 130 | (* nn_bind (s2, "tcp://eth0:5556"); *) 131 | (* nn_device (s1, s2); *) 132 | let open Nanomsg_utils.Res in 133 | get_exn 134 | (socket ~domain:AF_SP_RAW Req >>= fun s1 -> 135 | bind s1 (`Tcp (`All, 5555)) >>= fun eid1 -> 136 | socket ~domain:AF_SP_RAW Rep >>= fun s2 -> 137 | bind s2 (`Tcp (`All, 5556)) >>= fun eid2 -> 138 | device s1 s2) 139 | 140 | let send_recv_fd_test ctx = 141 | let sock = socket_exn Pair in 142 | ignore @@ recv_fd sock; 143 | ignore @@ send_fd sock; 144 | close_exn sock 145 | 146 | let reqrep_test ctx = 147 | let open Nanomsg_utils.Res in 148 | let receiver = socket_exn Rep in 149 | let sender = socket_exn Req in 150 | let _ = bind_exn receiver @@ `Inproc "*" in 151 | let _ = connect_exn sender @@ `Inproc "*" in 152 | let packet = "testing" in 153 | send_string sender packet >>= fun () -> 154 | recv_string receiver >>= fun received -> 155 | close receiver >>= fun () -> 156 | close sender >|= fun () -> 157 | assert_equal packet received 158 | 159 | let pubsub_local_test ctx = 160 | let open Nanomsg_utils.Res in 161 | let address = `Inproc "t2" in 162 | socket Sub >>= fun sub -> 163 | subscribe sub "" >>= fun () -> 164 | connect sub address >>= fun _ -> 165 | let packet = "foo bar baz" in 166 | socket Pub >>= fun pub -> 167 | bind pub address >>= fun _ -> 168 | send_string pub packet >>= fun _ -> 169 | recv_string sub >>= fun recv_msg -> 170 | close pub >>= fun _ -> 171 | close sub >|= fun _ -> 172 | assert_equal packet recv_msg 173 | 174 | let pubsub_local_2subs_test ctx = 175 | let open Nanomsg_utils.Res in 176 | let addr1 = `Inproc "tt1" in 177 | let addr2 = `Inproc "tt2" in 178 | socket Sub >>= fun sub1 -> 179 | socket Sub >>= fun sub2 -> 180 | let _ = connect sub1 addr1 in 181 | let _ = connect sub2 addr2 in 182 | subscribe sub1 "" >>= fun () -> 183 | subscribe sub2 "" >>= fun () -> 184 | let packet = "one two three" in 185 | socket Pub >>= fun pub -> 186 | let _ = bind pub addr1 in 187 | let _ = bind pub addr2 in 188 | send_string pub packet >>= fun () -> 189 | recv_string sub1 >>= fun x1 -> 190 | recv_string sub2 >>= fun x2 -> 191 | close pub >>= fun () -> 192 | close sub1 >>= fun () -> 193 | close sub2 >|= fun () -> 194 | assert_equal packet x1; 195 | assert_equal packet x2 196 | 197 | let suite = 198 | "Nanomsg">::: 199 | [ 200 | "bind_addr" >:: bind_addr_test; 201 | "connect_of_string" >:: connect_of_string_test; 202 | "connect_to_string" >:: connect_to_string_test; 203 | "socket" >:: socket_test; 204 | "send_recv_fd" >:: send_recv_fd_test; 205 | "reqrep" >:: (fun a -> Nanomsg_utils.Res.get_exn @@ reqrep_test a); 206 | "pubsub_local" >:: (fun a -> Nanomsg_utils.Res.get_exn @@ pubsub_local_test a); 207 | "pubsub_local_2subs" >:: (fun a -> Nanomsg_utils.Res.get_exn @@ pubsub_local_2subs_test a); 208 | ] 209 | 210 | let () = 211 | run_test_tt_main suite 212 | -------------------------------------------------------------------------------- /lib_test/lwt_suite.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open OUnit 3 | 4 | open Nanomsg 5 | module NB = Nanomsg_lwt 6 | 7 | let reqrep_test _ = 8 | let open Nanomsg_utils.Res in 9 | let receiver = socket_exn Rep in 10 | let sender = socket_exn Req in 11 | let _ = bind_exn receiver @@ `Inproc "*" in 12 | let _ = connect_exn sender @@ `Inproc "*" in 13 | let packet = "testing" in 14 | send_string sender packet >>= fun () -> 15 | recv_string receiver >>= fun received -> 16 | close receiver >>= fun () -> 17 | close sender >|= fun () -> 18 | assert_equal packet received 19 | 20 | let ok msg = function 21 | | Result.Error m -> assert_failure msg 22 | | Result.Ok v -> v 23 | 24 | let tcp_pubsub_test _ = 25 | let open Nanomsg_lwt in 26 | let inner () = 27 | let port = 56352 in 28 | wrap_error @@ socket Pub >>= fun pub -> 29 | wrap_error @@ socket Sub >>= fun sub -> 30 | wrap_error @@ set_ipv4_only pub false >>= fun () -> 31 | wrap_error @@ set_ipv4_only sub false >>= fun () -> 32 | let _ = ok "tcp_pubsub: bind" @@ bind pub @@ `Tcp (`All, port) in 33 | let _ = ok "tcp_pubsub: connect" @@ connect sub @@ 34 | `Tcp ((`V6 Ipaddr.V6.localhost, None), port) in 35 | wrap_error @@ Nanomsg.subscribe sub "" >>= fun () -> 36 | let msg = "bleh" in 37 | let recv_msg = Bytes.create @@ String.length msg in 38 | let recv_msg' = Bytes.create @@ String.length msg in 39 | let th = Nanomsg_lwt.send_string pub msg in 40 | Nanomsg_lwt.recv_string sub >>= fun str -> 41 | assert_equal (Lwt.Return ()) (Lwt.state th); 42 | assert_equal msg str; 43 | let th = Nanomsg_lwt.send_string pub msg in 44 | Nanomsg_lwt.recv_buf sub recv_msg >>= fun (_:int) -> 45 | assert_equal (Lwt.Return ()) (Lwt.state th); 46 | assert_equal msg (Bytes.unsafe_to_string recv_msg); 47 | let th = Nanomsg_lwt.send_bytes pub recv_msg in 48 | Nanomsg_lwt.recv_buf sub recv_msg' >|= fun (_:int) -> 49 | assert_equal (Lwt.Return ()) (Lwt.state th); 50 | assert_equal recv_msg recv_msg'; 51 | close_exn pub; 52 | close sub 53 | in Lwt_main.run @@ inner () 54 | 55 | let pipeline_local_test _ = 56 | let open Nanomsg_lwt in 57 | let msgs = [|"foo"; "bar"; "baz"|] in 58 | let receiver addr = 59 | wrap_error @@ socket Pull >>= fun s -> 60 | wrap_error @@ bind s addr >>= fun _ -> 61 | let rec inner n = 62 | if n > 2 63 | then wrap_error @@ close s 64 | else 65 | Nanomsg_lwt.recv_string s >>= fun m -> 66 | (assert_equal msgs.(n) m; inner (succ n)) 67 | in 68 | inner 0 69 | in 70 | let sender addr = 71 | wrap_error @@ socket Push >>= fun s -> 72 | wrap_error @@ connect s addr >>= fun _ -> 73 | Lwt_list.iter_s (Nanomsg_lwt.send_string s) @@ Array.to_list msgs >>= fun () -> 74 | Lwt_unix.yield () >>= fun () -> wrap_error @@ close s 75 | in 76 | Lwt_main.run @@ 77 | Lwt.join 78 | [ sender (`Inproc "rdvpoint") 79 | ; receiver (`Inproc "rdvpoint") ] 80 | 81 | let suite = 82 | "Nanomsg">::: 83 | [ "reqrep" >:: (fun a -> Nanomsg_utils.Res.get_exn @@ reqrep_test a) 84 | ; "tcp_pubsub" >:: (fun a -> Nanomsg_utils.Res.get_exn @@ tcp_pubsub_test a) 85 | ; "pipeline_local" >:: pipeline_local_test ] 86 | 87 | let () = ignore (run_test_tt_main suite) 88 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: c84703b33b787664c9897fbfd1760891) *) 3 | module OASISGettext = struct 4 | (* # 22 "src/oasis/OASISGettext.ml" *) 5 | 6 | 7 | let ns_ str = str 8 | let s_ str = str 9 | let f_ (str: ('a, 'b, 'c, 'd) format4) = str 10 | 11 | 12 | let fn_ fmt1 fmt2 n = 13 | if n = 1 then 14 | fmt1^^"" 15 | else 16 | fmt2^^"" 17 | 18 | 19 | let init = [] 20 | end 21 | 22 | module OASISString = struct 23 | (* # 22 "src/oasis/OASISString.ml" *) 24 | 25 | 26 | (** Various string utilities. 27 | 28 | Mostly inspired by extlib and batteries ExtString and BatString libraries. 29 | 30 | @author Sylvain Le Gall 31 | *) 32 | 33 | 34 | let nsplitf str f = 35 | if str = "" then 36 | [] 37 | else 38 | let buf = Buffer.create 13 in 39 | let lst = ref [] in 40 | let push () = 41 | lst := Buffer.contents buf :: !lst; 42 | Buffer.clear buf 43 | in 44 | let str_len = String.length str in 45 | for i = 0 to str_len - 1 do 46 | if f str.[i] then 47 | push () 48 | else 49 | Buffer.add_char buf str.[i] 50 | done; 51 | push (); 52 | List.rev !lst 53 | 54 | 55 | (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the 56 | separator. 57 | *) 58 | let nsplit str c = 59 | nsplitf str ((=) c) 60 | 61 | 62 | let find ~what ?(offset=0) str = 63 | let what_idx = ref 0 in 64 | let str_idx = ref offset in 65 | while !str_idx < String.length str && 66 | !what_idx < String.length what do 67 | if str.[!str_idx] = what.[!what_idx] then 68 | incr what_idx 69 | else 70 | what_idx := 0; 71 | incr str_idx 72 | done; 73 | if !what_idx <> String.length what then 74 | raise Not_found 75 | else 76 | !str_idx - !what_idx 77 | 78 | 79 | let sub_start str len = 80 | let str_len = String.length str in 81 | if len >= str_len then 82 | "" 83 | else 84 | String.sub str len (str_len - len) 85 | 86 | 87 | let sub_end ?(offset=0) str len = 88 | let str_len = String.length str in 89 | if len >= str_len then 90 | "" 91 | else 92 | String.sub str 0 (str_len - len) 93 | 94 | 95 | let starts_with ~what ?(offset=0) str = 96 | let what_idx = ref 0 in 97 | let str_idx = ref offset in 98 | let ok = ref true in 99 | while !ok && 100 | !str_idx < String.length str && 101 | !what_idx < String.length what do 102 | if str.[!str_idx] = what.[!what_idx] then 103 | incr what_idx 104 | else 105 | ok := false; 106 | incr str_idx 107 | done; 108 | if !what_idx = String.length what then 109 | true 110 | else 111 | false 112 | 113 | 114 | let strip_starts_with ~what str = 115 | if starts_with ~what str then 116 | sub_start str (String.length what) 117 | else 118 | raise Not_found 119 | 120 | 121 | let ends_with ~what ?(offset=0) str = 122 | let what_idx = ref ((String.length what) - 1) in 123 | let str_idx = ref ((String.length str) - 1) in 124 | let ok = ref true in 125 | while !ok && 126 | offset <= !str_idx && 127 | 0 <= !what_idx do 128 | if str.[!str_idx] = what.[!what_idx] then 129 | decr what_idx 130 | else 131 | ok := false; 132 | decr str_idx 133 | done; 134 | if !what_idx = -1 then 135 | true 136 | else 137 | false 138 | 139 | 140 | let strip_ends_with ~what str = 141 | if ends_with ~what str then 142 | sub_end str (String.length what) 143 | else 144 | raise Not_found 145 | 146 | 147 | let replace_chars f s = 148 | let buf = Buffer.create (String.length s) in 149 | String.iter (fun c -> Buffer.add_char buf (f c)) s; 150 | Buffer.contents buf 151 | 152 | let lowercase_ascii = 153 | replace_chars 154 | (fun c -> 155 | if (c >= 'A' && c <= 'Z') then 156 | Char.chr (Char.code c + 32) 157 | else 158 | c) 159 | 160 | let uncapitalize_ascii s = 161 | if s <> "" then 162 | (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 163 | else 164 | s 165 | 166 | let uppercase_ascii = 167 | replace_chars 168 | (fun c -> 169 | if (c >= 'a' && c <= 'z') then 170 | Char.chr (Char.code c - 32) 171 | else 172 | c) 173 | 174 | let capitalize_ascii s = 175 | if s <> "" then 176 | (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 177 | else 178 | s 179 | 180 | end 181 | 182 | module OASISUtils = struct 183 | (* # 22 "src/oasis/OASISUtils.ml" *) 184 | 185 | 186 | open OASISGettext 187 | 188 | 189 | module MapExt = 190 | struct 191 | module type S = 192 | sig 193 | include Map.S 194 | val add_list: 'a t -> (key * 'a) list -> 'a t 195 | val of_list: (key * 'a) list -> 'a t 196 | val to_list: 'a t -> (key * 'a) list 197 | end 198 | 199 | module Make (Ord: Map.OrderedType) = 200 | struct 201 | include Map.Make(Ord) 202 | 203 | let rec add_list t = 204 | function 205 | | (k, v) :: tl -> add_list (add k v t) tl 206 | | [] -> t 207 | 208 | let of_list lst = add_list empty lst 209 | 210 | let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] 211 | end 212 | end 213 | 214 | 215 | module MapString = MapExt.Make(String) 216 | 217 | 218 | module SetExt = 219 | struct 220 | module type S = 221 | sig 222 | include Set.S 223 | val add_list: t -> elt list -> t 224 | val of_list: elt list -> t 225 | val to_list: t -> elt list 226 | end 227 | 228 | module Make (Ord: Set.OrderedType) = 229 | struct 230 | include Set.Make(Ord) 231 | 232 | let rec add_list t = 233 | function 234 | | e :: tl -> add_list (add e t) tl 235 | | [] -> t 236 | 237 | let of_list lst = add_list empty lst 238 | 239 | let to_list = elements 240 | end 241 | end 242 | 243 | 244 | module SetString = SetExt.Make(String) 245 | 246 | 247 | let compare_csl s1 s2 = 248 | String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) 249 | 250 | 251 | module HashStringCsl = 252 | Hashtbl.Make 253 | (struct 254 | type t = string 255 | let equal s1 s2 = (compare_csl s1 s2) = 0 256 | let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) 257 | end) 258 | 259 | module SetStringCsl = 260 | SetExt.Make 261 | (struct 262 | type t = string 263 | let compare = compare_csl 264 | end) 265 | 266 | 267 | let varname_of_string ?(hyphen='_') s = 268 | if String.length s = 0 then 269 | begin 270 | invalid_arg "varname_of_string" 271 | end 272 | else 273 | begin 274 | let buf = 275 | OASISString.replace_chars 276 | (fun c -> 277 | if ('a' <= c && c <= 'z') 278 | || 279 | ('A' <= c && c <= 'Z') 280 | || 281 | ('0' <= c && c <= '9') then 282 | c 283 | else 284 | hyphen) 285 | s; 286 | in 287 | let buf = 288 | (* Start with a _ if digit *) 289 | if '0' <= s.[0] && s.[0] <= '9' then 290 | "_"^buf 291 | else 292 | buf 293 | in 294 | OASISString.lowercase_ascii buf 295 | end 296 | 297 | 298 | let varname_concat ?(hyphen='_') p s = 299 | let what = String.make 1 hyphen in 300 | let p = 301 | try 302 | OASISString.strip_ends_with ~what p 303 | with Not_found -> 304 | p 305 | in 306 | let s = 307 | try 308 | OASISString.strip_starts_with ~what s 309 | with Not_found -> 310 | s 311 | in 312 | p^what^s 313 | 314 | 315 | let is_varname str = 316 | str = varname_of_string str 317 | 318 | 319 | let failwithf fmt = Printf.ksprintf failwith fmt 320 | 321 | 322 | let rec file_location ?pos1 ?pos2 ?lexbuf () = 323 | match pos1, pos2, lexbuf with 324 | | Some p, None, _ | None, Some p, _ -> 325 | file_location ~pos1:p ~pos2:p ?lexbuf () 326 | | Some p1, Some p2, _ -> 327 | let open Lexing in 328 | let fn, lineno = p1.pos_fname, p1.pos_lnum in 329 | let c1 = p1.pos_cnum - p1.pos_bol in 330 | let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in 331 | Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 332 | | _, _, Some lexbuf -> 333 | file_location 334 | ~pos1:(Lexing.lexeme_start_p lexbuf) 335 | ~pos2:(Lexing.lexeme_end_p lexbuf) 336 | () 337 | | None, None, None -> 338 | s_ "" 339 | 340 | 341 | let failwithpf ?pos1 ?pos2 ?lexbuf fmt = 342 | let loc = file_location ?pos1 ?pos2 ?lexbuf () in 343 | Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt 344 | 345 | 346 | end 347 | 348 | module OASISExpr = struct 349 | (* # 22 "src/oasis/OASISExpr.ml" *) 350 | 351 | 352 | open OASISGettext 353 | open OASISUtils 354 | 355 | 356 | type test = string 357 | type flag = string 358 | 359 | 360 | type t = 361 | | EBool of bool 362 | | ENot of t 363 | | EAnd of t * t 364 | | EOr of t * t 365 | | EFlag of flag 366 | | ETest of test * string 367 | 368 | 369 | type 'a choices = (t * 'a) list 370 | 371 | 372 | let eval var_get t = 373 | let rec eval' = 374 | function 375 | | EBool b -> 376 | b 377 | 378 | | ENot e -> 379 | not (eval' e) 380 | 381 | | EAnd (e1, e2) -> 382 | (eval' e1) && (eval' e2) 383 | 384 | | EOr (e1, e2) -> 385 | (eval' e1) || (eval' e2) 386 | 387 | | EFlag nm -> 388 | let v = 389 | var_get nm 390 | in 391 | assert(v = "true" || v = "false"); 392 | (v = "true") 393 | 394 | | ETest (nm, vl) -> 395 | let v = 396 | var_get nm 397 | in 398 | (v = vl) 399 | in 400 | eval' t 401 | 402 | 403 | let choose ?printer ?name var_get lst = 404 | let rec choose_aux = 405 | function 406 | | (cond, vl) :: tl -> 407 | if eval var_get cond then 408 | vl 409 | else 410 | choose_aux tl 411 | | [] -> 412 | let str_lst = 413 | if lst = [] then 414 | s_ "" 415 | else 416 | String.concat 417 | (s_ ", ") 418 | (List.map 419 | (fun (cond, vl) -> 420 | match printer with 421 | | Some p -> p vl 422 | | None -> s_ "") 423 | lst) 424 | in 425 | match name with 426 | | Some nm -> 427 | failwith 428 | (Printf.sprintf 429 | (f_ "No result for the choice list '%s': %s") 430 | nm str_lst) 431 | | None -> 432 | failwith 433 | (Printf.sprintf 434 | (f_ "No result for a choice list: %s") 435 | str_lst) 436 | in 437 | choose_aux (List.rev lst) 438 | 439 | 440 | end 441 | 442 | 443 | # 443 "myocamlbuild.ml" 444 | module BaseEnvLight = struct 445 | (* # 22 "src/base/BaseEnvLight.ml" *) 446 | 447 | 448 | module MapString = Map.Make(String) 449 | 450 | 451 | type t = string MapString.t 452 | 453 | 454 | let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" 455 | 456 | 457 | let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = 458 | let line = ref 1 in 459 | let lexer st = 460 | let st_line = 461 | Stream.from 462 | (fun _ -> 463 | try 464 | match Stream.next st with 465 | | '\n' -> incr line; Some '\n' 466 | | c -> Some c 467 | with Stream.Failure -> None) 468 | in 469 | Genlex.make_lexer ["="] st_line 470 | in 471 | let rec read_file lxr mp = 472 | match Stream.npeek 3 lxr with 473 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 474 | Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; 475 | read_file lxr (MapString.add nm value mp) 476 | | [] -> mp 477 | | _ -> 478 | failwith 479 | (Printf.sprintf "Malformed data file '%s' line %d" filename !line) 480 | in 481 | match stream with 482 | | Some st -> read_file (lexer st) MapString.empty 483 | | None -> 484 | if Sys.file_exists filename then begin 485 | let chn = open_in_bin filename in 486 | let st = Stream.of_channel chn in 487 | try 488 | let mp = read_file (lexer st) MapString.empty in 489 | close_in chn; mp 490 | with e -> 491 | close_in chn; raise e 492 | end else if allow_empty then begin 493 | MapString.empty 494 | end else begin 495 | failwith 496 | (Printf.sprintf 497 | "Unable to load environment, the file '%s' doesn't exist." 498 | filename) 499 | end 500 | 501 | let rec var_expand str env = 502 | let buff = Buffer.create ((String.length str) * 2) in 503 | Buffer.add_substitute 504 | buff 505 | (fun var -> 506 | try 507 | var_expand (MapString.find var env) env 508 | with Not_found -> 509 | failwith 510 | (Printf.sprintf 511 | "No variable %s defined when trying to expand %S." 512 | var 513 | str)) 514 | str; 515 | Buffer.contents buff 516 | 517 | 518 | let var_get name env = var_expand (MapString.find name env) env 519 | let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst 520 | end 521 | 522 | 523 | # 523 "myocamlbuild.ml" 524 | module MyOCamlbuildFindlib = struct 525 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 526 | 527 | 528 | (** OCamlbuild extension, copied from 529 | * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html 530 | * by N. Pouillard and others 531 | * 532 | * Updated on 2016-06-02 533 | * 534 | * Modified by Sylvain Le Gall 535 | *) 536 | open Ocamlbuild_plugin 537 | 538 | 539 | type conf = {no_automatic_syntax: bool} 540 | 541 | 542 | let run_and_read = Ocamlbuild_pack.My_unix.run_and_read 543 | 544 | 545 | let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings 546 | 547 | 548 | let exec_from_conf exec = 549 | let exec = 550 | let env = BaseEnvLight.load ~allow_empty:true () in 551 | try 552 | BaseEnvLight.var_get exec env 553 | with Not_found -> 554 | Printf.eprintf "W: Cannot get variable %s\n" exec; 555 | exec 556 | in 557 | let fix_win32 str = 558 | if Sys.os_type = "Win32" then begin 559 | let buff = Buffer.create (String.length str) in 560 | (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. 561 | *) 562 | String.iter 563 | (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) 564 | str; 565 | Buffer.contents buff 566 | end else begin 567 | str 568 | end 569 | in 570 | fix_win32 exec 571 | 572 | 573 | let split s ch = 574 | let buf = Buffer.create 13 in 575 | let x = ref [] in 576 | let flush () = 577 | x := (Buffer.contents buf) :: !x; 578 | Buffer.clear buf 579 | in 580 | String.iter 581 | (fun c -> 582 | if c = ch then 583 | flush () 584 | else 585 | Buffer.add_char buf c) 586 | s; 587 | flush (); 588 | List.rev !x 589 | 590 | 591 | let split_nl s = split s '\n' 592 | 593 | 594 | let before_space s = 595 | try 596 | String.before s (String.index s ' ') 597 | with Not_found -> s 598 | 599 | (* ocamlfind command *) 600 | let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] 601 | 602 | (* This lists all supported packages. *) 603 | let find_packages () = 604 | List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) 605 | 606 | 607 | (* Mock to list available syntaxes. *) 608 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 609 | 610 | 611 | let well_known_syntax = [ 612 | "camlp4.quotations.o"; 613 | "camlp4.quotations.r"; 614 | "camlp4.exceptiontracer"; 615 | "camlp4.extend"; 616 | "camlp4.foldgenerator"; 617 | "camlp4.listcomprehension"; 618 | "camlp4.locationstripper"; 619 | "camlp4.macro"; 620 | "camlp4.mapgenerator"; 621 | "camlp4.metagenerator"; 622 | "camlp4.profiler"; 623 | "camlp4.tracer" 624 | ] 625 | 626 | 627 | let dispatch conf = 628 | function 629 | | After_options -> 630 | (* By using Before_options one let command line options have an higher 631 | * priority on the contrary using After_options will guarantee to have 632 | * the higher priority override default commands by ocamlfind ones *) 633 | Options.ocamlc := ocamlfind & A"ocamlc"; 634 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 635 | Options.ocamldep := ocamlfind & A"ocamldep"; 636 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 637 | Options.ocamlmktop := ocamlfind & A"ocamlmktop"; 638 | Options.ocamlmklib := ocamlfind & A"ocamlmklib" 639 | 640 | | After_rules -> 641 | 642 | (* Avoid warnings for unused tag *) 643 | flag ["tests"] N; 644 | 645 | (* When one link an OCaml library/binary/package, one should use 646 | * -linkpkg *) 647 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 648 | 649 | (* For each ocamlfind package one inject the -package option when 650 | * compiling, computing dependencies, generating documentation and 651 | * linking. *) 652 | List.iter 653 | begin fun pkg -> 654 | let base_args = [A"-package"; A pkg] in 655 | (* TODO: consider how to really choose camlp4o or camlp4r. *) 656 | let syn_args = [A"-syntax"; A "camlp4o"] in 657 | let (args, pargs) = 658 | (* Heuristic to identify syntax extensions: whether they end in 659 | ".syntax"; some might not. 660 | *) 661 | if not (conf.no_automatic_syntax) && 662 | (Filename.check_suffix pkg "syntax" || 663 | List.mem pkg well_known_syntax) then 664 | (syn_args @ base_args, syn_args) 665 | else 666 | (base_args, []) 667 | in 668 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; 669 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; 670 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; 671 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; 672 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; 673 | 674 | (* TODO: Check if this is allowed for OCaml < 3.12.1 *) 675 | flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; 676 | flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; 677 | flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; 678 | flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; 679 | end 680 | (find_packages ()); 681 | 682 | (* Like -package but for extensions syntax. Morover -syntax is useless 683 | * when linking. *) 684 | List.iter begin fun syntax -> 685 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 686 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 687 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 688 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & 689 | S[A"-syntax"; A syntax]; 690 | end (find_syntaxes ()); 691 | 692 | (* The default "thread" tag is not compatible with ocamlfind. 693 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 694 | * options when using this tag. When using the "-linkpkg" option with 695 | * ocamlfind, this module will then be added twice on the command line. 696 | * 697 | * To solve this, one approach is to add the "-thread" option when using 698 | * the "threads" package using the previous plugin. 699 | *) 700 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 701 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 702 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 703 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); 704 | flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); 705 | flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); 706 | flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); 707 | flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); 708 | flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); 709 | flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); 710 | 711 | | _ -> 712 | () 713 | end 714 | 715 | module MyOCamlbuildBase = struct 716 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 717 | 718 | 719 | (** Base functions for writing myocamlbuild.ml 720 | @author Sylvain Le Gall 721 | *) 722 | 723 | 724 | open Ocamlbuild_plugin 725 | module OC = Ocamlbuild_pack.Ocaml_compiler 726 | 727 | 728 | type dir = string 729 | type file = string 730 | type name = string 731 | type tag = string 732 | 733 | 734 | type t = 735 | { 736 | lib_ocaml: (name * dir list * string list) list; 737 | lib_c: (name * dir * file list) list; 738 | flags: (tag list * (spec OASISExpr.choices)) list; 739 | (* Replace the 'dir: include' from _tags by a precise interdepends in 740 | * directory. 741 | *) 742 | includes: (dir * dir list) list; 743 | } 744 | 745 | 746 | (* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 747 | 748 | 749 | let env_filename = Pathname.basename BaseEnvLight.default_filename 750 | 751 | 752 | let dispatch_combine lst = 753 | fun e -> 754 | List.iter 755 | (fun dispatch -> dispatch e) 756 | lst 757 | 758 | 759 | let tag_libstubs nm = 760 | "use_lib"^nm^"_stubs" 761 | 762 | 763 | let nm_libstubs nm = 764 | nm^"_stubs" 765 | 766 | 767 | let dispatch t e = 768 | let env = BaseEnvLight.load ~allow_empty:true () in 769 | match e with 770 | | Before_options -> 771 | let no_trailing_dot s = 772 | if String.length s >= 1 && s.[0] = '.' then 773 | String.sub s 1 ((String.length s) - 1) 774 | else 775 | s 776 | in 777 | List.iter 778 | (fun (opt, var) -> 779 | try 780 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 781 | with Not_found -> 782 | Printf.eprintf "W: Cannot get variable %s\n" var) 783 | [ 784 | Options.ext_obj, "ext_obj"; 785 | Options.ext_lib, "ext_lib"; 786 | Options.ext_dll, "ext_dll"; 787 | ] 788 | 789 | | After_rules -> 790 | (* Declare OCaml libraries *) 791 | List.iter 792 | (function 793 | | nm, [], intf_modules -> 794 | ocaml_lib nm; 795 | let cmis = 796 | List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") 797 | intf_modules in 798 | dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis 799 | | nm, dir :: tl, intf_modules -> 800 | ocaml_lib ~dir:dir (dir^"/"^nm); 801 | List.iter 802 | (fun dir -> 803 | List.iter 804 | (fun str -> 805 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 806 | ["compile"; "infer_interface"; "doc"]) 807 | tl; 808 | let cmis = 809 | List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") 810 | intf_modules in 811 | dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] 812 | cmis) 813 | t.lib_ocaml; 814 | 815 | (* Declare directories dependencies, replace "include" in _tags. *) 816 | List.iter 817 | (fun (dir, include_dirs) -> 818 | Pathname.define_context dir include_dirs) 819 | t.includes; 820 | 821 | (* Declare C libraries *) 822 | List.iter 823 | (fun (lib, dir, headers) -> 824 | (* Handle C part of library *) 825 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 826 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 827 | A("-l"^(nm_libstubs lib))]); 828 | 829 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 830 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 831 | 832 | if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then 833 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 834 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 835 | 836 | (* When ocaml link something that use the C library, then one 837 | need that file to be up to date. 838 | This holds both for programs and for libraries. 839 | *) 840 | dep ["link"; "ocaml"; tag_libstubs lib] 841 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 842 | 843 | dep ["compile"; "ocaml"; tag_libstubs lib] 844 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 845 | 846 | (* TODO: be more specific about what depends on headers *) 847 | (* Depends on .h files *) 848 | dep ["compile"; "c"] 849 | headers; 850 | 851 | (* Setup search path for lib *) 852 | flag ["link"; "ocaml"; "use_"^lib] 853 | (S[A"-I"; P(dir)]); 854 | ) 855 | t.lib_c; 856 | 857 | (* Add flags *) 858 | List.iter 859 | (fun (tags, cond_specs) -> 860 | let spec = BaseEnvLight.var_choose cond_specs env in 861 | let rec eval_specs = 862 | function 863 | | S lst -> S (List.map eval_specs lst) 864 | | A str -> A (BaseEnvLight.var_expand str env) 865 | | spec -> spec 866 | in 867 | flag tags & (eval_specs spec)) 868 | t.flags 869 | | _ -> 870 | () 871 | 872 | 873 | let dispatch_default conf t = 874 | dispatch_combine 875 | [ 876 | dispatch t; 877 | MyOCamlbuildFindlib.dispatch conf; 878 | ] 879 | 880 | 881 | end 882 | 883 | 884 | # 884 "myocamlbuild.ml" 885 | open Ocamlbuild_plugin;; 886 | let package_default = 887 | { 888 | MyOCamlbuildBase.lib_ocaml = 889 | [ 890 | ("nanomsg", ["lib"], []); 891 | ("nanomsg_async", ["lib"], []); 892 | ("nanomsg_lwt", ["lib"], []) 893 | ]; 894 | lib_c = [("nanomsg", "lib", [])]; 895 | flags = 896 | [ 897 | (["oasis_library_nanomsg_ccopt"; "compile"], 898 | [ 899 | (OASISExpr.EBool true, 900 | S [A "-ccopt"; A "-I"; A "-ccopt"; A "${pkg_ctypes_stubs}"]) 901 | ]); 902 | (["oasis_library_nanomsg_cclib"; "link"], 903 | [(OASISExpr.EBool true, S [A "-cclib"; A "-lnanomsg"])]); 904 | (["oasis_library_nanomsg_cclib"; "ocamlmklib"; "c"], 905 | [(OASISExpr.EBool true, S [A "-lnanomsg"])]) 906 | ]; 907 | includes = [("lib_test", ["lib"])] 908 | } 909 | ;; 910 | 911 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 912 | 913 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 914 | 915 | # 916 "myocamlbuild.ml" 916 | (* OASIS_STOP *) 917 | 918 | open Ocamlbuild_plugin;; 919 | 920 | dispatch 921 | (MyOCamlbuildBase.dispatch_combine [ 922 | begin function 923 | | After_rules -> 924 | rule "cstubs: lib/x_bindings.ml -> x_stubs.c, x_stubs.ml" 925 | ~prods:["lib/%_stubs.c"; "lib/%_generated.ml"] 926 | ~deps: ["lib_gen/%_bindgen.byte"] 927 | (fun env build -> 928 | Cmd (A(env "lib_gen/%_bindgen.byte"))); 929 | copy_rule "cstubs: lib_gen/x_bindings.ml -> lib/x_bindings.ml" 930 | "lib_gen/%_bindings.ml" "lib/%_bindings.ml" 931 | | _ -> () 932 | end; 933 | dispatch_default 934 | ]) 935 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | 3 | name: "nanomsg" 4 | version: "1.1" 5 | 6 | maintainer: "Vincent Bernardoff " 7 | authors: [ 8 | "Vincent Bernardoff " 9 | "Rudi Grinberg " 10 | ] 11 | 12 | homepage: "http://github.com/rgringberg/onanomsg" 13 | bug-reports: "http://github.com/rgrinberg/onanomsg/issues" 14 | dev-repo: "git://github.com/rgrinberg/onanomsg" 15 | license: "WTFPL" 16 | 17 | build: [ 18 | ["oasis" "setup"] 19 | ["./configure" "--%{lwt:enable}%-lwt" "--%{async:enable}%-async"] 20 | [make] 21 | ] 22 | 23 | install: [make "install"] 24 | 25 | remove: ["ocamlfind" "remove" "nanomsg"] 26 | 27 | build-test: [ 28 | ["oasis" "setup"] 29 | ["./configure" "--enable-tests" 30 | "--%{lwt:enable}%-lwt" 31 | "--%{async:enable}%-async"] 32 | [make] 33 | ] 34 | 35 | depends: [ 36 | "conf-nanomsg" 37 | "ocamlfind" {build} 38 | "ocamlbuild" {build} 39 | "oasis" {build} 40 | "ctypes" {>= "0.3"} 41 | "ctypes-foreign" 42 | "result" 43 | "ipaddr" {>= "3.0.0"} 44 | "ppx_deriving" 45 | "bigstring" 46 | "ounit" {test} 47 | ] 48 | 49 | depopts: ["lwt" "async"] 50 | 51 | available: [ocaml-version >= "4.02.0"] 52 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | version = "1.0" 2 | description = "Bindings to nanomsg" 3 | requires = "ctypes.foreign ipaddr ppx_deriving.std containers containers.bigarray" 4 | archive(byte) = "nanomsg.cma" 5 | archive(byte, plugin) = "nanomsg.cma" 6 | archive(native) = "nanomsg.cmxa" 7 | archive(native, plugin) = "nanomsg.cmxs" 8 | exists_if = "nanomsg.cma" 9 | package "lwt" ( 10 | version = "1.0" 11 | description = "Bindings to nanomsg" 12 | requires = "nanomsg lwt.unix" 13 | archive(byte) = "nanomsg_lwt.cma" 14 | archive(byte, plugin) = "nanomsg_lwt.cma" 15 | archive(native) = "nanomsg_lwt.cmxa" 16 | archive(native, plugin) = "nanomsg_lwt.cmxs" 17 | exists_if = "nanomsg_lwt.cma" 18 | ) -------------------------------------------------------------------------------- /pkg/build.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #directory "pkg" 3 | #use "topkg.ml" 4 | 5 | let lwt = Env.bool "lwt" 6 | let ounit = Env.bool "ounit" 7 | 8 | let () = 9 | Pkg.describe "nanomsg" ~builder:`OCamlbuild [ 10 | Pkg.lib "pkg/META"; 11 | Pkg.lib ~exts:Exts.module_library "lib/nanomsg"; 12 | Pkg.lib ~cond:lwt ~exts:Exts.module_library "lib/nanomsg_lwt"; 13 | 14 | Pkg.bin ~cond:ounit ~auto:true "lib_test/suite"; 15 | ] 16 | -------------------------------------------------------------------------------- /pkg/topkg.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the BSD3 license, see license at the end of the file. 4 | %%NAME%% release %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Public api *) 8 | 9 | (** Build environment access *) 10 | module type Env = sig 11 | val bool : string -> bool 12 | (** [bool key] declares [key] as being a boolean key in the environment. 13 | Specifing key=(true|false) on the command line becomes mandatory. *) 14 | 15 | val native : bool 16 | (** [native] is [bool "native"]. *) 17 | 18 | val native_dynlink : bool 19 | (** [native_dylink] is [bool "native-dynlink"] *) 20 | end 21 | 22 | (** Exts defines sets of file extensions. *) 23 | module type Exts = sig 24 | val interface : string list 25 | (** [interface] is [[".mli"; ".cmi"; ".cmti"]] *) 26 | 27 | val interface_opt : string list 28 | (** [interface_opt] is [".cmx" :: interface] *) 29 | 30 | val library : string list 31 | (** [library] is [[".cma"; ".cmxa"; ".cmxs"; ".a"]] *) 32 | 33 | val module_library : string list 34 | (** [module_library] is [(interface_opt @ library)]. *) 35 | end 36 | 37 | (** Package description. *) 38 | module type Pkg = sig 39 | type builder = [ `OCamlbuild | `Other of string * string ] 40 | (** The type for build tools. Either [`OCamlbuild] or an 41 | [`Other (tool, bdir)] tool [tool] that generates its build artefacts 42 | in [bdir]. *) 43 | 44 | type moves 45 | (** The type for install moves. *) 46 | 47 | type field = ?cond:bool -> ?exts:string list -> ?dst:string -> string -> moves 48 | (** The type for field install functions. A call 49 | [field cond exts dst path] generates install moves as follows: 50 | {ul 51 | {- If [cond] is [false] (defaults to [true]), no move is generated.} 52 | {- If [exts] is present, generates a move for each path in 53 | the list [List.map (fun e -> path ^ e) exts].} 54 | {- If [dst] is present this path is used as the move destination 55 | (allows to install in subdirectories). If absent [dst] is 56 | [Filename.basename path].} *) 57 | 58 | val lib : field 59 | val bin : ?auto:bool -> field 60 | (** If [auto] is true (defaults to false) generates 61 | [path ^ ".native"] if {!Env.native} is [true] and 62 | [path ^ ".byte"] if {!Env.native} is [false]. *) 63 | val sbin : ?auto:bool -> field (** See {!bin}. *) 64 | val toplevel : field 65 | val share : field 66 | val share_root : field 67 | val etc : field 68 | val doc : field 69 | val misc : field 70 | val stublibs : field 71 | val man : field 72 | val describe : string -> builder:builder -> moves list -> unit 73 | (** [describe name builder moves] describes a package named [name] with 74 | builder [builder] and install moves [moves]. *) 75 | end 76 | 77 | (* Implementation *) 78 | 79 | module Topkg : sig 80 | val cmd : [`Build | `Explain | `Help ] 81 | val env : (string * bool) list 82 | val err_parse : string -> 'a 83 | val err_mdef : string -> 'a 84 | val err_miss : string -> 'a 85 | val err_file : string -> string -> 'a 86 | val warn_unused : string -> unit 87 | end = struct 88 | 89 | (* Parses the command line. The actual cmd execution occurs in the call 90 | to Pkg.describe. *) 91 | 92 | let err fmt = 93 | let k _ = exit 1 in 94 | Format.kfprintf k Format.err_formatter ("%s: " ^^ fmt ^^ "@.") Sys.argv.(0) 95 | 96 | let err_parse a = err "argument `%s' is not of the form key=(true|false)" a 97 | let err_mdef a = err "bool `%s' is defined more than once" a 98 | let err_miss a = err "argument `%s=(true|false)' is missing" a 99 | let err_file f e = err "%s: %s" f e 100 | let warn_unused k = 101 | Format.eprintf "%s: warning: environment key `%s` unused.@." Sys.argv.(0) k 102 | 103 | let cmd, env = 104 | let rec parse_env acc = function (* not t.r. *) 105 | | arg :: args -> 106 | begin try 107 | (* String.cut ... *) 108 | let len = String.length arg in 109 | let eq = String.index arg '=' in 110 | let bool = bool_of_string (String.sub arg (eq + 1) (len - eq - 1)) in 111 | let key = String.sub arg 0 eq in 112 | if key = "" then raise Exit else 113 | try ignore (List.assoc key acc); err_mdef key with 114 | | Not_found -> parse_env ((key, bool) :: acc) args 115 | with 116 | | Invalid_argument _ | Not_found | Exit -> err_parse arg 117 | end 118 | | [] -> acc 119 | in 120 | match List.tl (Array.to_list Sys.argv) with 121 | | "explain" :: args -> `Explain, parse_env [] args 122 | | ("help" | "-h" | "--help" | "-help") :: args -> `Help, parse_env [] args 123 | | args -> `Build, parse_env [] args 124 | end 125 | 126 | module Env : sig 127 | include Env 128 | val get : unit -> (string * bool) list 129 | end = struct 130 | let env = ref [] 131 | let get () = !env 132 | let add_bool key b = env := (key, b) :: !env 133 | let bool key = 134 | let b = try List.assoc key Topkg.env with 135 | | Not_found -> if Topkg.cmd = `Build then Topkg.err_miss key else true 136 | in 137 | add_bool key b; b 138 | 139 | let native = bool "native" 140 | let native_dynlink = bool "native-dynlink" 141 | end 142 | 143 | module Exts : Exts = struct 144 | let interface = [".mli"; ".cmi"; ".cmti"] 145 | let interface_opt = ".cmx" :: interface 146 | let library = [".cma"; ".cmxa"; ".cmxs"; ".a"] 147 | let module_library = (interface_opt @ library) 148 | end 149 | 150 | module Pkg : Pkg = struct 151 | type builder = [ `OCamlbuild | `Other of string * string ] 152 | type moves = (string * (string * string)) list 153 | type field = ?cond:bool -> ?exts:string list -> ?dst:string -> string -> moves 154 | 155 | let str = Printf.sprintf 156 | let warn_unused () = 157 | let keys = List.map fst Topkg.env in 158 | let keys_used = List.map fst (Env.get ()) in 159 | let unused = List.find_all (fun k -> not (List.mem k keys_used)) keys in 160 | List.iter Topkg.warn_unused unused 161 | 162 | let has_suffix = Filename.check_suffix 163 | let build_strings ?(exec_sep = " ") btool bdir mvs = 164 | let no_build = [ ".cmti"; ".cmt" ] in 165 | let install = Buffer.create 1871 in 166 | let exec = Buffer.create 1871 in 167 | let rec add_mvs current = function 168 | | (field, (src, dst)) :: mvs when field = current -> 169 | if List.exists (has_suffix src) no_build then 170 | Buffer.add_string install (str "\n \"?%s/%s\" {\"%s\"}" bdir src dst) 171 | else begin 172 | Buffer.add_string exec (str "%s%s" exec_sep src); 173 | Buffer.add_string install (str "\n \"%s/%s\" {\"%s\"}" bdir src dst); 174 | end; 175 | add_mvs current mvs 176 | | (((field, _) :: _) as mvs) -> 177 | if current <> "" (* first *) then Buffer.add_string install " ]\n"; 178 | Buffer.add_string install (str "%s: [" field); 179 | add_mvs field mvs 180 | | [] -> () 181 | in 182 | Buffer.add_string exec btool; 183 | add_mvs "" mvs; 184 | Buffer.add_string install " ]\n"; 185 | Buffer.contents install, Buffer.contents exec 186 | 187 | let pr = Format.printf 188 | let pr_explanation btool bdir pkg mvs = 189 | let env = Env.get () in 190 | let install, exec = build_strings ~exec_sep:" \\\n " btool bdir mvs in 191 | pr "@["; 192 | pr "Package name: %s@," pkg; 193 | pr "Build tool: %s@," btool; 194 | pr "Build directory: %s@," bdir; 195 | pr "Environment:@, "; 196 | List.iter (fun (k,v) -> pr "%s=%b@, " k v) (List.sort compare env); 197 | pr "@,Build invocation:@,"; 198 | pr " %s@,@," exec; 199 | pr "Install file:@,"; 200 | pr "%s@," install; 201 | pr "@]"; 202 | () 203 | 204 | let pr_help () = 205 | pr "Usage example:@\n %s" Sys.argv.(0); 206 | List.iter (fun (k,v) -> pr " %s=%b" k v) (List.sort compare (Env.get ())); 207 | pr "@." 208 | 209 | let build btool bdir pkg mvs = 210 | let install, exec = build_strings btool bdir mvs in 211 | let e = Sys.command exec in 212 | if e <> 0 then exit e else 213 | let install_file = pkg ^ ".install" in 214 | try 215 | let oc = open_out install_file in 216 | output_string oc install; flush oc; close_out oc 217 | with Sys_error e -> Topkg.err_file install_file e 218 | 219 | let mvs ?(drop_exts = []) field ?(cond = true) ?(exts = []) ?dst src = 220 | if not cond then [] else 221 | let mv src dst = (field, (src, dst)) in 222 | let expand exts s d = List.map (fun e -> mv (s ^ e) (d ^ e)) exts in 223 | let dst = match dst with None -> Filename.basename src | Some dst -> dst in 224 | let files = if exts = [] then [mv src dst] else expand exts src dst in 225 | let keep (_, (src, _)) = not (List.exists (has_suffix src) drop_exts) in 226 | List.find_all keep files 227 | 228 | let lib = 229 | let drop_exts = 230 | if Env.native && not Env.native_dynlink then [ ".cmxs" ] else 231 | if not Env.native then [ ".a"; ".cmx"; ".cmxa"; ".cmxs" ] else [] 232 | in 233 | mvs ~drop_exts "lib" 234 | 235 | let share = mvs "share" 236 | let share_root = mvs "share_root" 237 | let etc = mvs "etc" 238 | let toplevel = mvs "toplevel" 239 | let doc = mvs "doc" 240 | let misc = mvs "misc" 241 | let stublibs = mvs "stublibs" 242 | let man = mvs "man" 243 | 244 | let bin_drops = if not Env.native then [ ".native" ] else [] 245 | let bin_mvs field ?(auto = false) ?cond ?exts ?dst src = 246 | let src, dst = 247 | if not auto then src, dst else 248 | let dst = match dst with 249 | | None -> Some (Filename.basename src) 250 | | Some _ as dst -> dst 251 | in 252 | let src = if Env.native then src ^ ".native" else src ^ ".byte" in 253 | src, dst 254 | in 255 | mvs ~drop_exts:bin_drops field ?cond ?dst src 256 | 257 | let bin = bin_mvs "bin" 258 | let sbin = bin_mvs "sbin" 259 | 260 | let describe pkg ~builder mvs = 261 | let mvs = List.sort compare (List.flatten mvs) in 262 | let btool, bdir = match builder with 263 | | `OCamlbuild -> "ocamlbuild -use-ocamlfind -classic-display", "_build" 264 | | `Other (btool, bdir) -> btool, bdir 265 | in 266 | match Topkg.cmd with 267 | | `Explain -> pr_explanation btool bdir pkg mvs 268 | | `Help -> pr_help () 269 | | `Build -> warn_unused (); build btool bdir pkg mvs 270 | end 271 | 272 | (*--------------------------------------------------------------------------- 273 | Copyright (c) 2014 Daniel C. Bünzli. 274 | All rights reserved. 275 | 276 | Redistribution and use in source and binary forms, with or without 277 | modification, are permitted provided that the following conditions 278 | are met: 279 | 280 | 1. Redistributions of source code must retain the above copyright 281 | notice, this list of conditions and the following disclaimer. 282 | 283 | 2. Redistributions in binary form must reproduce the above 284 | copyright notice, this list of conditions and the following 285 | disclaimer in the documentation and/or other materials provided 286 | with the distribution. 287 | 288 | 3. Neither the name of Daniel C. Bünzli nor the names of 289 | contributors may be used to endorse or promote products derived 290 | from this software without specific prior written permission. 291 | 292 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 293 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 294 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 295 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 296 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 297 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 298 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 299 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 300 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 301 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 302 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 303 | ---------------------------------------------------------------------------*) 304 | --------------------------------------------------------------------------------