├── .github └── workflows │ └── workflow.yml ├── .gitignore ├── CHANGES.md ├── CODEOWNERS ├── LICENSE.md ├── Makefile ├── README.md ├── dune-project ├── zmq-async.opam ├── zmq-async ├── src │ ├── deferred.ml │ ├── deferred.mli │ ├── dune │ └── zmq_async.ml └── test │ ├── dune │ └── test.ml ├── zmq-deferred ├── src │ ├── deferred.ml │ ├── dune │ ├── socket.ml │ └── socket.mli └── test │ ├── dune │ ├── test.ml │ └── test.mli ├── zmq-eio.opam ├── zmq-eio ├── src │ ├── dune │ ├── socket.ml │ └── socket.mli └── test │ ├── dune │ └── test.ml ├── zmq-lwt.opam ├── zmq-lwt ├── src │ ├── deferred.ml │ ├── deferred.mli │ ├── dune │ └── zmq_lwt.ml └── test │ ├── dune │ └── test.ml ├── zmq.opam └── zmq ├── examples ├── Readme ├── dune ├── echoclient.ml ├── echoserver.ml ├── hwclient.ml ├── hwserver.ml ├── stream_server.ml ├── tasksink.ml ├── taskvent.ml ├── taskwork.ml ├── threaded_loopback.ml ├── wuclient.ml ├── wuproxy.ml ├── wuserver.ml └── zversion.ml ├── src ├── caml_zmq_stubs.c ├── config │ ├── discover.ml │ └── dune ├── context.c ├── context.h ├── dune ├── fail.c ├── fail.h ├── msg.c ├── msg.h ├── poll.c ├── poll.h ├── socket.c ├── socket.h ├── zmq.ml └── zmq.mli └── test ├── curve.ml ├── dune ├── fd_usage.ml ├── test.ml └── zmq_test.ml /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | - pull_request 5 | - push 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - ubuntu-20.04 14 | ocaml-version: 15 | - 5 16 | - 4.14.0 17 | - 4.04.1 18 | include: 19 | - lwt: true 20 | - async: true 21 | - eio: true 22 | ocaml-version: 5 23 | 24 | runs-on: ${{ matrix.os }} 25 | 26 | steps: 27 | - name: Checkout code 28 | uses: actions/checkout@v3 29 | 30 | - name: Use OCaml ${{ matrix.ocaml-version }} 31 | uses: ocaml/setup-ocaml@v2 32 | with: 33 | ocaml-compiler: ${{ matrix.ocaml-version }} 34 | opam-local-packages: zmq.opam 35 | 36 | - name: zmq 37 | run: | 38 | opam install --deps-only --with-doc --with-test zmq 39 | opam exec -- dune build zmq 40 | opam exec -- dune runtest zmq 41 | 42 | - name: zmq-lwt 43 | if: matrix.lwt 44 | run: | 45 | opam pin add zmq-lwt.dev . --no-action 46 | opam install --deps-only --with-doc --with-test zmq-lwt 47 | opam exec -- dune build zmq-lwt 48 | opam exec -- dune runtest zmq-lwt 49 | 50 | - name: zmq-async 51 | if: matrix.async 52 | run: | 53 | opam pin add zmq-async.dev . --no-action 54 | opam install --deps-only --with-doc --with-test zmq-async 55 | opam exec -- dune build zmq-async 56 | opam exec -- dune runtest zmq-async 57 | 58 | - name: zmq-eio 59 | if: matrix.eio 60 | run: | 61 | opam pin add zmq-eio.dev . --no-action 62 | opam install --deps-only --with-doc --with-test zmq-eio 63 | opam exec -- dune build zmq-eio 64 | opam exec -- dune runtest zmq-eio 65 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /_build/ 2 | /_opam/ 3 | .merlin 4 | /*.install 5 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 5.3.0 2 | --- 3 | * Add eio binding in zmq-eio (#126, @andersfugmann) 4 | 5 | 5.2.2 6 | --- 7 | * Fix race in monitor test (#129, @andersfugmann) 8 | 9 | 5.2.1 10 | --- 11 | * Forward compatibility with Lwt 6.0 (#122, @andersfugmann) 12 | * Fix wrong fd type for zmq-async, effecting s390x (#123, @andersfugmann) 13 | 14 | 5.2.0 15 | --- 16 | * Remove dependency on StdInt (#121, @andersfugmann) 17 | 18 | * Silence warnings about `const char*` when writing to the inside of an 19 | allocated string value (#116, @Leonidas-from-XIV) 20 | 21 | 5.1.5 22 | ----- 23 | 24 | * fix bug in `STREAM` sockets (#114, @c-cube) 25 | 26 | 5.1.4 27 | ----- 28 | 29 | * Add poll helpers: `mask_in`, `mask_out`, `mask_in_out` 30 | 31 | * Fix build with OCaml 4.13 (#108, #110, @Leonidas-from-XIV) 32 | 33 | * Fix `Xpub` typo (#107, @roddyyaga) 34 | 35 | 5.1.3 36 | ----- 37 | 38 | * Support building with dune 1.x and 2.x (#104) 39 | 40 | * Bring back support for OCaml 4.03 for `zmq` and `zmq-lwt` (#101, #102) 41 | 42 | 5.1.2 43 | ----- 44 | * Use unix sockets in tests to avoid permission problems when running 45 | in a sandbox environment. 46 | 47 | * Make monitor test more reliable by explictly waiting for each event to 48 | arrive. 49 | 50 | 5.1.1 51 | ----- 52 | 53 | * Fix `EINVAL` when attempting to get the curve encryption keys (#85, #86, #91) 54 | 55 | * Do not depend on `configurator` anymore (#96) 56 | 57 | * Depend on v0.11 versions of Jane Street packages to not fail on `makedev` 58 | issue. This requires us to drop support for OCaml 4.03 (#93) 59 | 60 | 5.1.0 61 | ----- 62 | 63 | * Implement `Msg.gets` (#87, #90) 64 | 65 | * Improve support for OCaml 4.08+ (#83, #89) 66 | 67 | * Properly allocate right size of caml block (#88) 68 | 69 | * Update build config to use new dune syntax 70 | 71 | * Remove configurator in favor of dune.configurator. This removes the build time 72 | dependency on the configurator and base packages. 73 | 74 | 5.0.0 75 | ----- 76 | 77 | * Change build system to use jbuilder instead of oasis. This also adds proper 78 | support for pkg-config installed zmq. 79 | 80 | * Import zmq-async and zmq-lwt. The old bindings async-zmq and lwt-zmq are now 81 | deprecated. 82 | 83 | * Refactor zmq-async and zmq-lwt to be supported out of a single code base. This 84 | regularizes the interface, and dramatically improves and stability. 85 | 86 | * Add support for and reading & writing bigarrays. This interfaces allows the 87 | user to reduce needless copying of packets sent by the bindings. 88 | 89 | * Rename module ZMQ to Zmq. 90 | 91 | 4.0-8 92 | ----- 93 | 94 | * Add threading example by Stavros Polymenis 95 | 96 | * Minor addition to API documentation 97 | 98 | * Remove OCaml version requirement in opam package (strictly not part of this 99 | release, but still) 100 | 101 | 102 | 4.0-7 103 | ----- 104 | 105 | * Fixes compilation errors when compiling with 4.03 (and 4.04) 106 | 107 | * Fixes a generic problem with deallocating resources though finalisers. As a 108 | result no resources are automatically released though finalisers. However a 109 | warning will be printed to stdout if resources are leaked 110 | 111 | * Include oasis autogenerated files, removing the dependency on oasis when 112 | installing 113 | 114 | 115 | 4.0-5 116 | ----- 117 | 118 | * The build system now also looks for ZMQ headers and libraries in `/usr/local` 119 | 120 | 4.0-4 121 | ----- 122 | 123 | * Compatibility with ZeroMQ 4.1 124 | 125 | 126 | 4.0-3 127 | ----- 128 | 129 | * Fixed error when GC collecting contexts freed by `ZMQ.Context.terminate` 130 | 131 | * Fixed overflow bug in `get_bytes_option` 132 | 133 | 134 | 3.2-2 135 | ----- 136 | 137 | * Remove `get_identity`/`set_identity` socket-type restrictions 138 | -------------------------------------------------------------------------------- /CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @issuu/backend 2 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | License (ocaml-zmq) 2 | =================== 3 | 4 | "MIT License" 5 | 6 | Copyright (C) 2011 by Pedro Borges and contributors 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software and associated documentation files (the "Software"), to deal 10 | in the Software without restriction, including without limitation the rights 11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the Software is 13 | furnished to do so, subject to the following conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in 16 | all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build 2 | build: 3 | dune build @install @examples 4 | 5 | .PHONY: examples 6 | examples: 7 | dune build @examples 8 | 9 | # requires odoc 10 | .PHONY: doc 11 | doc: 12 | dune build @doc 13 | 14 | .PHONY: test 15 | test: 16 | dune runtest --force 17 | 18 | .PHONY: repl 19 | repl: 20 | dune utop zmq/src 21 | 22 | .PHONY: repl-lwt 23 | repl-lwt: 24 | dune utop zmq-lwt/src 25 | 26 | .PHONY: repl-async 27 | repl-async: 28 | dune utop zmq-async/src 29 | 30 | .PHONY: all 31 | all: 32 | dune build @install @examples 33 | 34 | .PHONY: install 35 | install: 36 | dune install 37 | 38 | .PHONY: uninstall 39 | uninstall: 40 | dune uninstall 41 | 42 | .PHONY: clean 43 | clean: 44 | dune clean 45 | 46 | # requires dune-release 47 | .PHONY: tag 48 | tag: 49 | dune-release tag 50 | 51 | .PHONY: distrib 52 | distrib: 53 | dune-release distrib 54 | 55 | .PHONY: publish 56 | publish: 57 | dune-release publish 58 | 59 | .PHONY: opam-pkg 60 | opam-pkg: 61 | dune-release opam pkg 62 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OCaml bindings for ZMQ 4.x 2 | ========================== 3 | 4 | [![Build Status](https://github.com/issuu/ocaml-zmq/actions/workflows/workflow.yml/badge.svg)](https://github.com/issuu/ocaml-zmq/actions/workflows/workflow.yml?query=branch%3Amaster) 5 | 6 | Dependencies 7 | ------------ 8 | 9 | * [OPAM](http://opam.ocaml.org/) 10 | * OCaml >= 4.03.0 11 | * OCaml >= 4.04.1, Async >= v0.11.0 for zmq-async 12 | * Ocaml >= 5.0.0 for zmq-eio 13 | * Lwt >= 2.6.0 for zmq-lwt 14 | * libzmq (c lib) >= 4.x 15 | 16 | Install 17 | ------- 18 | 19 | ```sh 20 | opam install zmq 21 | ``` 22 | 23 | Uninstall 24 | --------- 25 | 26 | ```sh 27 | opam remove zmq 28 | ``` 29 | 30 | Documentation 31 | ------------- 32 | API documentation can be found [here](https://issuu.github.io/ocaml-zmq) 33 | 34 | Development 35 | ----------- 36 | 37 | With OPAM you can create a local switch which will install all dependencies automatically. 38 | 39 | ```sh 40 | opam switch create ./ 5.1.1 41 | make 42 | ``` 43 | 44 | License 45 | ------- 46 | 47 | See `LICENSE.md`. 48 | 49 | Thanks 50 | ------ 51 | 52 | To the guys from the #ocaml channel, gildor, thelema, kaustuv and many others, 53 | wagerlabs, little-arhat and the ocaml-uint authors. 54 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name zmq) 3 | 4 | (generate_opam_files true) 5 | 6 | (source (github issuu/ocaml-zmq)) 7 | (license MIT) 8 | (maintainers "Anders Fugmann ") 9 | 10 | (package 11 | (name zmq) 12 | (authors "Anders Fugmann" "Pedro Borges" "Peter Zotov") 13 | (synopsis "OCaml bindings for ZeroMQ 4.x") 14 | (description "This library contains basic bindings for ZMQ. 15 | Lwt aware bindings to zmq are availble though package zmq-lwt 16 | Async aware bindings to zmq are available though package zmq-async") 17 | (depends 18 | (ocaml (>= 4.03.0)) 19 | conf-zmq 20 | (ounit2 :with-test) 21 | dune-configurator) 22 | (conflicts 23 | ocaml-zmq)) 24 | 25 | (package 26 | (name zmq-async) 27 | (authors "Rudi Grinberg") 28 | (synopsis "Async-aware bindings to ZMQ") 29 | (depends 30 | (ocaml (>= 4.04.1)) 31 | (zmq (= :version)) 32 | (async_unix (>= v0.11.0)) 33 | (async_kernel (>= v0.11.0)) 34 | (base (>= v0.11.0)) 35 | (ounit2 :with-test))) 36 | 37 | (package 38 | (name zmq-lwt) 39 | (authors "Anders Fugmann ") 40 | (synopsis "Lwt-aware bindings to ZMQ") 41 | (depends 42 | (ocaml (>= 4.03.0)) 43 | (zmq (= :version)) 44 | (lwt (>= 2.6.0)) 45 | (ounit2 :with-test))) 46 | 47 | (package 48 | (name zmq-eio) 49 | (authors "Anders Fugmann") 50 | (synopsis "Eio aware bindings to ZMQ") 51 | (depends 52 | (ocaml (>= 4.04.1)) 53 | (zmq (= :version)) 54 | (eio (>= 0.10)) 55 | (eio_main (>= 0.10)) 56 | (base (>= v0.11.0)) 57 | (ounit2 :with-test))) 58 | -------------------------------------------------------------------------------- /zmq-async.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Async-aware bindings to ZMQ" 4 | maintainer: ["Anders Fugmann "] 5 | authors: ["Rudi Grinberg"] 6 | license: "MIT" 7 | homepage: "https://github.com/issuu/ocaml-zmq" 8 | bug-reports: "https://github.com/issuu/ocaml-zmq/issues" 9 | depends: [ 10 | "dune" {>= "2.7"} 11 | "ocaml" {>= "4.04.1"} 12 | "zmq" {= version} 13 | "async_unix" {>= "v0.11.0"} 14 | "async_kernel" {>= "v0.11.0"} 15 | "base" {>= "v0.11.0"} 16 | "ounit2" {with-test} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/issuu/ocaml-zmq.git" 34 | -------------------------------------------------------------------------------- /zmq-async/src/deferred.ml: -------------------------------------------------------------------------------- 1 | open Async_kernel 2 | open Async_unix 3 | 4 | type 'a t = 'a Deferred.t 5 | module Deferred = struct 6 | type 'a t = 'a Deferred.t 7 | let return a = Deferred.return a 8 | let catch f = try_with ~extract_exn:true f 9 | let don't_wait_for f = don't_wait_for (f ()) 10 | let sleepf secs = Async_kernel.after (Core.Time_ns.Span.of_sec secs) 11 | let fail exn = raise exn 12 | 13 | module Infix = struct 14 | let (>>=) = Deferred.(>>=) 15 | let () a b = Deferred.any [ a; b ] 16 | end 17 | end 18 | 19 | module Condition = struct 20 | type 'a t = 'a Condition.t 21 | let create () = Condition.create () 22 | let wait t = Condition.wait t 23 | let signal t v = Condition.signal t v 24 | end 25 | 26 | module Mailbox = struct 27 | type 'a t = 'a Async_kernel.Ivar.t 28 | let create () = Async_kernel.Ivar.create () 29 | let send t v = Async_kernel.Ivar.fill t v 30 | let recv t = Async_kernel.Ivar.read t 31 | end 32 | 33 | 34 | module Fd = struct 35 | type 'a t' = 'a t 36 | type t = Fd.t 37 | let create fd = 38 | (* The kind here seems not to matter much, but we should make sure 39 | that the fd is not set into non-blocking mode, as this breaks 40 | on s390x. 41 | The 'File' kind avoids fd being set into non-blocking mode. 42 | 'Fd.create' also allows setting 'avoid_setting_nonblock', but 43 | this option name is not stable across supported versions of 44 | async_unix. *) 45 | Fd.create Fd.Kind.File fd (Base.Info.of_string "") 46 | 47 | let wait_readable: t -> unit t' = fun t -> 48 | Fd.ready_to t `Read >>= function 49 | | `Bad_fd -> failwith "Bad filedescriptor" 50 | | `Closed -> failwith "Filedescr closed unexpectedly" 51 | | `Ready -> return () 52 | 53 | let release t = Fd.close ~file_descriptor_handling:Fd.Do_not_close_file_descriptor t 54 | end 55 | -------------------------------------------------------------------------------- /zmq-async/src/deferred.mli: -------------------------------------------------------------------------------- 1 | include Zmq_deferred.Deferred.T with type 'a t = 'a Async_kernel.Deferred.t 2 | -------------------------------------------------------------------------------- /zmq-async/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zmq_async) 3 | (public_name zmq-async) 4 | (libraries zmq.deferred async_unix async_kernel base)) 5 | -------------------------------------------------------------------------------- /zmq-async/src/zmq_async.ml: -------------------------------------------------------------------------------- 1 | module Socket = Zmq_deferred.Socket.Make(Deferred) 2 | -------------------------------------------------------------------------------- /zmq-async/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries zmq_deferred_test zmq-async)) 4 | 5 | (rule 6 | (alias runtest) 7 | (deps 8 | (:test test.exe)) 9 | (action 10 | (run %{test})) 11 | (package zmq-async)) 12 | -------------------------------------------------------------------------------- /zmq-async/test/test.ml: -------------------------------------------------------------------------------- 1 | module Test = Zmq_deferred_test.Test.Make(Zmq_async__Deferred) 2 | 3 | let () = Test.run Async_unix.Thread_safe.block_on_async_exn 4 | -------------------------------------------------------------------------------- /zmq-deferred/src/deferred.ml: -------------------------------------------------------------------------------- 1 | module type T = sig 2 | type 'a t 3 | module Deferred : sig 4 | type nonrec 'a t = 'a t 5 | val return: 'a -> 'a t 6 | val catch: (unit -> 'a t) -> ('a, exn) result t 7 | val don't_wait_for: (unit -> unit t) -> unit 8 | val sleepf: float -> unit t 9 | val fail: exn -> 'a t 10 | module Infix : sig 11 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 12 | (* Determined, whenever either of the deferred becomes determined *) 13 | val (): 'a t -> 'a t -> 'a t 14 | end 15 | end 16 | module Condition : sig 17 | type 'a t 18 | val create: unit -> 'a t 19 | val wait: 'a t -> 'a Deferred.t 20 | val signal: 'a t -> 'a -> unit 21 | end 22 | 23 | module Mailbox : sig 24 | type 'a t 25 | val create: unit -> 'a t 26 | val send: 'a t -> 'a -> unit 27 | val recv: 'a t -> 'a Deferred.t 28 | end 29 | 30 | module Fd : sig 31 | type t 32 | (* Wrap the given unix file_deser *) 33 | val create: Unix.file_descr -> t 34 | 35 | (** Wait for the fd to become readable. 36 | It is important that all waiters on the socket are woken up, 37 | and not just one, as the fd is used as a broadcast mechanism. 38 | 39 | The Fd must _NOT_ be closed, as its owned by Zmq. 40 | 41 | *) 42 | val wait_readable: t -> unit Deferred.t 43 | val release: t -> unit Deferred.t 44 | end 45 | end 46 | -------------------------------------------------------------------------------- /zmq-deferred/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zmq_deferred) 3 | (public_name zmq.deferred) 4 | (libraries zmq)) 5 | -------------------------------------------------------------------------------- /zmq-deferred/src/socket.ml: -------------------------------------------------------------------------------- 1 | module type Socket = sig 2 | type 'a deferred 3 | 4 | (** An concurrent zeromq socket *) 5 | type 'a t 6 | 7 | type 'a of_socket_args 8 | 9 | (** [of_socket s] wraps the zeromq socket [s]*) 10 | val of_socket : ('a Zmq.Socket.t -> 'a t) of_socket_args 11 | 12 | (** [to_socket s] extracts the raw zeromq socket from [s] *) 13 | val to_socket : 'a t -> 'a Zmq.Socket.t 14 | 15 | (** [recv socket] waits for a message on [socket] without blocking 16 | other concurrent threads *) 17 | val recv : 'a t -> string deferred 18 | 19 | (** [send socket] sends a message on [socket] without blocking other 20 | concurrent threads *) 21 | val send : 'a t -> string -> unit deferred 22 | 23 | (** [recv_all socket] waits for a multi-part message on [socket] without 24 | blocking other concurrent threads *) 25 | val recv_all : 'a t -> string list deferred 26 | 27 | (** [send_all socket m] sends all parts of the multi-part message [m] on 28 | [socket] without blocking other concurrent threads *) 29 | val send_all : 'a t -> string list -> unit deferred 30 | 31 | (** [recv_msg socket] waits for a message on [socket] without blocking 32 | other concurrent threads *) 33 | val recv_msg : 'a t -> Zmq.Msg.t deferred 34 | 35 | (** [send_msg socket] sends a message on [socket] without blocking other 36 | concurrent threads *) 37 | val send_msg : 'a t -> Zmq.Msg.t -> unit deferred 38 | 39 | (** [recv_msg_all socket] waits for a multi-part message on [socket] without 40 | blocking other concurrent threads *) 41 | val recv_msg_all : 'a t -> Zmq.Msg.t list deferred 42 | 43 | (** [send_msg_all socket m] sends all parts of the multi-part message [m] on 44 | [socket] without blocking other concurrent threads *) 45 | val send_msg_all : 'a t -> Zmq.Msg.t list -> unit deferred 46 | 47 | val close : 'a t -> unit deferred 48 | 49 | 50 | module Router : sig 51 | 52 | (** Identity of a socket connected to the router. *) 53 | type id_t 54 | 55 | (** [id_of_string s] coerces [s] into an {!id_t}. *) 56 | val id_of_string : string -> id_t 57 | 58 | (** [recv socket] waits for a message on [socket] without blocking other Lwt 59 | threads. *) 60 | val recv : [ `Router ] t -> (id_t * string list) deferred 61 | 62 | (** [send socket id message] sends [message] on [socket] to [id] without 63 | blocking other Lwt threads. *) 64 | val send : [ `Router ] t -> id_t -> string list -> unit deferred 65 | end 66 | 67 | module Monitor : sig 68 | (** [recv socket] waits for a monitoring event on [socket] without blocking other concurrent threads. *) 69 | val recv : [ `Monitor ] t -> Zmq.Monitor.event deferred 70 | end 71 | 72 | end 73 | 74 | module Make(T: Deferred.T) = struct 75 | open T 76 | open Deferred.Infix 77 | type 'a deferred = 'a T.t 78 | type 'a of_socket_args = 'a 79 | exception Retry 80 | type 'a t = 81 | { socket : 'a Zmq.Socket.t; 82 | fd : Fd.t; 83 | senders : (unit -> unit) Queue.t; 84 | receivers : (unit -> unit) Queue.t; 85 | condition : unit Condition.t; 86 | fd_condition : unit Condition.t; 87 | mutable closing : bool; 88 | } 89 | 90 | (** Small process that will notify of the fd changes *) 91 | let rec fd_monitor t = 92 | Condition.wait t.fd_condition >>= fun () -> 93 | match t.closing with 94 | | true -> Deferred.return () 95 | | false -> begin 96 | Deferred.catch (fun () -> Fd.wait_readable t.fd) >>= fun _ -> 97 | Condition.signal t.condition (); 98 | match t.closing with 99 | | true -> Deferred.return () 100 | | false -> fd_monitor t 101 | end 102 | 103 | (** The event loop repeats acting on events as long as there are 104 | sends or receives to be processed. 105 | According to the zmq specification, send and receive may update the event, 106 | and the fd can only be trusted after reading the status of the socket. 107 | *) 108 | let rec event_loop t = 109 | match t.closing with 110 | | true -> Deferred.return () 111 | | false -> begin 112 | let open Zmq.Socket in 113 | let process queue = 114 | let f = Queue.peek queue in 115 | try 116 | f (); 117 | (* Success, pop the sender *) 118 | (Queue.pop queue : unit -> unit) |> ignore 119 | with 120 | | Retry -> (* If f raised EAGAIN, dont pop the message *) () 121 | in 122 | match events t.socket, Queue.is_empty t.senders, Queue.is_empty t.receivers with 123 | | _, true, true -> 124 | Condition.wait t.condition >>= fun () -> 125 | event_loop t 126 | | Poll_error, _, _ -> failwith "Cannot poll socket" 127 | (* Prioritize send's to keep network busy *) 128 | | Poll_in_out, false, _ 129 | | Poll_out, false, _ -> 130 | process t.senders; 131 | event_loop t 132 | | Poll_in_out, _, false 133 | | Poll_in, _, false -> 134 | process t.receivers; 135 | event_loop t 136 | | Poll_in, _, true 137 | | Poll_out, true, _ 138 | | No_event, _, _ -> 139 | Condition.signal t.fd_condition (); 140 | Condition.wait t.condition >>= fun () -> 141 | event_loop t 142 | | exception Unix.Unix_error(Unix.ENOTSOCK, "zmq_getsockopt", "") -> 143 | Deferred.return () 144 | end 145 | 146 | let of_socket: ('a Zmq.Socket.t -> 'a t) of_socket_args = fun socket -> 147 | let fd = Fd.create (Zmq.Socket.get_fd socket) in 148 | let t = 149 | { socket; fd; 150 | senders = Queue.create (); 151 | receivers = Queue.create (); 152 | condition = Condition.create (); 153 | fd_condition = Condition.create (); 154 | closing = false; 155 | } 156 | in 157 | Deferred.don't_wait_for (fun () -> event_loop t); 158 | Deferred.don't_wait_for (fun () -> fd_monitor t); 159 | t 160 | 161 | type op = Send | Receive 162 | let post: _ t -> op -> (_ Zmq.Socket.t -> 'a) -> 'a Deferred.t = fun t op f -> 163 | let f' mailbox () = 164 | let res = match f t.socket with 165 | | v -> Ok v 166 | | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> 167 | (* Signal try again *) 168 | raise Retry 169 | | exception exn -> Error exn 170 | in 171 | Mailbox.send mailbox res 172 | in 173 | let queue = match op with 174 | | Send -> t.senders 175 | | Receive -> t.receivers 176 | in 177 | let mailbox = Mailbox.create () in 178 | let should_signal = Queue.is_empty queue in 179 | Queue.push (f' mailbox) queue; 180 | 181 | (* Wakeup the thread if the queue was empty *) 182 | begin 183 | match should_signal with 184 | | true -> Condition.signal t.condition () 185 | | false -> () 186 | end; 187 | 188 | Mailbox.recv mailbox >>= function 189 | | Ok v -> Deferred.return v 190 | | Error exn -> Deferred.fail exn 191 | 192 | let to_socket t = t.socket 193 | 194 | let recv s = post s Receive (fun s -> Zmq.Socket.recv ~block:false s) 195 | let send s m = post s Send (fun s -> Zmq.Socket.send ~block:false s m) 196 | 197 | let recv_msg s = post s Receive (fun s -> Zmq.Socket.recv_msg ~block:false s) 198 | let send_msg s m = 199 | post s Send (fun s -> Zmq.Socket.send_msg ~block:false s m) 200 | 201 | (** Recevie all message blocks. *) 202 | 203 | let recv_all s = 204 | (* The documentaton says that either all message parts are 205 | transmitted, or none. So once a message becomes available, all 206 | parts can be read wothout blocking. 207 | 208 | Also receiving a multipart message must not be interleaved with 209 | another receving thread on the same socket. 210 | 211 | We could have a read-mutex and a write mutex in order to limit 212 | potential starvation of other threads while reading large 213 | multipart messages. 214 | 215 | *) 216 | post s Receive (fun s -> Zmq.Socket.recv_all ~block:false s) 217 | 218 | let send_all s parts = 219 | (* See the comment in recv_all. *) 220 | post s Send (fun s -> Zmq.Socket.send_all ~block:false s parts) 221 | 222 | let recv_msg_all s = 223 | post s Receive (fun s -> Zmq.Socket.recv_msg_all ~block:false s) 224 | let send_msg_all s parts = 225 | post s Send (fun s -> Zmq.Socket.send_msg_all ~block:false s parts) 226 | 227 | let close t = 228 | t.closing <- true; 229 | Deferred.catch (fun () -> Fd.release t.fd) >>= fun _ -> 230 | Condition.signal t.fd_condition (); 231 | Condition.signal t.condition (); 232 | Zmq.Socket.close t.socket; 233 | Deferred.return () 234 | 235 | module Router = struct 236 | type id_t = string 237 | 238 | let id_of_string t = t 239 | 240 | let recv s = 241 | recv_all s >>= function 242 | | id :: message -> Deferred.return (id, message) 243 | | _ -> assert false 244 | 245 | let send s id message = 246 | send_all s (id :: message) 247 | end 248 | 249 | module Monitor = struct 250 | let recv s = post s Receive (fun s -> Zmq.Monitor.recv ~block:false s) 251 | end 252 | 253 | end 254 | -------------------------------------------------------------------------------- /zmq-deferred/src/socket.mli: -------------------------------------------------------------------------------- 1 | (** The functor allows abstraction of the concurrency monad *) 2 | 3 | module type Socket = sig 4 | type 'a deferred 5 | 6 | (** An concurrent zeromq socket *) 7 | type 'a t 8 | 9 | type 'a of_socket_args 10 | 11 | (** [of_socket s] wraps the zeromq socket [s]*) 12 | val of_socket : ('a Zmq.Socket.t -> 'a t) of_socket_args 13 | 14 | (** [to_socket s] extracts the raw zeromq socket from [s] *) 15 | val to_socket : 'a t -> 'a Zmq.Socket.t 16 | 17 | (** [recv socket] waits for a message on [socket] without blocking 18 | other concurrent threads *) 19 | val recv : 'a t -> string deferred 20 | 21 | (** [send socket] sends a message on [socket] without blocking other 22 | concurrent threads *) 23 | val send : 'a t -> string -> unit deferred 24 | 25 | (** [recv_all socket] waits for a multi-part message on [socket] without 26 | blocking other concurrent threads *) 27 | val recv_all : 'a t -> string list deferred 28 | 29 | (** [send_all socket m] sends all parts of the multi-part message [m] on 30 | [socket] without blocking other concurrent threads *) 31 | val send_all : 'a t -> string list -> unit deferred 32 | 33 | (** [recv_msg socket] waits for a message on [socket] without blocking 34 | other concurrent threads *) 35 | val recv_msg : 'a t -> Zmq.Msg.t deferred 36 | 37 | (** [send_msg socket] sends a message on [socket] without blocking other 38 | concurrent threads *) 39 | val send_msg : 'a t -> Zmq.Msg.t -> unit deferred 40 | 41 | (** [recv_msg_all socket] waits for a multi-part message on [socket] without 42 | blocking other concurrent threads *) 43 | val recv_msg_all : 'a t -> Zmq.Msg.t list deferred 44 | 45 | (** [send_msg_all socket m] sends all parts of the multi-part message [m] on 46 | [socket] without blocking other concurrent threads *) 47 | val send_msg_all : 'a t -> Zmq.Msg.t list -> unit deferred 48 | 49 | val close : 'a t -> unit deferred 50 | 51 | 52 | module Router : sig 53 | 54 | (** Identity of a socket connected to the router. *) 55 | type id_t 56 | 57 | (** [id_of_string s] coerces [s] into an {!id_t}. *) 58 | val id_of_string : string -> id_t 59 | 60 | (** [recv socket] waits for a message on [socket] without blocking other Lwt 61 | threads. *) 62 | val recv : [ `Router ] t -> (id_t * string list) deferred 63 | 64 | (** [send socket id message] sends [message] on [socket] to [id] without 65 | blocking other Lwt threads. *) 66 | val send : [ `Router ] t -> id_t -> string list -> unit deferred 67 | end 68 | 69 | module Monitor : sig 70 | (** [recv socket] waits for a monitoring event on [socket] without blocking other concurrent threads. *) 71 | val recv : [ `Monitor ] t -> Zmq.Monitor.event deferred 72 | end 73 | 74 | end 75 | 76 | module Make : functor (T : Deferred.T) -> Socket with type 'a deferred = 'a T.t and type 'a of_socket_args = 'a 77 | -------------------------------------------------------------------------------- /zmq-deferred/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zmq_deferred_test) 3 | (libraries zmq.deferred ounit2)) 4 | -------------------------------------------------------------------------------- /zmq-deferred/test/test.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | let count = 1000 3 | 4 | let list_init cnt f = 5 | let rec loop = function 6 | | n when n = cnt -> [] 7 | | n -> f n :: loop (n + 1) 8 | in 9 | loop 0 |> List.rev 10 | 11 | module Make(T: Zmq_deferred.Deferred.T) = struct 12 | open T 13 | open Deferred.Infix 14 | 15 | module Socket = Zmq_deferred.Socket.Make(T) 16 | 17 | let all_ok l = List.fold_left (fun acc a -> acc >>= fun () -> a) (T.Deferred.return ()) l 18 | let setup () = 19 | let make ctx tpe = 20 | let s = Zmq.Socket.create ctx tpe in 21 | Zmq.Socket.set_receive_high_water_mark s 1; 22 | Zmq.Socket.set_send_high_water_mark s 2; 23 | s 24 | in 25 | let ctx = Zmq.Context.create () in 26 | let s1 = make ctx Zmq.Socket.pair in 27 | let s2 = make ctx Zmq.Socket.pair in 28 | let endpoint = "inproc://test" in 29 | Zmq.Socket.bind s1 endpoint; 30 | Zmq.Socket.connect s2 endpoint; 31 | T.Deferred.sleepf 0.0001 >>= fun () -> 32 | T.Deferred.return (ctx, Socket.of_socket s1, Socket.of_socket s2) 33 | 34 | let teardown (ctx, s1, s2) = 35 | Socket.close s2 >>= fun () -> 36 | Socket.close s1 >>= fun () -> 37 | Zmq.Context.terminate ctx; 38 | T.Deferred.return () 39 | 40 | let rec send ?(delay = 0.0) s = function 41 | | 0 -> T.Deferred.return () 42 | | n -> 43 | Socket.send s "test" >>= fun () -> 44 | T.Deferred.sleepf delay >>= fun () -> 45 | send s ~delay (n - 1) 46 | 47 | let rec recv ?(delay = 0.0) s = function 48 | | 0 -> T.Deferred.return () 49 | | n -> 50 | Socket.recv s >>= fun _ -> 51 | T.Deferred.sleepf delay >>= fun () -> 52 | recv s ~delay (n - 1) 53 | 54 | (* Tests *) 55 | let test_send_receive (_, s1, s2) = 56 | all_ok [ 57 | send s2 count; recv s1 count 58 | ] 59 | 60 | let test_msend_mreceive (_, s1, s2) = 61 | all_ok [ 62 | send s2 count; send s2 count; send s2 count; send s2 count; 63 | recv s1 count; recv s1 count; recv s1 count; recv s1 count; 64 | ] 65 | 66 | let test_mix (_, s1, s2) = 67 | all_ok [ 68 | send s2 count; recv s1 count; 69 | send s1 count; recv s2 count; 70 | send s2 count; recv s1 count; 71 | send s1 count; recv s2 count; 72 | send s2 count; recv s1 count; 73 | ] 74 | 75 | let test_slow_send (_, s1, s2) = 76 | all_ok [ 77 | recv ~delay:0.0001 s2 count; 78 | send s1 (count / 5); 79 | send s1 (count / 5); 80 | send s1 (count / 5); 81 | send s1 (count / 5); 82 | send s1 (count / 5); 83 | ] 84 | 85 | let test_slow_receive (_, s1, s2) = 86 | all_ok [ 87 | send ~delay:0.0001 s2 count; 88 | recv s1 (count / 5); 89 | recv s1 (count / 5); 90 | recv s1 (count / 5); 91 | recv s1 (count / 5); 92 | recv s1 (count / 5); 93 | ] 94 | 95 | let test_multi (_, s1, s2) = 96 | all_ok ( 97 | ((send ~delay:0.0001 s1 count) :: (list_init count (fun _ -> Socket.recv s2 >>= fun _ -> Deferred.return ()))) 98 | @ 99 | ((send ~delay:0.0002 s2 count) :: (list_init count (fun _ -> Socket.recv s1 >>= fun _ -> Deferred.return ()))) 100 | ) 101 | 102 | let test_slow_mix (_, s1, s2) = 103 | all_ok [ 104 | send ~delay:0.0001 s2 count; recv ~delay:0.0002 s1 count; 105 | send ~delay:0.0001 s1 count; recv ~delay:0.0002 s2 count; 106 | send ~delay:0.0001 s2 count; recv ~delay:0.0002 s1 count; 107 | send ~delay:0.0001 s1 count; recv ~delay:0.0002 s2 count; 108 | ] 109 | 110 | let suite (exec : (unit -> unit Deferred.t) -> unit) = 111 | let bracket setup test teardown = 112 | let f () = 113 | setup () >>= fun v -> 114 | Deferred.catch (fun () -> test v) >>= fun r -> 115 | teardown v >>= fun () -> 116 | match r with 117 | | Ok v -> Deferred.return v 118 | | Error exn -> Deferred.fail exn 119 | in 120 | fun () -> exec f 121 | in 122 | 123 | __MODULE__ >::: [ 124 | "test_send_receive" >:: bracket setup test_send_receive teardown; 125 | "test_msend_mreceive" >:: bracket setup test_msend_mreceive teardown; 126 | "test_mix" >:: bracket setup test_mix teardown; 127 | "test_slow_send" >:: bracket setup test_slow_send teardown; 128 | "test_slow_receive" >:: bracket setup test_slow_receive teardown; 129 | "test_slow_mix" >:: bracket setup test_slow_mix teardown; 130 | "test_multi" >:: bracket setup test_multi teardown; 131 | ] 132 | 133 | let run exec = 134 | run_test_tt_main (suite exec) |> ignore 135 | 136 | end 137 | -------------------------------------------------------------------------------- /zmq-deferred/test/test.mli: -------------------------------------------------------------------------------- 1 | module Make: functor(T: Zmq_deferred.Deferred.T) -> sig 2 | val run: ((unit -> unit T.Deferred.t) -> unit) -> unit 3 | end 4 | -------------------------------------------------------------------------------- /zmq-eio.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Eio aware bindings to ZMQ" 4 | maintainer: ["Anders Fugmann "] 5 | authors: ["Anders Fugmann"] 6 | license: "MIT" 7 | homepage: "https://github.com/issuu/ocaml-zmq" 8 | bug-reports: "https://github.com/issuu/ocaml-zmq/issues" 9 | depends: [ 10 | "dune" {>= "2.7"} 11 | "ocaml" {>= "4.04.1"} 12 | "zmq" {= version} 13 | "eio" {>= "0.10"} 14 | "eio_main" {>= "0.10"} 15 | "base" {>= "v0.11.0"} 16 | "ounit2" {with-test} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/issuu/ocaml-zmq.git" 34 | -------------------------------------------------------------------------------- /zmq-eio/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zmq_eio) 3 | (public_name zmq-eio) 4 | (libraries zmq.deferred eio eio_main base)) 5 | -------------------------------------------------------------------------------- /zmq-eio/src/socket.ml: -------------------------------------------------------------------------------- 1 | (** Eio based bindings for eio *) 2 | exception Closed 3 | 4 | type 'a t = { 5 | socket : 'a Zmq.Socket.t; 6 | fd : Unix.file_descr; 7 | senders : (unit -> unit) Queue.t; 8 | receivers : (unit -> unit) Queue.t; 9 | condition : Eio.Condition.t; 10 | mutex : Eio.Mutex.t; 11 | ready_condition: Eio.Condition.t; 12 | mutable thread : unit Eio.Promise.or_exn option; (* None indicates already closed *) 13 | } 14 | 15 | type 'a of_socket_args = sw:Eio.Switch.t -> 'a 16 | type 'a deferred = 'a 17 | 18 | (** invoke the first function on the queue, but only pop it if it does not raise EAGAIN *) 19 | let process queue = 20 | match (Queue.peek queue) () with 21 | | () -> 22 | let (_: unit -> unit) = Queue.pop queue in 23 | () 24 | | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> 25 | (* If f raised EAGAIN, dont pop the message. *) 26 | (* This should never happen. If so, the queue could be replaced with a Eio.Stream for faster handling *) 27 | () 28 | 29 | let with_lock lock f = 30 | Eio.Mutex.lock lock; 31 | try 32 | let v = f () in 33 | Eio.Mutex.unlock lock; 34 | v 35 | with 36 | | e -> 37 | Eio.Mutex.unlock lock; 38 | raise e 39 | 40 | let rec fd_monitor t = 41 | Eio.Condition.await_no_mutex t.ready_condition; 42 | Eio_unix.await_readable t.fd; 43 | with_lock t.mutex (fun () -> Eio.Condition.broadcast t.condition); 44 | fd_monitor t 45 | 46 | let rec event_loop t = 47 | let inner () = 48 | match Zmq.Socket.events t.socket with 49 | | Zmq.Socket.Poll_error -> 50 | failwith "Cannot poll socket" 51 | | (Poll_in_out | Poll_in) when not (Queue.is_empty t.receivers) -> 52 | process t.receivers 53 | | (Poll_in_out | Poll_out) when not (Queue.is_empty t.senders) -> 54 | process t.senders 55 | | _ -> 56 | Eio.Condition.broadcast t.ready_condition; 57 | Eio.Condition.await t.condition t.mutex; 58 | in 59 | with_lock t.mutex (fun () -> inner ()); 60 | match t.thread with 61 | | None when Queue.is_empty t.senders && Queue.is_empty t.receivers -> 62 | () 63 | | _ -> 64 | event_loop t 65 | 66 | let of_socket: ('a Zmq.Socket.t -> 'a t) of_socket_args = fun ~sw socket -> 67 | let fd = Zmq.Socket.get_fd socket in 68 | let t = 69 | { socket; 70 | fd; 71 | senders = Queue.create (); 72 | receivers = Queue.create (); 73 | mutex = Eio.Mutex.create (); 74 | condition = Eio.Condition.create (); 75 | ready_condition = Eio.Condition.create (); 76 | thread = None; 77 | } 78 | in 79 | let thread = Eio.Fiber.fork_promise ~sw (fun () -> 80 | Eio.Switch.run (fun sw -> 81 | Eio.Fiber.fork ~sw (fun () -> event_loop t); 82 | Eio.Fiber.fork_daemon ~sw (fun () -> fd_monitor t); 83 | () 84 | ); 85 | ) 86 | in 87 | t.thread <- Some thread; 88 | t 89 | 90 | let to_socket t = 91 | t.socket 92 | 93 | (** Stop the deamon thread, and ensure that all sends and receives has been handled *) 94 | let close t = 95 | let thread = match t.thread with 96 | | None -> failwith "Socket already closed" 97 | | Some t -> t 98 | in 99 | with_lock t.mutex (fun () -> t.thread <- None; Eio.Condition.broadcast t.condition); 100 | let _e = Eio.Promise.await_exn thread in 101 | Zmq.Socket.close t.socket; 102 | () 103 | 104 | 105 | let request t queue f = 106 | let () = 107 | match t.thread with 108 | | None -> raise Closed 109 | | Some _ -> () 110 | in 111 | let (pt, pu) = Eio.Promise.create ~label:"Zmq" () in 112 | let f () = 113 | let v = f () in 114 | Eio.Promise.resolve pu v 115 | in 116 | with_lock t.mutex (fun () -> Queue.push f queue; Eio.Condition.broadcast t.condition); 117 | Eio.Promise.await pt 118 | 119 | let send t message = 120 | request t t.senders (fun () -> Zmq.Socket.send ~block:false t.socket message) 121 | 122 | let send_msg t message = 123 | request t t.senders (fun () -> Zmq.Socket.send_msg ~block:false t.socket message) 124 | 125 | let send_all t messages = 126 | request t t.senders (fun () -> Zmq.Socket.send_all ~block:false t.socket messages) 127 | 128 | let send_msg_all t messages = 129 | request t t.senders (fun () -> Zmq.Socket.send_msg_all ~block:false t.socket messages) 130 | 131 | let recv t = 132 | request t t.receivers (fun () -> Zmq.Socket.recv ~block:false t.socket) 133 | 134 | let recv_msg t = 135 | request t t.receivers (fun () -> Zmq.Socket.recv_msg ~block:false t.socket) 136 | 137 | let recv_all t = 138 | request t t.receivers (fun () -> Zmq.Socket.recv_all ~block:false t.socket) 139 | 140 | let recv_msg_all t = 141 | request t t.receivers (fun () -> Zmq.Socket.recv_msg_all ~block:false t.socket) 142 | 143 | module Router = struct 144 | type id_t = string 145 | 146 | let id_of_string t = t 147 | 148 | let recv t = 149 | match recv_all t with 150 | | id :: message -> (id, message) 151 | | _ -> assert false 152 | 153 | let send t id message = 154 | send_all t (id :: message) 155 | end 156 | 157 | module Monitor = struct 158 | let recv t = request t t.receivers (fun () -> Zmq.Monitor.recv ~block:false t.socket) 159 | end 160 | -------------------------------------------------------------------------------- /zmq-eio/src/socket.mli: -------------------------------------------------------------------------------- 1 | include Zmq_deferred.Socket.Socket with type 'a deferred = 'a and type 'a of_socket_args = sw:Eio.Switch.t -> 'a 2 | -------------------------------------------------------------------------------- /zmq-eio/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries zmq-eio ounit2 eio eio_main)) 4 | 5 | (rule 6 | (alias runtest) 7 | (deps 8 | (:test test.exe)) 9 | (action 10 | (run %{test})) 11 | (package zmq-eio)) 12 | -------------------------------------------------------------------------------- /zmq-eio/test/test.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | let sleepf env secs = Eio.Time.sleep (Eio.Stdenv.clock env) secs 4 | 5 | let setup ~sw env = 6 | let make ctx tpe = 7 | let s = Zmq.Socket.create ctx tpe in 8 | Zmq.Socket.set_receive_high_water_mark s 1; 9 | Zmq.Socket.set_send_high_water_mark s 2; 10 | s 11 | in 12 | let ctx = Zmq.Context.create () in 13 | let s1 = make ctx Zmq.Socket.pair in 14 | let s2 = make ctx Zmq.Socket.pair in 15 | let endpoint = "inproc://test" in 16 | Zmq.Socket.bind s1 endpoint; 17 | Zmq.Socket.connect s2 endpoint; 18 | (* Sleep a bit *) 19 | sleepf env 0.0001; 20 | (ctx, Zmq_eio.Socket.of_socket ~sw s1, Zmq_eio.Socket.of_socket ~sw s2) 21 | 22 | let teardown ~sw:_ _env (ctx, s1, s2) = 23 | Zmq_eio.Socket.close s2; 24 | Zmq_eio.Socket.close s1; 25 | Zmq.Context.terminate ctx; 26 | () 27 | 28 | let all_ok l = 29 | Eio.Fiber.List.iter (fun f -> f ()) l 30 | 31 | let send env ?(delay = 0.0) s count = 32 | let rec inner = function 33 | | 0 -> () 34 | | n -> 35 | Zmq_eio.Socket.send s "test"; 36 | sleepf env delay; 37 | inner (n - 1) 38 | in 39 | fun () -> inner count 40 | 41 | let send_all env ?(delay = 0.0) s count = 42 | let rec inner = function 43 | | 0 -> () 44 | | n -> 45 | Zmq_eio.Socket.send_all s ["test1"; "test2"; "test3"]; 46 | sleepf env delay; 47 | inner (n - 1) 48 | in 49 | fun () -> inner count 50 | 51 | let recv env ?(delay = 0.0) s count = 52 | let rec inner = function 53 | | 0 -> () 54 | | n -> 55 | let _ = Zmq_eio.Socket.recv s in 56 | sleepf env delay; 57 | inner (n - 1) 58 | in 59 | fun () -> inner count 60 | 61 | let recv_all env ?(delay = 0.0) s count = 62 | let rec inner = function 63 | | 0 -> () 64 | | n -> 65 | let _ = Zmq_eio.Socket.recv_all s in 66 | sleepf env delay; 67 | inner (n - 1) 68 | in 69 | fun () -> inner count 70 | 71 | (** Test functions *) 72 | let test_setup_teardown ~sw:_ _env _s = () 73 | 74 | let count = 1000 75 | (* Tests *) 76 | let test_send_receive ~sw:_ env (_, s1, s2) = 77 | all_ok [ 78 | send env s2 count; 79 | recv env s1 count; 80 | ] 81 | 82 | let test_send_receive_all ~sw:_ env (_, s1, s2) = 83 | all_ok [ 84 | send_all env s2 count; 85 | recv_all env s1 count; 86 | ] 87 | 88 | let test_msend_mreceive ~sw:_ env (_, s1, s2) = 89 | all_ok [ 90 | send env s2 count; send env s2 count; send env s2 count; send env s2 count; 91 | recv env s1 count; recv env s1 count; recv env s1 count; recv env s1 count; 92 | ] 93 | 94 | let test_mix ~sw:_ env (_, s1, s2) = 95 | all_ok [ 96 | send env s2 count; recv env s1 count; 97 | send env s1 count; recv env s2 count; 98 | send env s2 count; recv env s1 count; 99 | send env s1 count; recv env s2 count; 100 | send env s2 count; recv env s1 count; 101 | ] 102 | 103 | let test_slow_send ~sw:_ env (_, s1, s2) = 104 | all_ok [ 105 | recv env ~delay:0.0001 s2 count; 106 | send env s1 (count / 5); 107 | send env s1 (count / 5); 108 | send env s1 (count / 5); 109 | send env s1 (count / 5); 110 | send env s1 (count / 5); 111 | ] 112 | 113 | let test_slow_receive ~sw:_ env (_, s1, s2) = 114 | all_ok [ 115 | send env ~delay:0.0001 s2 count; 116 | recv env s1 (count / 5); 117 | recv env s1 (count / 5); 118 | recv env s1 (count / 5); 119 | recv env s1 (count / 5); 120 | recv env s1 (count / 5); 121 | ] 122 | 123 | let test_slow_mix1 ~sw:_ env (_, s1, s2) = 124 | all_ok [ 125 | send env ~delay:0.0001 s2 count; recv env ~delay:0.0002 s1 count; 126 | send env ~delay:0.0001 s1 count; recv env ~delay:0.0002 s2 count; 127 | send env ~delay:0.0001 s2 count; recv env ~delay:0.0002 s1 count; 128 | send env ~delay:0.0001 s1 count; recv env ~delay:0.0002 s2 count; 129 | ] 130 | 131 | let test_slow_mix2 ~sw:_ env (_, s1, s2) = 132 | all_ok [ 133 | send env ~delay:0.0002 s2 count; recv env ~delay:0.0001 s1 count; 134 | send env ~delay:0.0002 s1 count; recv env ~delay:0.0001 s2 count; 135 | send env ~delay:0.0002 s2 count; recv env ~delay:0.0001 s1 count; 136 | send env ~delay:0.0002 s1 count; recv env ~delay:0.0001 s2 count; 137 | ] 138 | 139 | 140 | let suite () = 141 | let bracket test = 142 | let f sw env = 143 | let s = setup ~sw env in 144 | match test ~sw env s with 145 | | v -> teardown ~sw env s; v 146 | | exception e -> teardown ~sw env s; raise e 147 | in 148 | fun () -> Eio_main.run (fun env -> 149 | Eio.Switch.run (fun sw -> f sw env)) 150 | in 151 | 152 | __MODULE__ >::: [ 153 | "test_setup_teardown" >:: bracket test_setup_teardown; 154 | "test_send_receive" >:: bracket test_send_receive; 155 | "test_msend_mreceive" >:: bracket test_msend_mreceive; 156 | "test_mix" >:: bracket test_mix; 157 | "test_slow_send" >:: bracket test_slow_send; 158 | "test_slow_receive" >:: bracket test_slow_receive; 159 | "test_slow_mix" >:: bracket test_slow_mix1; 160 | "test_slow_mix" >:: bracket test_slow_mix2; 161 | "test_send_receive_all" >:: bracket test_send_receive_all; 162 | ] 163 | 164 | 165 | let () = 166 | run_test_tt_main (suite ()) |> ignore 167 | -------------------------------------------------------------------------------- /zmq-lwt.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Lwt-aware bindings to ZMQ" 4 | maintainer: ["Anders Fugmann "] 5 | authors: ["Anders Fugmann "] 6 | license: "MIT" 7 | homepage: "https://github.com/issuu/ocaml-zmq" 8 | bug-reports: "https://github.com/issuu/ocaml-zmq/issues" 9 | depends: [ 10 | "dune" {>= "2.7"} 11 | "ocaml" {>= "4.03.0"} 12 | "zmq" {= version} 13 | "lwt" {>= "2.6.0"} 14 | "ounit2" {with-test} 15 | "odoc" {with-doc} 16 | ] 17 | build: [ 18 | ["dune" "subst"] {dev} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "@install" 27 | "@runtest" {with-test} 28 | "@doc" {with-doc} 29 | ] 30 | ] 31 | dev-repo: "git+https://github.com/issuu/ocaml-zmq.git" 32 | -------------------------------------------------------------------------------- /zmq-lwt/src/deferred.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a Lwt.t 2 | 3 | (* Define let_catch_result with the same signature as Lwt_result.catch 4 | for lwt version >= 6.0. This function can be replaced by 5 | Lwt_result.catch if/when we bump minimum required version of Lwt to >= 6.0. 6 | See https://github.com/ocsigen/lwt/pull/965 7 | *) 8 | let lwt_result_catch f = 9 | Lwt.catch (fun () -> Lwt_result.ok (f ())) Lwt_result.fail 10 | 11 | module Deferred = struct 12 | type 'a t = 'a Lwt.t 13 | let return a = Lwt.return a 14 | let catch f = lwt_result_catch f 15 | let don't_wait_for = Lwt.async 16 | let sleepf secs = Lwt_unix.sleep secs 17 | let fail exn = Lwt.fail exn 18 | 19 | module Infix = struct 20 | let (>>=) = Lwt.(>>=) 21 | let () = Lwt.() 22 | end 23 | end 24 | 25 | module Condition = struct 26 | type 'a t = 'a Lwt_condition.t 27 | let create () = Lwt_condition.create () 28 | let wait t = Lwt_condition.wait t 29 | let signal t v = Lwt_condition.signal t v 30 | end 31 | 32 | module Mailbox = struct 33 | type 'a t = ('a Lwt.t * 'a Lwt.u) 34 | let create () = Lwt.wait () 35 | let send (_, u) v = Lwt.wakeup_later u v 36 | let recv (t, _) = t 37 | end 38 | 39 | module Fd = struct 40 | type t = Lwt_unix.file_descr 41 | 42 | let create fd = Lwt_unix.of_unix_file_descr ~set_flags:false fd 43 | let wait_readable t = Lwt_unix.wait_read t 44 | let release _ = Deferred.return () 45 | end 46 | -------------------------------------------------------------------------------- /zmq-lwt/src/deferred.mli: -------------------------------------------------------------------------------- 1 | include Zmq_deferred.Deferred.T with type 'a t = 'a Lwt.t 2 | -------------------------------------------------------------------------------- /zmq-lwt/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zmq_lwt) 3 | (public_name zmq-lwt) 4 | (libraries zmq.deferred lwt lwt.unix)) 5 | -------------------------------------------------------------------------------- /zmq-lwt/src/zmq_lwt.ml: -------------------------------------------------------------------------------- 1 | module Socket = Zmq_deferred.Socket.Make(Deferred) 2 | -------------------------------------------------------------------------------- /zmq-lwt/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries zmq_deferred_test zmq-lwt)) 4 | 5 | (rule 6 | (alias runtest) 7 | (deps 8 | (:test test.exe)) 9 | (action 10 | (run %{test})) 11 | (package zmq-lwt)) 12 | -------------------------------------------------------------------------------- /zmq-lwt/test/test.ml: -------------------------------------------------------------------------------- 1 | module Test = Zmq_deferred_test.Test.Make(Zmq_lwt__Deferred) 2 | let () = Test.run (fun f -> Lwt_main.run (f ())) 3 | -------------------------------------------------------------------------------- /zmq.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "OCaml bindings for ZeroMQ 4.x" 4 | description: """ 5 | This library contains basic bindings for ZMQ. 6 | Lwt aware bindings to zmq are availble though package zmq-lwt 7 | Async aware bindings to zmq are available though package zmq-async""" 8 | maintainer: ["Anders Fugmann "] 9 | authors: ["Anders Fugmann" "Pedro Borges" "Peter Zotov"] 10 | license: "MIT" 11 | homepage: "https://github.com/issuu/ocaml-zmq" 12 | bug-reports: "https://github.com/issuu/ocaml-zmq/issues" 13 | depends: [ 14 | "dune" {>= "2.7"} 15 | "ocaml" {>= "4.03.0"} 16 | "conf-zmq" 17 | "ounit2" {with-test} 18 | "dune-configurator" 19 | "odoc" {with-doc} 20 | ] 21 | conflicts: ["ocaml-zmq"] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/issuu/ocaml-zmq.git" 37 | -------------------------------------------------------------------------------- /zmq/examples/Readme: -------------------------------------------------------------------------------- 1 | To compile the examples use ocamlfind ocamlopt -o -linkpkg -package zmq,str 2 | -------------------------------------------------------------------------------- /zmq/examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names hwserver hwclient wuserver wuclient wuproxy taskvent taskwork 3 | tasksink threaded_loopback echoserver echoclient stream_server) 4 | (libraries threads zmq str)) 5 | 6 | (alias 7 | (name examples) 8 | (deps hwserver.exe hwclient.exe wuserver.exe wuclient.exe wuproxy.exe 9 | taskvent.exe taskwork.exe tasksink.exe threaded_loopback.exe 10 | echoserver.exe echoclient.exe stream_server.exe)) 11 | -------------------------------------------------------------------------------- /zmq/examples/echoclient.ml: -------------------------------------------------------------------------------- 1 | (* Simple client *) 2 | 3 | let ctx = Zmq.Context.create () in 4 | let socket = Zmq.Socket.create ctx Zmq.Socket.dealer in 5 | Zmq.Socket.connect socket "tcp://127.0.0.1:5555"; 6 | 7 | let msg = 8 | let open Bigarray in 9 | let data = Array1.create char c_layout 1_000_000 in 10 | Array1.fill data '\x00'; 11 | Zmq.Msg.init_data data 12 | in 13 | 14 | while true do 15 | Zmq.Socket.send_msg socket msg; 16 | ignore (Zmq.Socket.recv_msg socket); 17 | done; 18 | 19 | Zmq.Socket.close socket; 20 | Zmq.Context.terminate ctx 21 | -------------------------------------------------------------------------------- /zmq/examples/echoserver.ml: -------------------------------------------------------------------------------- 1 | (* Simple echo server with no copying of the received message 2 | content *) 3 | 4 | let ctx = Zmq.Context.create () in 5 | let socket = Zmq.Socket.create ctx Zmq.Socket.router in 6 | Zmq.Socket.bind socket "tcp://*:5555"; 7 | 8 | let counter = ref 0 in 9 | 10 | while true do 11 | incr counter; 12 | Printf.printf "Round %d\n%!" !counter; 13 | let sender = Zmq.Socket.recv_msg socket in 14 | let msg = Zmq.Socket.recv_msg socket in 15 | Zmq.Socket.send_msg ~more:true socket sender; 16 | Zmq.Socket.send_msg socket msg; 17 | done; 18 | 19 | Zmq.Socket.close socket; 20 | Zmq.Context.terminate ctx 21 | -------------------------------------------------------------------------------- /zmq/examples/hwclient.ml: -------------------------------------------------------------------------------- 1 | let context = Zmq.Context.create () in 2 | print_endline "Connecting to hello world server..."; 3 | let requester = Zmq.Socket.create context Zmq.Socket.req in 4 | Zmq.Socket.connect requester "tcp://localhost:5555"; 5 | 6 | for i = 1 to 10 do 7 | Printf.printf "Sending request %d...\n" i; 8 | Zmq.Socket.send requester "Hello"; 9 | let reply = Zmq.Socket.recv requester in 10 | Printf.printf "Received reply %d: [%s]\n" i reply 11 | done; 12 | 13 | Zmq.Socket.close requester; 14 | Zmq.Context.terminate context 15 | -------------------------------------------------------------------------------- /zmq/examples/hwserver.ml: -------------------------------------------------------------------------------- 1 | let context = Zmq.Context.create () in 2 | let responder = Zmq.Socket.create context Zmq.Socket.rep in 3 | Zmq.Socket.bind responder "tcp://*:5555"; 4 | 5 | while true do 6 | let request = Zmq.Socket.recv responder in 7 | Printf.printf "Received request: [%s]\n%!" request; 8 | Zmq.Socket.send responder "World" 9 | done; 10 | 11 | Zmq.Socket.close responder; 12 | Zmq.Context.terminate context 13 | -------------------------------------------------------------------------------- /zmq/examples/stream_server.ml: -------------------------------------------------------------------------------- 1 | 2 | let ctx = Zmq.Context.create();; 3 | let sock = Zmq.Socket.create ctx Zmq.Socket.stream;; 4 | Zmq.Socket.bind sock "tcp://0.0.0.0:8089";; 5 | 6 | while true do 7 | let l = Zmq.Socket.recv_all sock in 8 | Printf.printf "receive: [%s]\n%!" (String.concat ";" @@ List.map (Printf.sprintf "%S") l); 9 | match l with 10 | | [id; msg] when String.trim msg = "hello" -> 11 | Zmq.Socket.send_all sock [id; "world\n"] 12 | | _ -> () 13 | done;; 14 | 15 | Zmq.Socket.close sock; 16 | Zmq.Context.terminate ctx 17 | -------------------------------------------------------------------------------- /zmq/examples/tasksink.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Task sink 3 | Binds PULL socket to tcp://localhost:5558 4 | Collects results from workers vis that socket 5 | *) 6 | 7 | let time_diff_ms t1 t2 = 8 | truncate ((t2 -. t1) *. 1000.0) 9 | 10 | let () = 11 | let module Socket = Zmq.Socket in 12 | 13 | (* Prepare our context and socket *) 14 | let context = Zmq.Context.create () in 15 | let receiver = Socket.create context Socket.pull in 16 | Socket.bind receiver "tcp://*:5558"; 17 | 18 | (* Wait for start of batch *) 19 | let _ = Socket.recv receiver in 20 | 21 | (* Start our clock now *) 22 | let start_time = Unix.gettimeofday () in 23 | 24 | (* Process 100 confirmations *) 25 | for task_nbr = 0 to 99 do 26 | let _ = Socket.recv receiver in 27 | if task_nbr mod 10 == 0 then 28 | Printf.printf ":" 29 | else 30 | Printf.printf "."; 31 | flush stdout 32 | done; 33 | 34 | (* Calculate and report duration of batch *) 35 | let elapsed = time_diff_ms start_time (Unix.gettimeofday ()) in 36 | Printf.printf "Total elapsed time: %d msec \n" elapsed; 37 | 38 | Socket.close receiver; 39 | Zmq.Context.terminate context 40 | -------------------------------------------------------------------------------- /zmq/examples/taskvent.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Task ventilator 3 | Binds PUSH socket to tcp://localhost:5557 4 | Sends batch of tasks to workers via that socket 5 | *) 6 | 7 | (* build a list of size random numbers in [1, bound] *) 8 | let random_list bound size = 9 | let next_int () = (Random.int bound) + 1 in 10 | let rec loop i lst = 11 | if i == size then lst else loop (i+1) ((next_int ()) :: lst) in 12 | loop 0 [] 13 | 14 | let () = 15 | let module Socket = Zmq.Socket in 16 | let context = Zmq.Context.create () in 17 | 18 | (* Socket to send messages on *) 19 | let sender = Socket.create context Socket.push in 20 | Socket.bind sender "tcp://*:5557"; 21 | 22 | (* Socket to send start of batch message on *) 23 | let sink = Socket.create context Socket.push in 24 | Socket.connect sink "tcp://localhost:5558"; 25 | 26 | Printf.printf "Press Enter when the workers are ready: "; 27 | ignore (read_line ()); 28 | Printf.printf "Sending tasks to workers... \n"; 29 | 30 | (* The first message is "0" and signals start of batch *) 31 | Socket.send sink "0"; 32 | 33 | (* Initialize RNG with changing seed *) 34 | Random.self_init (); 35 | 36 | (* Send 100 tasks with random workload from 1 to 100 msec *) 37 | let workloads = random_list 100 100 in 38 | let total = List.fold_left (+) 0 workloads in 39 | List.iter (fun w -> let str = Printf.sprintf "%d" w in Socket.send sender str) workloads; 40 | 41 | Printf.printf "Total expected cost: %d msec\n" total; 42 | Unix.sleep 1; (* Give 0MQ time to deliver *) 43 | 44 | Socket.close sink; 45 | Socket.close sender; 46 | Zmq.Context.terminate context 47 | -------------------------------------------------------------------------------- /zmq/examples/taskwork.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Task worker 3 | Connects PULL socket to tcp://localhost:5557 4 | Collects workloads from ventilator via that socket 5 | Connects PUSH socket to tcp://localhost:5558 6 | Sends results to sink via that socket 7 | *) 8 | 9 | let ms_sleep msec = 10 | ignore (Unix.select [] [] [] (msec /. 1000.0)) 11 | 12 | let () = 13 | let module Socket = Zmq.Socket in 14 | let context = Zmq.Context.create () in 15 | 16 | (* Socket to receive messages on *) 17 | let receiver = Socket.create context Socket.pull in 18 | Socket.connect receiver "tcp://localhost:5557"; 19 | 20 | (* Socket to send messages to *) 21 | let sender = Socket.create context Socket.push in 22 | Socket.connect sender "tcp://localhost:5558"; 23 | 24 | (* Process tasks forever *) 25 | while true do 26 | let str = Socket.recv receiver in 27 | (* Simple progress indicator for the viewer *) 28 | flush stdout; 29 | Printf.printf "%s." str; 30 | 31 | (* Do the work *) 32 | ms_sleep (float_of_string str); 33 | 34 | (* Send results to sink *) 35 | Socket.send sender "" 36 | done; 37 | 38 | Socket.close receiver; 39 | Socket.close sender; 40 | Zmq.Context.terminate context 41 | -------------------------------------------------------------------------------- /zmq/examples/threaded_loopback.ml: -------------------------------------------------------------------------------- 1 | open Zmq 2 | 3 | let rec subscription socket = 4 | (* Block thread until there is data *) 5 | let msg = Socket.recv socket in 6 | let thread = Thread.self () |> Thread.id |> string_of_int in 7 | print_endline @@ "thread " ^ thread ^ " received: " ^ msg; 8 | subscription socket 9 | 10 | let rec publish count socket = 11 | let thread = Thread.self () |> Thread.id |> string_of_int in 12 | let msg = "Hello #" ^ string_of_int count ^ " from thread " ^ thread in 13 | Socket.send socket msg; 14 | print_endline @@ "thread " ^ thread ^ " sent: " ^ msg; 15 | Thread.delay 1.0; 16 | publish (succ count) socket 17 | 18 | let () = 19 | let context = Context.create () in 20 | 21 | let publish_socket = Socket.create context Socket.pub in 22 | let publish_thread = 23 | Socket.bind publish_socket "tcp://*:5000"; 24 | Thread.create (publish 0) publish_socket in 25 | 26 | let subscribe_socket = Socket.create context Socket.sub in 27 | let subscribe_thread = 28 | Socket.connect subscribe_socket "tcp://127.0.0.1:5000"; 29 | Socket.subscribe subscribe_socket ""; 30 | Thread.create subscription subscribe_socket in 31 | 32 | List.iter Thread.join [subscribe_thread; publish_thread]; 33 | List.iter Socket.close [(subscribe_socket :> [`Sub | `Pub] Socket.t); (publish_socket :> [`Sub | `Pub] Socket.t)]; 34 | 35 | Context.terminate context 36 | -------------------------------------------------------------------------------- /zmq/examples/wuclient.ml: -------------------------------------------------------------------------------- 1 | let split = Str.split (Str.regexp_string " ") 2 | 3 | let () = 4 | let context = Zmq.Context.create () in 5 | let subscriber = Zmq.Socket.create context Zmq.Socket.sub in 6 | print_endline "Collecting updates from weather server..."; 7 | Zmq.Socket.connect subscriber "tcp://localhost:5556"; 8 | 9 | let filter = if (Array.length Sys.argv) > 1 then Sys.argv.(1) else "10001 " in 10 | Zmq.Socket.subscribe subscriber filter; 11 | 12 | let total_temp = ref 0 in 13 | let update_nbr = 100 in 14 | for _i = 0 to pred update_nbr do 15 | let str = Zmq.Socket.recv subscriber in 16 | match List.map int_of_string (split str) with 17 | | [ _; temperature; _] -> total_temp := !total_temp + temperature; 18 | | _ -> (); 19 | done; 20 | 21 | Printf.printf "Average temperature for zipcode %s was %d\n" filter (!total_temp / update_nbr); 22 | 23 | Zmq.Socket.close subscriber; 24 | Zmq.Context.terminate context 25 | -------------------------------------------------------------------------------- /zmq/examples/wuproxy.ml: -------------------------------------------------------------------------------- 1 | let context = Zmq.Context.create () in 2 | 3 | let frontend = Zmq.Socket.create context Zmq.Socket.sub in 4 | Zmq.Socket.connect frontend "tcp://192.168.55.210:5556"; 5 | 6 | let backend = Zmq.Socket.create context Zmq.Socket.sub in 7 | Zmq.Socket.bind backend "tcp://10.1.1.0:8100"; 8 | 9 | Zmq.Socket.subscribe frontend ""; 10 | 11 | while true do 12 | let finish = ref false in 13 | while not !finish do 14 | let message = Zmq.Socket.recv frontend in 15 | if Zmq.Socket.has_more frontend then 16 | Zmq.Socket.send ~more:true backend message 17 | else begin 18 | Zmq.Socket.send backend message; 19 | finish := true 20 | end 21 | done 22 | done; 23 | 24 | Zmq.Socket.close frontend; 25 | Zmq.Socket.close backend; 26 | Zmq.Context.terminate context 27 | -------------------------------------------------------------------------------- /zmq/examples/wuserver.ml: -------------------------------------------------------------------------------- 1 | open Zmq 2 | 3 | let randint a b = (Random.int (b - a + 1)) + a 4 | 5 | let () = 6 | let context = Zmq.Context.create () in 7 | let publisher = Zmq.Socket.create context Zmq.Socket.pub in 8 | Zmq.Socket.bind publisher "tcp://*:5556"; 9 | 10 | while true do 11 | let zipcode = (randint 1 10001) in 12 | let temperature = (randint 1 215) - 80 in 13 | let relhumidity = (randint 1 50) + 10 in 14 | Socket.send publisher (Printf.sprintf "%05d %d %d" zipcode temperature relhumidity) 15 | done; 16 | 17 | Zmq.Socket.close publisher; 18 | Zmq.Context.terminate context; 19 | -------------------------------------------------------------------------------- /zmq/examples/zversion.ml: -------------------------------------------------------------------------------- 1 | let _ = 2 | let (x, y, z) = Zmq.version () in 3 | Printf.printf "Current 0MQ version is %d.%d.%d\n" x y z 4 | -------------------------------------------------------------------------------- /zmq/src/caml_zmq_stubs.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | 22 | #if defined(_WIN32) || defined(_WIN64) 23 | # include 24 | # include 25 | # define fd_type SOCKET 26 | # define Val_fd(x) win_alloc_socket(x) 27 | #else 28 | # define fd_type int 29 | # define Val_fd(x) Val_int(x) 30 | #endif 31 | 32 | #include 33 | #if ZMQ_VERSION_MAJOR != 4 34 | #error "This library requires libzmq 4.x" 35 | #endif 36 | 37 | #include "fail.h" 38 | #include "context.h" 39 | #include "socket.h" 40 | #include "msg.h" 41 | 42 | /** 43 | * Version 44 | */ 45 | 46 | CAMLprim value caml_zmq_version(value unit) { 47 | CAMLparam1 (unit); 48 | CAMLlocal1 (version_tuple); 49 | 50 | int major, minor, patch; 51 | zmq_version(&major, &minor, &patch); 52 | 53 | version_tuple = caml_alloc_tuple(3); 54 | Store_field(version_tuple, 0, Val_int(major)); 55 | Store_field(version_tuple, 1, Val_int(minor)); 56 | Store_field(version_tuple, 2, Val_int(patch)); 57 | 58 | CAMLreturn (version_tuple); 59 | } 60 | 61 | /** 62 | * Init 63 | */ 64 | 65 | CAMLprim value caml_zmq_new(value unit) { 66 | CAMLparam1 (unit); 67 | CAMLlocal1 (ctx_value); 68 | 69 | void *ctx = zmq_ctx_new(); 70 | caml_zmq_raise_if(ctx == NULL, "zmq_ctx_new"); 71 | 72 | ctx_value = caml_zmq_copy_context(ctx); 73 | CAMLreturn (ctx_value); 74 | } 75 | 76 | /** 77 | * Term 78 | */ 79 | 80 | CAMLprim value caml_zmq_term(value ctx) { 81 | CAMLparam1 (ctx); 82 | 83 | int result = zmq_ctx_term(CAML_ZMQ_Context_val(ctx)); 84 | caml_zmq_raise_if(result == -1, "zmq_ctx_term"); 85 | 86 | CAML_ZMQ_Context_val(ctx) = NULL; 87 | CAMLreturn (Val_unit); 88 | } 89 | 90 | /** 91 | * Set context option 92 | */ 93 | 94 | static int const native_ctx_int_option_for[] = { 95 | ZMQ_IO_THREADS, 96 | ZMQ_MAX_SOCKETS, 97 | ZMQ_IPV6 98 | }; 99 | 100 | CAMLprim value caml_zmq_ctx_set_int_option(value socket, value option_name, value option_value) { 101 | CAMLparam3 (socket, option_name, option_value); 102 | 103 | int result = zmq_ctx_set(CAML_ZMQ_Context_val(socket), 104 | native_ctx_int_option_for[Int_val(option_name)], 105 | Int_val(option_value)); 106 | caml_zmq_raise_if(result == -1, "zmq_ctx_set"); 107 | CAMLreturn (Val_unit); 108 | } 109 | 110 | /** 111 | * Get context option 112 | */ 113 | 114 | CAMLprim value caml_zmq_ctx_get_int_option(value socket, value option_name) { 115 | CAMLparam2 (socket, option_name); 116 | 117 | int result = zmq_ctx_get(CAML_ZMQ_Context_val(socket), 118 | native_ctx_int_option_for[Int_val(option_name)]); 119 | caml_zmq_raise_if(result == -1, "zmq_ctx_get"); 120 | CAMLreturn (Val_int(result)); 121 | } 122 | 123 | /** 124 | * Socket 125 | */ 126 | 127 | /* Order must match OCaml's kind declaration */ 128 | static int const socket_type_for_kind[] = { 129 | ZMQ_PAIR, 130 | ZMQ_PUB, 131 | ZMQ_SUB, 132 | ZMQ_REQ, 133 | ZMQ_REP, 134 | ZMQ_DEALER, 135 | ZMQ_ROUTER, 136 | ZMQ_PULL, 137 | ZMQ_PUSH, 138 | ZMQ_XPUB, 139 | ZMQ_XSUB, 140 | ZMQ_STREAM, 141 | }; 142 | 143 | CAMLprim value caml_zmq_socket(value ctx, value socket_kind) { 144 | CAMLparam2 (ctx, socket_kind); 145 | CAMLlocal1 (sock_value); 146 | void *socket; 147 | 148 | int kind = Int_val(socket_kind); 149 | assert (kind >= ZMQ_PAIR && kind <= ZMQ_STREAM); 150 | 151 | socket = zmq_socket(CAML_ZMQ_Context_val(ctx), socket_type_for_kind[kind]); 152 | caml_zmq_raise_if(socket == NULL, "zmq_socket"); 153 | sock_value = caml_zmq_copy_socket(socket); 154 | CAMLreturn (sock_value); 155 | } 156 | 157 | /** 158 | * Close 159 | */ 160 | 161 | CAMLprim value caml_zmq_close(value socket) { 162 | CAMLparam1 (socket); 163 | int result = zmq_close(CAML_ZMQ_Socket_val(socket)); 164 | caml_zmq_raise_if(result == -1, "zmq_close"); 165 | CAML_ZMQ_Socket_val(socket) = NULL; 166 | CAMLreturn (Val_unit); 167 | } 168 | 169 | /** 170 | * Set socket options 171 | */ 172 | 173 | static int const native_int64_option_for[] = { 174 | ZMQ_AFFINITY, 175 | ZMQ_MAXMSGSIZE 176 | }; 177 | 178 | CAMLprim value caml_zmq_set_int64_option(value socket, value option_name, value socket_option) { 179 | CAMLparam3 (socket, option_name, socket_option); 180 | 181 | int64_t val = Long_val(socket_option); 182 | int result = zmq_setsockopt(CAML_ZMQ_Socket_val(socket), 183 | native_int64_option_for[Int_val(option_name)], 184 | &val, 185 | sizeof(val)); 186 | 187 | 188 | caml_zmq_raise_if(result == -1, "zmq_setsockopt"); 189 | CAMLreturn (Val_unit); 190 | } 191 | 192 | static int const native_bytes_option_for[] = { 193 | ZMQ_IDENTITY, 194 | ZMQ_SUBSCRIBE, 195 | ZMQ_UNSUBSCRIBE, 196 | ZMQ_LAST_ENDPOINT, 197 | ZMQ_TCP_ACCEPT_FILTER, 198 | ZMQ_PLAIN_USERNAME, 199 | ZMQ_PLAIN_PASSWORD, 200 | ZMQ_CURVE_PUBLICKEY, 201 | ZMQ_CURVE_SECRETKEY, 202 | ZMQ_CURVE_SERVERKEY, 203 | ZMQ_ZAP_DOMAIN, 204 | }; 205 | 206 | CAMLprim value caml_zmq_set_string_option(value socket, value option_name, value socket_option) { 207 | CAMLparam3 (socket, option_name, socket_option); 208 | 209 | const char *option_value = String_val(socket_option); 210 | size_t option_size = caml_string_length(socket_option); 211 | int result = zmq_setsockopt(CAML_ZMQ_Socket_val(socket), 212 | native_bytes_option_for[Int_val(option_name)], 213 | option_value, 214 | option_size); 215 | 216 | caml_zmq_raise_if(result == -1, "zmq_setsockopt"); 217 | CAMLreturn (Val_unit); 218 | } 219 | 220 | static int const native_int_option_for[] = { 221 | ZMQ_RATE, 222 | ZMQ_RECOVERY_IVL, 223 | ZMQ_SNDBUF, 224 | ZMQ_RCVBUF, 225 | ZMQ_RCVMORE, 226 | ZMQ_EVENTS, 227 | ZMQ_TYPE, 228 | ZMQ_LINGER, 229 | ZMQ_RECONNECT_IVL, 230 | ZMQ_BACKLOG, 231 | ZMQ_RECONNECT_IVL_MAX, 232 | ZMQ_SNDHWM, 233 | ZMQ_RCVHWM, 234 | ZMQ_MULTICAST_HOPS, 235 | ZMQ_RCVTIMEO, 236 | ZMQ_SNDTIMEO, 237 | ZMQ_IPV6, 238 | ZMQ_ROUTER_MANDATORY, 239 | ZMQ_TCP_KEEPALIVE, 240 | ZMQ_TCP_KEEPALIVE_CNT, 241 | ZMQ_TCP_KEEPALIVE_IDLE, 242 | ZMQ_TCP_KEEPALIVE_INTVL, 243 | ZMQ_IMMEDIATE, 244 | ZMQ_XPUB_VERBOSE, 245 | ZMQ_MECHANISM, 246 | ZMQ_PLAIN_SERVER, 247 | ZMQ_CURVE_SERVER, 248 | ZMQ_PROBE_ROUTER, 249 | ZMQ_REQ_CORRELATE, 250 | ZMQ_REQ_RELAXED, 251 | ZMQ_CONFLATE, 252 | ZMQ_STREAM_NOTIFY 253 | }; 254 | 255 | CAMLprim value caml_zmq_set_int_option(value socket, value option_name, value socket_option) { 256 | CAMLparam3 (socket, option_name, socket_option); 257 | 258 | int val = Int_val(socket_option); 259 | int result = zmq_setsockopt(CAML_ZMQ_Socket_val(socket), 260 | native_int_option_for[Int_val(option_name)], 261 | &val, 262 | sizeof(val)); 263 | 264 | caml_zmq_raise_if(result == -1, "zmq_setsockopt"); 265 | CAMLreturn (Val_unit); 266 | } 267 | 268 | /** 269 | * Get socket options 270 | */ 271 | 272 | CAMLprim value caml_zmq_get_int64_option(value socket, value option_name) { 273 | CAMLparam2 (socket, option_name); 274 | int64_t mark; 275 | size_t mark_size = sizeof (mark); 276 | int result = zmq_getsockopt (CAML_ZMQ_Socket_val(socket), 277 | native_int64_option_for[Int_val(option_name)], 278 | &mark, 279 | &mark_size); 280 | caml_zmq_raise_if(result == -1, "zmq_getsockopt"); 281 | CAMLreturn (Val_long(mark)); 282 | } 283 | 284 | CAMLprim value caml_zmq_get_string_option(value socket, value option_name, value option_maxlen) { 285 | CAMLparam3 (socket, option_name, option_maxlen); 286 | char buffer[256]; 287 | size_t buffer_size = Unsigned_long_val(option_maxlen); 288 | assert(buffer_size < sizeof (buffer)); 289 | int result = zmq_getsockopt (CAML_ZMQ_Socket_val(socket), 290 | native_bytes_option_for[Int_val(option_name)], 291 | buffer, 292 | &buffer_size); 293 | caml_zmq_raise_if(result == -1, "zmq_getsockopt"); 294 | buffer[buffer_size] = '\0'; 295 | CAMLreturn (caml_copy_string(buffer)); 296 | } 297 | 298 | CAMLprim value caml_zmq_get_int_option(value socket, value option_name) { 299 | CAMLparam2 (socket, option_name); 300 | int mark; 301 | size_t mark_size = sizeof (mark); 302 | int result = zmq_getsockopt (CAML_ZMQ_Socket_val(socket), 303 | native_int_option_for[Int_val(option_name)], 304 | &mark, 305 | &mark_size); 306 | caml_zmq_raise_if(result == -1, "zmq_getsockopt"); 307 | CAMLreturn (Val_int(mark)); 308 | } 309 | 310 | CAMLprim value caml_zmq_get_events(value socket) { 311 | CAMLparam1 (socket); 312 | uint32_t event = 0; 313 | size_t event_size = sizeof (event); 314 | int result = zmq_getsockopt (CAML_ZMQ_Socket_val(socket), 315 | ZMQ_EVENTS, 316 | &event, 317 | &event_size); 318 | caml_zmq_raise_if(result == -1, "zmq_getsockopt"); 319 | int event_type = 0; /* No_event */ 320 | if (event & ZMQ_POLLIN) { 321 | event_type = 1; /* Poll_in */ 322 | if (event & ZMQ_POLLOUT) { 323 | event_type = 3; /* Poll_in_out */ 324 | } 325 | } else if (event & ZMQ_POLLOUT) { 326 | event_type = 2; /* Poll_out */ 327 | } else if (event & ZMQ_POLLERR) { 328 | event_type = 4; /* Poll_error */ 329 | } 330 | CAMLreturn (Val_int(event_type)); 331 | } 332 | 333 | CAMLprim value caml_zmq_get_fd(value socket) { 334 | CAMLparam1 (socket); 335 | fd_type fd; 336 | size_t mark_size = sizeof (fd); 337 | int result = zmq_getsockopt (CAML_ZMQ_Socket_val(socket), 338 | ZMQ_FD, 339 | (void *)&fd, 340 | &mark_size); 341 | caml_zmq_raise_if(result == -1, "zmq_getsockopt"); 342 | CAMLreturn (Val_fd(fd)); 343 | } 344 | 345 | 346 | 347 | /** 348 | * Connect 349 | */ 350 | CAMLprim value caml_zmq_connect(value socket, value string_address) { 351 | CAMLparam2 (socket, string_address); 352 | int result = zmq_connect(CAML_ZMQ_Socket_val(socket), String_val(string_address)); 353 | caml_zmq_raise_if(result == -1, "zmq_connect"); 354 | CAMLreturn(Val_unit); 355 | } 356 | 357 | /** 358 | * Disconnect 359 | */ 360 | CAMLprim value caml_zmq_disconnect(value socket, value string_address) { 361 | CAMLparam2 (socket, string_address); 362 | int result = zmq_disconnect(CAML_ZMQ_Socket_val(socket), String_val(string_address)); 363 | caml_zmq_raise_if(result == -1, "zmq_disconnect"); 364 | CAMLreturn(Val_unit); 365 | } 366 | 367 | /** 368 | * Bind 369 | */ 370 | CAMLprim value caml_zmq_bind(value socket, value string_address) { 371 | CAMLparam2 (socket, string_address); 372 | int result = zmq_bind(CAML_ZMQ_Socket_val(socket), String_val(string_address)); 373 | caml_zmq_raise_if(result == -1, "zmq_bind"); 374 | CAMLreturn(Val_unit); 375 | } 376 | 377 | /** 378 | * Unbind 379 | */ 380 | CAMLprim value caml_zmq_unbind(value socket, value string_address) { 381 | CAMLparam2 (socket, string_address); 382 | int result = zmq_unbind(CAML_ZMQ_Socket_val(socket), String_val(string_address)); 383 | caml_zmq_raise_if(result == -1, "zmq_unbind"); 384 | CAMLreturn(Val_unit); 385 | } 386 | 387 | 388 | /** 389 | * Send 390 | */ 391 | CAMLprim value caml_zmq_send(value socket, value string, value block_flag, value more_flag) { 392 | CAMLparam4 (socket, string, block_flag, more_flag); 393 | 394 | int option = 0; 395 | if (! Bool_val(block_flag)) option |= ZMQ_NOBLOCK; 396 | if (Bool_val(more_flag)) option |= ZMQ_SNDMORE; 397 | 398 | void *sock = CAML_ZMQ_Socket_val(socket); 399 | zmq_msg_t msg; 400 | int length = caml_string_length(string); 401 | int result = zmq_msg_init_size(&msg, length); 402 | caml_zmq_raise_if(result == -1, "zmq_msg_init_size"); 403 | 404 | /* Doesn't copy '\0' */ 405 | memcpy ((void *) zmq_msg_data (&msg), String_val(string), length); 406 | 407 | caml_release_runtime_system(); 408 | result = zmq_msg_send(&msg, sock, option); 409 | caml_acquire_runtime_system(); 410 | 411 | int errno; 412 | if (result == -1) { 413 | errno = zmq_errno(); 414 | zmq_msg_close (&msg); 415 | caml_zmq_raise(errno, zmq_strerror(errno), "zmq_msg_send"); 416 | } 417 | int close_result = zmq_msg_close (&msg); 418 | caml_zmq_raise_if(close_result == -1, "zmq_msg_close"); 419 | 420 | CAMLreturn(Val_unit); 421 | } 422 | 423 | /** 424 | * Receive 425 | */ 426 | CAMLprim value caml_zmq_recv(value socket, value block_flag) { 427 | CAMLparam2 (socket, block_flag); 428 | CAMLlocal1 (message); 429 | 430 | int option = 0; 431 | if (!Bool_val(block_flag)) option |= ZMQ_NOBLOCK; 432 | 433 | void *sock = CAML_ZMQ_Socket_val(socket); 434 | 435 | zmq_msg_t msg; 436 | int result = zmq_msg_init (&msg); 437 | caml_zmq_raise_if(result == -1, "zmq_msg_init"); 438 | 439 | caml_release_runtime_system(); 440 | result = zmq_msg_recv(&msg, sock, option); 441 | caml_acquire_runtime_system(); 442 | 443 | int errno; 444 | if (result == -1) { 445 | errno = zmq_errno(); 446 | zmq_msg_close (&msg); 447 | caml_zmq_raise(errno, zmq_strerror(errno), "zmq_msg_recv"); 448 | } 449 | 450 | size_t size = zmq_msg_size (&msg); 451 | /* in the future (when we support a minimum of OCaml 4.06) this can be simplified to 452 | 453 | message = caml_alloc_initialized_string(size, zmq_msg_data (&msg)); 454 | 455 | * but in the meantime, we need to cast the pointer. This is legal because we control 456 | * the string value. */ 457 | message = caml_alloc_string(size); 458 | memcpy((char *)String_val(message), zmq_msg_data (&msg), size); 459 | result = zmq_msg_close(&msg); 460 | caml_zmq_raise_if(result == -1, "zmq_msg_close"); 461 | CAMLreturn (message); 462 | } 463 | 464 | 465 | /** 466 | * msg values 467 | */ 468 | void caml_zmq_remove_generational_global_root(void *data __attribute__((unused)), void *hint) { 469 | CAMLparam0(); 470 | caml_remove_generational_global_root(hint); 471 | CAMLreturn0; 472 | } 473 | 474 | /** 475 | * Send msg 476 | */ 477 | CAMLprim value caml_zmq_send_msg(value socket, value msg, value block_flag, value more_flag) { 478 | CAMLparam4 (socket, msg, block_flag, more_flag); 479 | 480 | int option = 0; 481 | if (! Bool_val(block_flag)) option |= ZMQ_NOBLOCK; 482 | if (Bool_val(more_flag)) option |= ZMQ_SNDMORE; 483 | 484 | void *sock = CAML_ZMQ_Socket_val(socket); 485 | zmq_msg_t *cmsg; 486 | cmsg = (zmq_msg_t *)CAML_ZMQ_Msg_val(msg); 487 | 488 | caml_release_runtime_system(); 489 | int result = zmq_msg_send(cmsg, sock, option); 490 | caml_acquire_runtime_system(); 491 | 492 | int errno; 493 | if (result == -1) { 494 | errno = zmq_errno(); 495 | caml_zmq_raise(errno, zmq_strerror(errno), "zmq_msg_send"); 496 | } 497 | 498 | CAMLreturn(Val_unit); 499 | } 500 | 501 | /** 502 | * Receive msg 503 | */ 504 | CAMLprim value caml_zmq_recv_msg(value socket, value block_flag) { 505 | CAMLparam2(socket, block_flag); 506 | 507 | int option = 0; 508 | if (!Bool_val(block_flag)) option |= ZMQ_NOBLOCK; 509 | 510 | void *sock = CAML_ZMQ_Socket_val(socket); 511 | 512 | zmq_msg_t *msg; 513 | msg = (zmq_msg_t *)malloc(sizeof(zmq_msg_t)); 514 | int result = zmq_msg_init (msg); 515 | 516 | int errno; 517 | if (result == -1) { 518 | errno = zmq_errno(); 519 | free(msg); 520 | caml_zmq_raise(errno, zmq_strerror(errno), "zmq_msg_init"); 521 | } 522 | 523 | caml_release_runtime_system(); 524 | result = zmq_msg_recv(msg, sock, option); 525 | caml_acquire_runtime_system(); 526 | 527 | if (result == -1) { 528 | errno = zmq_errno(); 529 | zmq_msg_close (msg); 530 | free(msg); 531 | caml_zmq_raise(errno, zmq_strerror(errno), "zmq_msg_recv"); 532 | } 533 | 534 | CAMLreturn (caml_zmq_copy_msg(msg)); 535 | } 536 | 537 | 538 | /** 539 | * Msg values 540 | */ 541 | CAMLprim value caml_zmq_msg_init_data(value ba, value offset, value len) { 542 | CAMLparam3(ba, offset, len); 543 | CAMLlocal1(msg); 544 | 545 | zmq_msg_t *cmsg; 546 | cmsg = (zmq_msg_t *)malloc(sizeof(zmq_msg_t)); 547 | 548 | caml_register_generational_global_root(&ba); 549 | int result = zmq_msg_init_data(cmsg, (char*)Caml_ba_data_val(ba) + Int_val(offset), Int_val(len), (void *)caml_zmq_remove_generational_global_root, (void *)ba); 550 | 551 | int errno; 552 | if (result == -1) { 553 | errno = zmq_errno(); 554 | zmq_msg_close(cmsg); 555 | free(cmsg); 556 | caml_zmq_raise(errno, zmq_strerror(errno), "zmq_msg_init_data"); 557 | } 558 | 559 | CAMLreturn(caml_zmq_copy_msg(cmsg)); 560 | } 561 | 562 | CAMLprim value caml_zmq_msg_size(value msg) { 563 | CAMLparam1(msg); 564 | CAMLreturn(Val_int(zmq_msg_size(CAML_ZMQ_Msg_val(msg)))); 565 | } 566 | 567 | CAMLprim value caml_zmq_msg_data(value msg) { 568 | CAMLparam1(msg); 569 | CAMLlocal1(data); 570 | data = caml_ba_alloc_dims(CAML_BA_UINT8 | CAML_BA_C_LAYOUT | CAML_BA_EXTERNAL, 571 | 1, 572 | zmq_msg_data(CAML_ZMQ_Msg_val(msg)), 573 | zmq_msg_size(CAML_ZMQ_Msg_val(msg))); 574 | CAMLreturn(data); 575 | } 576 | 577 | CAMLprim value caml_zmq_msg_close(value msg) { 578 | CAMLparam1(msg); 579 | zmq_msg_close(CAML_ZMQ_Msg_val(msg)); 580 | CAMLreturn(Val_unit); 581 | } 582 | 583 | CAMLprim value caml_zmq_msg_gets(value msg, value property) { 584 | CAMLparam2(msg, property); 585 | CAMLlocal1(result); 586 | const char *r = zmq_msg_gets(CAML_ZMQ_Msg_val(msg), String_val(property)); 587 | caml_zmq_raise_if(!r, "zmq_msg_gets"); 588 | result = caml_copy_string(r); 589 | CAMLreturn(result); 590 | } 591 | 592 | 593 | /** 594 | * Devices 595 | */ 596 | 597 | CAMLprim value caml_zmq_proxy2(value frontend, value backend) { 598 | CAMLparam2 (frontend, backend); 599 | 600 | void *native_frontend = CAML_ZMQ_Socket_val(frontend); 601 | void *native_backend = CAML_ZMQ_Socket_val(backend); 602 | 603 | caml_release_runtime_system(); 604 | int result = zmq_proxy(native_frontend, native_backend, NULL); 605 | caml_acquire_runtime_system(); 606 | 607 | caml_zmq_raise_if(result == -1, "zmq_proxy"); 608 | CAMLreturn (Val_unit); 609 | } 610 | 611 | CAMLprim value caml_zmq_proxy3(value frontend, value backend, value capture) { 612 | CAMLparam3 (frontend, backend, capture); 613 | 614 | void *native_frontend = CAML_ZMQ_Socket_val(frontend); 615 | void *native_backend = CAML_ZMQ_Socket_val(backend); 616 | void *native_capture = CAML_ZMQ_Socket_val(capture); 617 | 618 | caml_release_runtime_system(); 619 | int result = zmq_proxy(native_frontend, native_backend, native_capture); 620 | caml_acquire_runtime_system(); 621 | 622 | caml_zmq_raise_if(result == -1, "zmq_proxy"); 623 | CAMLreturn (Val_unit); 624 | } 625 | 626 | CAMLprim value caml_zmq_socket_monitor(value socket, value address) { 627 | CAMLparam2 (socket, address); 628 | 629 | caml_release_runtime_system(); 630 | int result = zmq_socket_monitor(CAML_ZMQ_Socket_val(socket), String_val(address), ZMQ_EVENT_ALL); 631 | caml_acquire_runtime_system(); 632 | 633 | caml_zmq_raise_if(result == -1, "zmq_socket_monitor"); 634 | CAMLreturn (Val_unit); 635 | } 636 | 637 | enum event_type { 638 | CONNECTED = 0, 639 | CONNECT_DELAYED, 640 | CONNECT_RETRIED, 641 | LISTENING, 642 | BIND_FAILED, 643 | ACCEPTED, 644 | ACCEPT_FAILED, 645 | CLOSED, 646 | CLOSE_FAILED, 647 | DISCONNECTED, 648 | MONITOR_STOPPED, 649 | HANDSHAKE_FAILED_NO_DETAIL, 650 | HANDSHAKE_SUCCEEDED, 651 | HANDSHAKE_FAILED_PROTOCOL, 652 | HANDSHAKE_FAILED_AUTH 653 | }; 654 | 655 | /** Decode monitor event */ 656 | CAMLprim value caml_decode_monitor_event(value event_val, value addr) { 657 | CAMLparam2 (event_val, addr); 658 | CAMLlocal1 (result); 659 | 660 | const char *data = String_val(event_val); 661 | const uint16_t *event = (const uint16_t *)data; 662 | const int32_t *param = (const int32_t *)(data + 2); 663 | 664 | switch (*event) { 665 | case ZMQ_EVENT_CONNECTED: 666 | result = caml_alloc(2, CONNECTED); 667 | Store_field(result, 0, addr); 668 | Store_field(result, 1, Val_fd(*param)); 669 | break; 670 | 671 | case ZMQ_EVENT_CONNECT_DELAYED: 672 | result = caml_alloc(1, CONNECT_DELAYED); 673 | Store_field(result, 0, addr); 674 | break; 675 | 676 | case ZMQ_EVENT_CONNECT_RETRIED: 677 | result = caml_alloc(2, CONNECT_RETRIED); 678 | Store_field(result, 0, addr); 679 | Store_field(result, 1, Val_int(*param)); 680 | break; 681 | 682 | case ZMQ_EVENT_LISTENING: 683 | result = caml_alloc(2, LISTENING); 684 | Store_field(result, 0, addr); 685 | Store_field(result, 1, Val_fd(*param)); 686 | break; 687 | 688 | case ZMQ_EVENT_BIND_FAILED: 689 | result = caml_alloc(3, BIND_FAILED); 690 | Store_field(result, 0, addr); 691 | Store_field(result, 1, Val_int(*param)); 692 | Store_field(result, 2, caml_copy_string(zmq_strerror(*param))); 693 | break; 694 | 695 | case ZMQ_EVENT_ACCEPTED: 696 | result = caml_alloc(2, ACCEPTED); 697 | Store_field(result, 0, addr); 698 | Store_field(result, 1, Val_fd(*param)); 699 | break; 700 | 701 | case ZMQ_EVENT_ACCEPT_FAILED: 702 | result = caml_alloc(3, ACCEPT_FAILED); 703 | Store_field(result, 0, addr); 704 | Store_field(result, 1, Val_int(*param)); 705 | Store_field(result, 2, caml_copy_string(zmq_strerror(*param))); 706 | break; 707 | 708 | case ZMQ_EVENT_CLOSED: 709 | result = caml_alloc(2, CLOSED); 710 | Store_field(result, 0, addr); 711 | Store_field(result, 1, Val_fd(*param)); 712 | break; 713 | 714 | case ZMQ_EVENT_CLOSE_FAILED: 715 | result = caml_alloc(3, CLOSE_FAILED); 716 | Store_field(result, 0, addr); 717 | Store_field(result, 1, Val_int(*param)); 718 | Store_field(result, 2, caml_copy_string(zmq_strerror(*param))); 719 | break; 720 | 721 | case ZMQ_EVENT_DISCONNECTED: 722 | result = caml_alloc(2, DISCONNECTED); 723 | Store_field(result, 0, addr); 724 | Store_field(result, 1, Val_fd(*param)); 725 | break; 726 | 727 | #if ZMQ_VERSION_MINOR >= 3 728 | case ZMQ_EVENT_MONITOR_STOPPED: 729 | result = caml_alloc(1, MONITOR_STOPPED); 730 | Store_field(result, 0, addr); 731 | break; 732 | 733 | case ZMQ_EVENT_HANDSHAKE_FAILED_NO_DETAIL: 734 | result = caml_alloc(1, HANDSHAKE_FAILED_NO_DETAIL); 735 | Store_field(result, 0, addr); 736 | break; 737 | 738 | case ZMQ_EVENT_HANDSHAKE_SUCCEEDED: 739 | result = caml_alloc(1, HANDSHAKE_SUCCEEDED); 740 | Store_field(result, 0, addr); 741 | break; 742 | 743 | case ZMQ_EVENT_HANDSHAKE_FAILED_PROTOCOL: 744 | result = caml_alloc(2, HANDSHAKE_FAILED_PROTOCOL); 745 | Store_field(result, 0, addr); 746 | Store_field(result, 1, Val_fd(*param)); 747 | break; 748 | 749 | case ZMQ_EVENT_HANDSHAKE_FAILED_AUTH: 750 | result = caml_alloc(2, HANDSHAKE_FAILED_AUTH); 751 | Store_field(result, 0, addr); 752 | Store_field(result, 1, Val_fd(*param)); 753 | break; 754 | #endif 755 | default: 756 | caml_invalid_argument("Unknown event type"); 757 | break; 758 | } 759 | CAMLreturn(result); 760 | } 761 | 762 | /** 763 | * Z85 764 | */ 765 | 766 | CAMLprim value caml_z85_encode(value source) { 767 | CAMLparam1 (source); 768 | CAMLlocal1 (result); 769 | 770 | /* 771 | * zmq_z85_encode writes a null terminator. However, OCaml does not 772 | * need a null terminator. The code below does not allocate space for 773 | * a null terminator, but zmq_z85_encode will not encounter an overrun, 774 | * as OCaml string representation guarantees that one byte past the 775 | * end of string is allocated and contains '\0'. 776 | * 777 | * See http://caml.inria.fr/pub/docs/oreilly-book/html/book-ora115.html#@concepts266 778 | * for details. 779 | */ 780 | int length = caml_string_length(source); 781 | result = caml_alloc_string(length / 4 * 5); 782 | if (zmq_z85_encode((char *)String_val(result), (uint8_t*) String_val(source), length) == NULL) 783 | caml_invalid_argument("zmq_z85_encode"); 784 | 785 | CAMLreturn(result); 786 | } 787 | 788 | CAMLprim value caml_z85_decode(value source) { 789 | CAMLparam1 (source); 790 | CAMLlocal1 (result); 791 | 792 | result = caml_alloc_string(caml_string_length(source) * 4 / 5); 793 | if (zmq_z85_decode((uint8_t*) String_val(result), String_val(source)) == NULL) 794 | caml_invalid_argument("zmq_z85_decode"); 795 | 796 | CAMLreturn(result); 797 | } 798 | 799 | /** 800 | * Key generation 801 | */ 802 | 803 | CAMLprim value caml_curve_keypair(value unit) { 804 | CAMLparam1 (unit); 805 | CAMLlocal3 (public, secret, tuple); 806 | 807 | /* See the notice in caml_z85_encode. */ 808 | public = caml_alloc_string(40); 809 | secret = caml_alloc_string(40); 810 | int result = zmq_curve_keypair((char *)String_val(public), (char *)String_val(secret)); 811 | caml_zmq_raise_if(result == -1, "zmq_curve_keypair"); 812 | 813 | tuple = caml_alloc_tuple(2); 814 | Store_field(tuple, 0, public); 815 | Store_field(tuple, 1, secret); 816 | CAMLreturn (tuple); 817 | } 818 | -------------------------------------------------------------------------------- /zmq/src/config/discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let () = 4 | C.main ~name:"zmq" (fun c -> 5 | let default : C.Pkg_config.package_conf = { 6 | libs = ["-lzmq"]; 7 | cflags = [] 8 | } in 9 | let conf = 10 | match C.Pkg_config.get c with 11 | | None -> default 12 | | Some pc -> 13 | begin match C.Pkg_config.query pc ~package:"libzmq" with 14 | | Some s -> s 15 | | None -> default 16 | end 17 | in 18 | C.Flags.write_sexp "c_flags.sexp" conf.cflags; 19 | C.Flags.write_sexp "c_library_flags.sexp" conf.libs) 20 | -------------------------------------------------------------------------------- /zmq/src/config/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (libraries dune.configurator)) 4 | -------------------------------------------------------------------------------- /zmq/src/context.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #include "context.h" 6 | 7 | #include 8 | #include 9 | 10 | #include 11 | 12 | static void custom_finalize_context(value context) { 13 | if (CAML_ZMQ_Context_val(context)) { 14 | fprintf(stderr, "Error: Context not closed before finalization\n"); 15 | } 16 | } 17 | 18 | static struct custom_operations caml_zmq_context_ops = { 19 | "org.zeromq.context", 20 | custom_finalize_context, 21 | custom_compare_default, 22 | custom_hash_default, 23 | custom_serialize_default, 24 | custom_deserialize_default 25 | #ifdef custom_compare_ext_default 26 | , custom_compare_ext_default 27 | #endif 28 | #ifdef custom_fixed_length_default 29 | , custom_fixed_length_default 30 | #endif 31 | }; 32 | 33 | value caml_zmq_copy_context(void *zmq_context) { 34 | CAMLparam0 (); 35 | CAMLlocal1 (context); 36 | context = caml_alloc_custom(&caml_zmq_context_ops, sizeof (zmq_context), 0, 1); 37 | CAML_ZMQ_Context_val(context) = zmq_context; 38 | CAMLreturn (context); 39 | } 40 | -------------------------------------------------------------------------------- /zmq/src/context.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #ifndef CAML_ZMQ_CONTEXT_H_ 6 | #define CAML_ZMQ_CONTEXT_H_ 7 | 8 | #include 9 | 10 | #define CAML_ZMQ_Context_val(v) (*((void **) Data_custom_val(v))) 11 | 12 | value caml_zmq_copy_context(void *zmq_context); 13 | 14 | #endif /* CAML_ZMQ_CONTEXT_H_ */ 15 | -------------------------------------------------------------------------------- /zmq/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name zmq) 3 | (public_name zmq) 4 | (wrapped false) 5 | (foreign_stubs 6 | (language c) 7 | (names caml_zmq_stubs socket context fail poll msg) 8 | (flags 9 | (:include c_flags.sexp) 10 | -Wall 11 | -Wextra 12 | -O2)) 13 | (c_library_flags 14 | (:include c_library_flags.sexp)) 15 | (libraries unix bigarray)) 16 | 17 | (rule 18 | (targets c_flags.sexp c_library_flags.sexp) 19 | (deps 20 | (:discover config/discover.exe)) 21 | (action 22 | (run %{discover}))) 23 | -------------------------------------------------------------------------------- /zmq/src/fail.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #include "fail.h" 6 | 7 | #include 8 | 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | /* This table must be synchronized with Zmq.internal_error. */ 16 | static int const caml_zmq_error_table[] = { 17 | ENOTSUP, 18 | EPROTONOSUPPORT, 19 | ENOBUFS, 20 | ENETDOWN, 21 | EADDRINUSE, 22 | EADDRNOTAVAIL, 23 | ECONNREFUSED, 24 | EINPROGRESS, 25 | ENOTSOCK, 26 | EMSGSIZE, 27 | EAFNOSUPPORT, 28 | ENETUNREACH, 29 | ECONNABORTED, 30 | ECONNRESET, 31 | ENOTCONN, 32 | ETIMEDOUT, 33 | EHOSTUNREACH, 34 | ENETRESET, 35 | EFSM, 36 | ENOCOMPATPROTO, 37 | ETERM, 38 | EMTHREAD, 39 | }; 40 | 41 | /* This must be the last value of the variant. */ 42 | static int const caml_zmq_EUNKNOWN = 43 | (sizeof caml_zmq_error_table) / (sizeof caml_zmq_error_table[0]); 44 | 45 | void caml_zmq_raise(int err_no, const char *err_str, const char *name) { 46 | CAMLparam0 (); 47 | 48 | /* err_no can be a standard Unix error code, or it can be a ZMQ-defined 49 | * error code in the range above ZMQ_HAUSNUMERO. If the system headers are 50 | * missing certain Unix codes, they get redefined in zmq.h with a number 51 | * above ZMQ_HAUSNUMERO. That range also contains new ZMQ-specific error 52 | * codes. 53 | */ 54 | if (err_no < ZMQ_HAUSNUMERO) { 55 | unix_error(err_no, (char *) name, Nothing); 56 | 57 | } else { 58 | int error_to_raise = caml_zmq_EUNKNOWN; 59 | int i; 60 | for (i = 0; i < caml_zmq_EUNKNOWN; i++) { 61 | if (err_no == caml_zmq_error_table[i]) { 62 | error_to_raise = i; 63 | break; 64 | } 65 | } 66 | /* From http://caml.inria.fr/pub/docs/manual-ocaml-4.01/intfc.html#sec439: 67 | 68 | If the function f does not return, but raises an exception that 69 | escapes the scope of the application, then this exception is 70 | propagated to the next enclosing OCaml code, skipping over the C 71 | code. That is, if an OCaml function f calls a C function g that calls 72 | back an OCaml function h that raises a stray exception, then the 73 | execution of g is interrupted and the exception is propagated back 74 | into f. 75 | */ 76 | 77 | caml_callback3(*caml_named_value("Zmq.zmq_raise"), 78 | Val_int(error_to_raise), 79 | caml_copy_string(err_str), 80 | caml_copy_string(name) 81 | ); 82 | } 83 | 84 | CAMLreturn0; 85 | } 86 | 87 | void caml_zmq_raise_if(int condition, const char *location) { 88 | if (condition) { 89 | int err_no = zmq_errno(); 90 | const char *err_str = zmq_strerror(err_no); 91 | caml_zmq_raise(err_no, err_str, location); 92 | } 93 | } 94 | -------------------------------------------------------------------------------- /zmq/src/fail.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #ifndef CAML_ZMQ_FAIL_H_ 6 | #define CAML_ZMQ_FAIL_H_ 7 | 8 | void caml_zmq_raise(int err_no, const char *err_str, const char *name); 9 | void caml_zmq_raise_if(int condition, const char *name); 10 | 11 | #endif /* CAML_ZMQ_FAIL_H_ */ 12 | -------------------------------------------------------------------------------- /zmq/src/msg.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #include "msg.h" 6 | 7 | #include 8 | #include 9 | 10 | #include 11 | 12 | static void custom_finalize_msg(value msg) { 13 | if (CAML_ZMQ_Msg_val(msg)) { 14 | zmq_msg_close(CAML_ZMQ_Msg_val(msg)); 15 | free(CAML_ZMQ_Msg_val(msg)); 16 | CAML_ZMQ_Msg_val(msg) = NULL; 17 | } 18 | } 19 | 20 | static struct custom_operations caml_zmq_msg_ops = { 21 | "org.zeromq.msg", 22 | custom_finalize_msg, 23 | custom_compare_default, 24 | custom_hash_default, 25 | custom_serialize_default, 26 | custom_deserialize_default 27 | #ifdef custom_compare_ext_default 28 | , custom_compare_ext_default 29 | #endif 30 | #ifdef custom_fixed_length_default 31 | , custom_fixed_length_default 32 | #endif 33 | }; 34 | 35 | value caml_zmq_copy_msg(void *zmq_msg) { 36 | CAMLparam0 (); 37 | CAMLlocal1 (msg); 38 | msg = caml_alloc_custom(&caml_zmq_msg_ops, sizeof (zmq_msg), 0, 1); 39 | CAML_ZMQ_Msg_val(msg) = zmq_msg; 40 | CAMLreturn (msg); 41 | } 42 | -------------------------------------------------------------------------------- /zmq/src/msg.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #ifndef CAML_ZMQ_MSG_H_ 6 | #define CAML_ZMQ_MSG_H_ 7 | 8 | #include 9 | 10 | #define CAML_ZMQ_Msg_val(v) (*((void **) Data_custom_val(v))) 11 | 12 | value caml_zmq_copy_msg(void *zmq_msg); 13 | 14 | #endif /* CAML_ZMQ_MSG_H_ */ 15 | 16 | -------------------------------------------------------------------------------- /zmq/src/poll.c: -------------------------------------------------------------------------------- 1 | #include "poll.h" 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | #include "fail.h" 11 | #include "socket.h" 12 | 13 | #include 14 | 15 | static void custom_finalize_poll(value poll) { 16 | free(CAML_ZMQ_Poll_val(poll)->poll_items); 17 | } 18 | 19 | static struct custom_operations caml_zmq_poll_ops = { 20 | "org.zeromq.poll", 21 | custom_finalize_poll, 22 | custom_compare_default, 23 | custom_hash_default, 24 | custom_serialize_default, 25 | custom_deserialize_default 26 | #ifdef custom_compare_ext_default 27 | , custom_compare_ext_default 28 | #endif 29 | #ifdef custom_fixed_length_default 30 | , custom_fixed_length_default 31 | #endif 32 | }; 33 | 34 | CAMLprim value caml_zmq_poll_of_pollitem_array(value pollitem_array) { 35 | CAMLparam1 (pollitem_array); 36 | CAMLlocal2 (poll, current_elem); 37 | 38 | int n = Wosize_val(pollitem_array); 39 | zmq_pollitem_t *items = malloc(sizeof(zmq_pollitem_t) * n); 40 | if (items == NULL) { 41 | unix_error(ENOMEM, "malloc", Nothing); 42 | } 43 | int i; 44 | for(i = 0; i < n; i++) { 45 | current_elem = Field(pollitem_array, i); 46 | items[i].socket = CAML_ZMQ_Socket_val(Field(current_elem, 0)); 47 | items[i].events = CAML_ZMQ_Mask_val(Field(current_elem, 1)); 48 | } 49 | 50 | poll= caml_alloc_custom(&caml_zmq_poll_ops, 51 | sizeof(struct caml_zmq_poll), 52 | 0, 1); 53 | CAML_ZMQ_Poll_val(poll)->num_elems = n; 54 | CAML_ZMQ_Poll_val(poll)->poll_items = items; 55 | CAMLreturn (poll); 56 | } 57 | 58 | /* Sync with variant declaration */ 59 | enum caml_zmq_event_mask { 60 | In = 0, 61 | Out, 62 | In_out 63 | }; 64 | 65 | value CAML_ZMQ_Val_mask(short mask) { 66 | if(mask & ZMQ_POLLIN) { 67 | if(mask & ZMQ_POLLOUT) { 68 | return Val_int(In_out); 69 | } 70 | return Val_int(In); 71 | } 72 | if(mask & ZMQ_POLLOUT) { 73 | return Val_int(Out); 74 | } 75 | 76 | abort(); /* unreachable */ 77 | } 78 | 79 | short CAML_ZMQ_Mask_val (value mask) { 80 | switch(Int_val(mask)) { 81 | case In: return ZMQ_POLLIN; 82 | case Out: return ZMQ_POLLOUT; 83 | case In_out: return ZMQ_POLLOUT | ZMQ_POLLIN; 84 | } 85 | 86 | abort(); /* unreachable */ 87 | } 88 | 89 | CAMLprim value caml_zmq_poll(value poll, value timeout) { 90 | CAMLparam2 (poll, timeout); 91 | CAMLlocal2 (events, some); 92 | 93 | int n = CAML_ZMQ_Poll_val(poll)->num_elems; 94 | zmq_pollitem_t *items = CAML_ZMQ_Poll_val(poll)->poll_items; 95 | int tm = Int_val(timeout); 96 | 97 | caml_release_runtime_system(); 98 | int num_event_sockets = zmq_poll(items, n, tm); 99 | caml_acquire_runtime_system(); 100 | 101 | caml_zmq_raise_if(num_event_sockets == -1, "zmq_poll"); 102 | 103 | events = caml_alloc(n, 0); 104 | 105 | int i; 106 | for(i = 0; i < n; i++) { 107 | if (!((items[i].revents & ZMQ_POLLIN) || (items[i].revents & ZMQ_POLLOUT))) { 108 | Store_field(events, i, Val_int(0)); /* None */ 109 | } else { 110 | some = caml_alloc(1, 0); 111 | Store_field(some, 0, CAML_ZMQ_Val_mask(items[i].revents)); 112 | Store_field(events, i, some); 113 | } 114 | } 115 | 116 | CAMLreturn (events); 117 | } 118 | -------------------------------------------------------------------------------- /zmq/src/poll.h: -------------------------------------------------------------------------------- 1 | #ifndef CAML_ZMQ_POLL_H_ 2 | #define CAML_ZMQ_POLL_H_ 3 | 4 | #include 5 | 6 | #include 7 | 8 | struct caml_zmq_poll { 9 | zmq_pollitem_t *poll_items; 10 | int num_elems; 11 | }; 12 | 13 | #define CAML_ZMQ_Poll_val(v) ((struct caml_zmq_poll *) Data_custom_val(v)) 14 | 15 | value caml_zmq_poll_of_pollitem_array(value pollitem_array); 16 | value caml_zmq_poll(value poll, value timeout); 17 | 18 | value CAML_ZMQ_Val_mask(short mask); 19 | short CAML_ZMQ_Mask_val(value mask); 20 | 21 | #endif /* CAML_ZMQ_POLLSET_H_ */ 22 | -------------------------------------------------------------------------------- /zmq/src/socket.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #include "socket.h" 6 | #include "fail.h" 7 | 8 | #include 9 | #include 10 | #include 11 | #include 12 | 13 | static void custom_finalize_socket(value socket) { 14 | if (CAML_ZMQ_Socket_val(socket)) { 15 | fprintf(stderr, "Error: Socket not closed before finalization\n"); 16 | } 17 | } 18 | 19 | static struct custom_operations caml_zmq_socket_ops = { 20 | "org.zeromq.socket", 21 | custom_finalize_socket, 22 | custom_compare_default, 23 | custom_hash_default, 24 | custom_serialize_default, 25 | custom_deserialize_default 26 | #ifdef custom_compare_ext_default 27 | , custom_compare_ext_default 28 | #endif 29 | #ifdef custom_fixed_length_default 30 | , custom_fixed_length_default 31 | #endif 32 | }; 33 | 34 | /* Captures a reference to the context to avoid collecting it prematurely */ 35 | value caml_zmq_copy_socket(void *zmq_socket) { 36 | CAMLparam0 (); 37 | CAMLlocal1 (socket); 38 | socket = caml_alloc_custom(&caml_zmq_socket_ops, sizeof (zmq_socket), 0, 1); 39 | CAML_ZMQ_Socket_val(socket) = zmq_socket; 40 | CAMLreturn (socket); 41 | } 42 | -------------------------------------------------------------------------------- /zmq/src/socket.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2011 Pedro Borges and contributors 3 | */ 4 | 5 | #ifndef CAML_ZMQ_SOCKET_H_ 6 | #define CAML_ZMQ_SOCKET_H_ 7 | 8 | #include 9 | 10 | #define CAML_ZMQ_Socket_val(v) (*((void **) Data_custom_val(v))) 11 | 12 | value caml_zmq_copy_socket(void *zmq_socket); 13 | 14 | #endif /* CAML_ZMQ_SOCKET_H_ */ 15 | -------------------------------------------------------------------------------- /zmq/src/zmq.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2011 Pedro Borges and contributors *) 2 | 3 | (** Module Exceptions *) 4 | 5 | type error = 6 | | EFSM 7 | | ENOCOMPATPROTO 8 | | ETERM 9 | | EMTHREAD 10 | | EUNKNOWN 11 | 12 | exception ZMQ_exception of error * string 13 | 14 | external version : unit -> int * int * int = "caml_zmq_version" 15 | 16 | module Context = struct 17 | type t 18 | 19 | external create : unit -> t = "caml_zmq_new" 20 | external terminate : t -> unit = "caml_zmq_term" 21 | 22 | type int_option = 23 | | ZMQ_IO_THREADS 24 | | ZMQ_MAX_SOCKETS 25 | | ZMQ_IPV6 26 | 27 | external set_int_option : 28 | t -> int_option -> int -> unit = "caml_zmq_ctx_set_int_option" 29 | external get_int_option : 30 | t -> int_option -> int = "caml_zmq_ctx_get_int_option" 31 | 32 | let get_io_threads ctx = 33 | get_int_option ctx ZMQ_IO_THREADS 34 | 35 | let set_io_threads ctx = 36 | set_int_option ctx ZMQ_IO_THREADS 37 | 38 | let get_max_sockets ctx = 39 | get_int_option ctx ZMQ_MAX_SOCKETS 40 | 41 | let set_max_sockets ctx = 42 | set_int_option ctx ZMQ_MAX_SOCKETS 43 | 44 | let get_ipv6 ctx = 45 | (get_int_option ctx ZMQ_IPV6) == 1 46 | 47 | let set_ipv6 ctx has_ipv6 = 48 | set_int_option ctx ZMQ_IPV6 (if has_ipv6 then 1 else 0) 49 | 50 | end 51 | 52 | module Msg = struct 53 | open Bigarray 54 | 55 | type t 56 | type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t 57 | 58 | external native_init_data : bigstring -> int -> int -> t = 59 | "caml_zmq_msg_init_data" 60 | 61 | let init_data ?(offset = 0) ?length buf = 62 | let length = 63 | let max_possible = Array1.dim buf - offset in 64 | match length with 65 | | Some l -> min l max_possible 66 | | None -> max_possible 67 | in 68 | native_init_data buf offset length 69 | 70 | external size : t -> int = "caml_zmq_msg_size" 71 | 72 | external unsafe_data : t -> bigstring = "caml_zmq_msg_data" 73 | 74 | let copy_data msg = 75 | let data = unsafe_data msg in 76 | let copy = Array1.create char c_layout (Array1.dim data) in 77 | Array1.blit data copy; 78 | copy 79 | 80 | external close : t -> unit = "caml_zmq_msg_close" 81 | 82 | external gets : t -> string -> string = "caml_zmq_msg_gets" 83 | end 84 | 85 | module Socket = struct 86 | 87 | type + 'a t 88 | 89 | 90 | (** This is an int so we know which socket we 91 | * are building inside the external functions *) 92 | 93 | type 'a kind = int 94 | 95 | let pair = 0 96 | let pub = 1 97 | let sub = 2 98 | let req = 3 99 | let rep = 4 100 | let dealer = 5 101 | let router = 6 102 | let pull = 7 103 | let push = 8 104 | let xpub = 9 105 | let xsub = 10 106 | let stream = 11 107 | 108 | (** Creation and Destruction *) 109 | external create : Context.t -> 'a kind -> 'a t = "caml_zmq_socket" 110 | external close : 'a t -> unit = "caml_zmq_close" 111 | 112 | (** Wiring *) 113 | external connect : 'a t -> string -> unit = "caml_zmq_connect" 114 | external disconnect : 'a t -> string -> unit = "caml_zmq_disconnect" 115 | external bind : 'a t -> string -> unit = "caml_zmq_bind" 116 | external unbind : 'a t -> string -> unit = "caml_zmq_unbind" 117 | 118 | (** Send and Receive *) 119 | external native_recv : 'a t -> bool -> string = "caml_zmq_recv" 120 | let recv ?(block = true) socket = native_recv socket block 121 | 122 | external native_send : 'a t -> string -> bool -> bool -> unit = "caml_zmq_send" 123 | let send ?(block = true) ?(more = false) socket message = native_send socket message block more 124 | 125 | external native_recv_msg : 'a t -> bool -> Msg.t = "caml_zmq_recv_msg" 126 | let recv_msg ?(block = true) socket = native_recv_msg socket block 127 | 128 | external native_send_msg : 'a t -> Msg.t -> bool -> bool -> unit = "caml_zmq_send_msg" 129 | let send_msg ?(block = true) ?(more = false) socket message = native_send_msg socket message block more 130 | 131 | type int64_option = 132 | | ZMQ_AFFINITY 133 | | ZMQ_MAXMSGSIZE 134 | 135 | external set_int64_option : 136 | 'a t -> int64_option -> int -> unit = "caml_zmq_set_int64_option" 137 | 138 | external get_int64_option : 139 | 'a t -> int64_option -> int = "caml_zmq_get_int64_option" 140 | 141 | 142 | type string_option = 143 | | ZMQ_IDENTITY 144 | | ZMQ_SUBSCRIBE 145 | | ZMQ_UNSUBSCRIBE 146 | | ZMQ_LAST_ENDPOINT 147 | | ZMQ_TCP_ACCEPT_FILTER 148 | | ZMQ_PLAIN_USERNAME 149 | | ZMQ_PLAIN_PASSWORD 150 | | ZMQ_CURVE_PUBLICKEY 151 | | ZMQ_CURVE_SECRETKEY 152 | | ZMQ_CURVE_SERVERKEY 153 | | ZMQ_ZAP_DOMAIN 154 | 155 | external set_string_option : 156 | 'a t -> string_option -> string -> unit = "caml_zmq_set_string_option" 157 | 158 | external get_string_option : 159 | 'a t -> string_option -> int -> string = "caml_zmq_get_string_option" 160 | 161 | [@@@warning "-37"] 162 | type int_option = 163 | | ZMQ_RATE 164 | | ZMQ_RECOVERY_IVL 165 | | ZMQ_SNDBUF 166 | | ZMQ_RCVBUF 167 | | ZMQ_RCVMORE 168 | | ZMQ_EVENTS 169 | | ZMQ_TYPE 170 | | ZMQ_LINGER 171 | | ZMQ_RECONNECT_IVL 172 | | ZMQ_BACKLOG 173 | | ZMQ_RECONNECT_IVL_MAX 174 | | ZMQ_SNDHWM 175 | | ZMQ_RCVHWM 176 | | ZMQ_MULTICAST_HOPS 177 | | ZMQ_RCVTIMEO 178 | | ZMQ_SNDTIMEO 179 | | ZMQ_IPV6 180 | | ZMQ_ROUTER_MANDATORY 181 | | ZMQ_TCP_KEEPALIVE 182 | | ZMQ_TCP_KEEPALIVE_CNT 183 | | ZMQ_TCP_KEEPALIVE_IDLE 184 | | ZMQ_TCP_KEEPALIVE_INTVL 185 | | ZMQ_IMMEDIATE 186 | | ZMQ_XPUB_VERBOSE 187 | | ZMQ_MECHANISM 188 | | ZMQ_PLAIN_SERVER 189 | | ZMQ_CURVE_SERVER 190 | | ZMQ_PROBE_ROUTER 191 | | ZMQ_REQ_CORRELATE 192 | | ZMQ_REQ_RELAXED 193 | | ZMQ_CONFLATE 194 | | ZMQ_STREAM_NOTIFY 195 | [@@@warning "+37"] 196 | 197 | external set_int_option : 198 | 'a t -> int_option -> int -> unit = "caml_zmq_set_int_option" 199 | 200 | external get_int_option : 201 | 'a t -> int_option -> int = "caml_zmq_get_int_option" 202 | 203 | 204 | let validate_string_length min max str msg = 205 | match String.length str with 206 | | n when n < min -> invalid_arg msg 207 | | n when n > max -> invalid_arg msg 208 | | _ -> () 209 | 210 | let set_max_message_size socket size = 211 | set_int64_option socket ZMQ_MAXMSGSIZE size 212 | 213 | let get_max_message_size socket = 214 | get_int64_option socket ZMQ_MAXMSGSIZE 215 | 216 | let set_affinity socket size = 217 | set_int64_option socket ZMQ_AFFINITY size 218 | 219 | let get_affinity socket = 220 | get_int64_option socket ZMQ_AFFINITY 221 | 222 | let set_identity socket identity = 223 | validate_string_length 1 255 identity "set_identity"; 224 | set_string_option socket ZMQ_IDENTITY identity 225 | 226 | let maximal_buffer_length = 255 227 | let curve_z85_buffer_length = 41 228 | 229 | let get_identity socket = 230 | get_string_option socket ZMQ_IDENTITY maximal_buffer_length 231 | 232 | let subscribe socket topic = 233 | set_string_option socket ZMQ_SUBSCRIBE topic 234 | 235 | let unsubscribe socket topic = 236 | set_string_option socket ZMQ_UNSUBSCRIBE topic 237 | 238 | let get_last_endpoint socket = 239 | get_string_option socket ZMQ_LAST_ENDPOINT maximal_buffer_length 240 | 241 | let set_tcp_accept_filter socket filter = 242 | set_string_option socket ZMQ_TCP_ACCEPT_FILTER filter 243 | 244 | let set_rate socket rate = 245 | set_int_option socket ZMQ_RATE rate 246 | 247 | let get_rate socket = 248 | get_int_option socket ZMQ_RATE 249 | 250 | let set_recovery_interval socket interval = 251 | set_int_option socket ZMQ_RECOVERY_IVL interval 252 | 253 | let get_recovery_interval socket = 254 | get_int_option socket ZMQ_RECOVERY_IVL 255 | 256 | let set_send_buffer_size socket size = 257 | set_int_option socket ZMQ_SNDBUF size 258 | 259 | let get_send_buffer_size socket = 260 | get_int_option socket ZMQ_SNDBUF 261 | 262 | let set_receive_buffer_size socket size = 263 | set_int_option socket ZMQ_RCVBUF size 264 | 265 | let get_receive_buffer_size socket = 266 | get_int_option socket ZMQ_RCVBUF 267 | 268 | let has_more socket = 269 | get_int_option socket ZMQ_RCVMORE != 0 270 | 271 | let set_linger_period socket period = 272 | set_int_option socket ZMQ_LINGER period 273 | 274 | let get_linger_period socket = 275 | get_int_option socket ZMQ_LINGER 276 | 277 | let set_reconnect_interval socket interval = 278 | set_int_option socket ZMQ_RECONNECT_IVL interval 279 | 280 | let get_reconnect_interval socket = 281 | get_int_option socket ZMQ_RECONNECT_IVL 282 | 283 | let set_connection_backlog socket backlog = 284 | set_int_option socket ZMQ_BACKLOG backlog 285 | 286 | let get_connection_backlog socket = 287 | get_int_option socket ZMQ_BACKLOG 288 | 289 | let set_reconnect_interval_max socket interval = 290 | set_int_option socket ZMQ_RECONNECT_IVL_MAX interval 291 | 292 | let get_reconnect_interval_max socket = 293 | get_int_option socket ZMQ_RECONNECT_IVL_MAX 294 | 295 | let set_send_high_water_mark socket mark = 296 | set_int_option socket ZMQ_SNDHWM mark 297 | 298 | let get_send_high_water_mark socket = 299 | get_int_option socket ZMQ_SNDHWM 300 | 301 | let set_receive_high_water_mark socket mark = 302 | set_int_option socket ZMQ_RCVHWM mark 303 | 304 | let get_receive_high_water_mark socket = 305 | get_int_option socket ZMQ_RCVHWM 306 | 307 | let set_multicast_hops socket hops = 308 | set_int_option socket ZMQ_MULTICAST_HOPS hops 309 | 310 | let get_multicast_hops socket = 311 | get_int_option socket ZMQ_MULTICAST_HOPS 312 | 313 | let set_receive_timeout socket timeout = 314 | set_int_option socket ZMQ_RCVTIMEO timeout 315 | 316 | let get_receive_timeout socket = 317 | get_int_option socket ZMQ_RCVTIMEO 318 | 319 | let set_send_timeout socket timeout = 320 | set_int_option socket ZMQ_SNDTIMEO timeout 321 | 322 | let get_send_timeout socket = 323 | get_int_option socket ZMQ_SNDTIMEO 324 | 325 | let set_ipv6 socket flag = 326 | let value = match flag with true -> 1 | false -> 0 in 327 | set_int_option socket ZMQ_IPV6 value 328 | 329 | let get_ipv6 socket = 330 | match get_int_option socket ZMQ_IPV6 with 331 | | 0 -> false 332 | | _ -> true 333 | 334 | let set_router_mandatory socket flag = 335 | let value = match flag with true -> 1 | false -> 0 in 336 | set_int_option socket ZMQ_ROUTER_MANDATORY value 337 | 338 | let get_router_mandatory socket = 339 | match get_int_option socket ZMQ_ROUTER_MANDATORY with 340 | | 0 -> false 341 | | _ -> true 342 | 343 | let set_tcp_keepalive socket flag = 344 | let value = match flag with 345 | | `Default -> -1 346 | | `Value false -> 0 347 | | `Value true -> 1 348 | in 349 | set_int_option socket ZMQ_TCP_KEEPALIVE value 350 | 351 | let get_tcp_keepalive socket = 352 | match get_int_option socket ZMQ_TCP_KEEPALIVE with 353 | | -1 -> `Default 354 | | 0 -> `Value false 355 | | _ -> `Value true 356 | 357 | let set_tcp_keepalive_idle socket flag = 358 | let value = match flag with 359 | | `Default -> -1 360 | | `Value n when n <= 0 -> invalid_arg "set_tcp_keepalive_idle" 361 | | `Value n -> n 362 | in 363 | set_int_option socket ZMQ_TCP_KEEPALIVE_IDLE value 364 | 365 | let get_tcp_keepalive_idle socket = 366 | match get_int_option socket ZMQ_TCP_KEEPALIVE_IDLE with 367 | | -1 -> `Default 368 | | n when n <= 0 -> assert false 369 | | n -> `Value n 370 | 371 | let set_tcp_keepalive_interval socket flag = 372 | let value = match flag with 373 | | `Default -> -1 374 | | `Value n when n <= 0 -> invalid_arg "set_tcp_keepalive_interval" 375 | | `Value n -> n 376 | in 377 | set_int_option socket ZMQ_TCP_KEEPALIVE_INTVL value 378 | 379 | let get_tcp_keepalive_interval socket = 380 | match get_int_option socket ZMQ_TCP_KEEPALIVE_INTVL with 381 | | -1 -> `Default 382 | | n when n <= 0 -> assert false 383 | | n -> `Value n 384 | 385 | let set_tcp_keepalive_count socket flag = 386 | let value = match flag with 387 | | `Default -> -1 388 | | `Value n when n <= 0 -> invalid_arg "set_tcp_keepalive_count" 389 | | `Value n -> n 390 | in 391 | set_int_option socket ZMQ_TCP_KEEPALIVE_CNT value 392 | 393 | let get_tcp_keepalive_count socket = 394 | match get_int_option socket ZMQ_TCP_KEEPALIVE_CNT with 395 | | -1 -> `Default 396 | | n when n <= 0 -> assert false 397 | | n -> `Value n 398 | 399 | let set_immediate socket flag = 400 | let value = match flag with 401 | | true -> 1 402 | | false -> 0 403 | in 404 | set_int_option socket ZMQ_IMMEDIATE value 405 | 406 | let get_immediate socket = 407 | match get_int_option socket ZMQ_IMMEDIATE with 408 | | 0 -> false 409 | | _ -> true 410 | 411 | let set_xpub_verbose socket flag = 412 | let value = match flag with 413 | | true -> 1 414 | | false -> 0 415 | in 416 | set_int_option socket ZMQ_XPUB_VERBOSE value 417 | 418 | let set_probe_router socket flag = 419 | set_int_option socket ZMQ_PROBE_ROUTER (if flag then 1 else 0) 420 | 421 | let set_req_correlate socket flag = 422 | set_int_option socket ZMQ_REQ_CORRELATE (if flag then 1 else 0) 423 | 424 | let set_req_relaxed socket flag = 425 | set_int_option socket ZMQ_REQ_RELAXED (if flag then 1 else 0) 426 | 427 | let set_plain_server socket flag = 428 | set_int_option socket ZMQ_PLAIN_SERVER (if flag then 1 else 0) 429 | 430 | let set_curve_server socket flag = 431 | set_int_option socket ZMQ_CURVE_SERVER (if flag then 1 else 0) 432 | 433 | let set_plain_username socket = 434 | set_string_option socket ZMQ_PLAIN_USERNAME 435 | 436 | let get_plain_username socket = 437 | get_string_option socket ZMQ_PLAIN_USERNAME maximal_buffer_length 438 | 439 | let set_plain_password socket = 440 | set_string_option socket ZMQ_PLAIN_PASSWORD 441 | 442 | let get_plain_password socket = 443 | get_string_option socket ZMQ_PLAIN_PASSWORD maximal_buffer_length 444 | 445 | let validate_curve_key_length str msg = 446 | match String.length str with 447 | | 32 | 40 -> () 448 | | _ -> invalid_arg msg 449 | 450 | let get_curve_publickey socket = 451 | get_string_option socket ZMQ_CURVE_PUBLICKEY curve_z85_buffer_length 452 | 453 | let set_curve_publickey socket str = 454 | validate_curve_key_length str "set_curve_publickey"; 455 | set_string_option socket ZMQ_CURVE_PUBLICKEY str 456 | 457 | let get_curve_secretkey socket = 458 | get_string_option socket ZMQ_CURVE_SECRETKEY curve_z85_buffer_length 459 | 460 | let set_curve_secretkey socket str = 461 | validate_curve_key_length str "set_curve_secretkey"; 462 | set_string_option socket ZMQ_CURVE_SECRETKEY str 463 | 464 | let get_curve_serverkey socket = 465 | get_string_option socket ZMQ_CURVE_SERVERKEY curve_z85_buffer_length 466 | 467 | let set_curve_serverkey socket str = 468 | validate_curve_key_length str "set_curve_serverkey"; 469 | set_string_option socket ZMQ_CURVE_SERVERKEY str 470 | 471 | let get_mechanism socket = 472 | match get_int_option socket ZMQ_MECHANISM with 473 | | 0 -> `Null 474 | | 1 -> `Plain 475 | | 2 -> `Curve 476 | | _ -> assert false 477 | 478 | let set_zap_domain socket = 479 | set_string_option socket ZMQ_ZAP_DOMAIN 480 | 481 | let get_zap_domain socket = 482 | get_string_option socket ZMQ_ZAP_DOMAIN maximal_buffer_length 483 | 484 | let set_conflate socket flag = 485 | set_int_option socket ZMQ_CONFLATE (if flag then 1 else 0) 486 | 487 | let set_stream_notify socket stream_notify_flag = 488 | set_int_option socket ZMQ_STREAM_NOTIFY (if stream_notify_flag then 1 else 0) 489 | 490 | external get_fd : 'a t -> Unix.file_descr = "caml_zmq_get_fd" 491 | 492 | type event = No_event | Poll_in | Poll_out | Poll_in_out | Poll_error 493 | external events : 'a t -> event = "caml_zmq_get_events" 494 | 495 | let recv_all_wrapper (f : ?block:bool -> _ t -> _) = 496 | (* Once the first message part is received all remaining message parts can 497 | be received without blocking. *) 498 | let rec loop socket accu = 499 | if has_more socket then 500 | loop socket (f socket :: accu) 501 | else 502 | accu 503 | in 504 | fun ?block socket -> 505 | let first = f ?block socket in 506 | List.rev (loop socket [first]) 507 | 508 | let send_all_wrapper (f : ?block:bool -> ?more:bool -> _ t -> _ -> unit) = 509 | (* Once the first message part is sent all remaining message parts can 510 | be sent without blocking. *) 511 | let rec send_all_inner_loop socket message = 512 | match message with 513 | | [] -> () 514 | | hd :: [] -> 515 | f socket hd 516 | | hd :: tl -> 517 | f ~more:true socket hd; 518 | send_all_inner_loop socket tl 519 | in 520 | fun ?block socket message -> 521 | match message with 522 | | [] -> () 523 | | hd :: [] -> 524 | f ?block ~more:false socket hd 525 | | hd :: tl -> 526 | f ?block ~more:true socket hd; 527 | send_all_inner_loop socket tl 528 | 529 | let recv_all ?block socket = 530 | recv_all_wrapper recv ?block socket 531 | 532 | let send_all ?block socket message = 533 | send_all_wrapper send ?block socket message 534 | 535 | let recv_msg_all ?block socket = 536 | recv_all_wrapper recv_msg ?block socket 537 | 538 | let send_msg_all ?block socket message = 539 | send_all_wrapper send_msg ?block socket message 540 | end 541 | 542 | module Proxy = struct 543 | external zmq_proxy2 : 544 | 'a Socket.t -> 'b Socket.t -> unit = "caml_zmq_proxy2" 545 | external zmq_proxy3 : 546 | 'a Socket.t -> 'b Socket.t -> 'c Socket.t -> unit = "caml_zmq_proxy3" 547 | 548 | let create ?capture frontend backend = 549 | match capture with 550 | | Some capture -> zmq_proxy3 frontend backend capture 551 | | None -> zmq_proxy2 frontend backend 552 | 553 | end 554 | 555 | module Poll = struct 556 | 557 | type t 558 | 559 | type poll_event = In | Out | In_out 560 | type 'a poll_mask = ('a Socket.t * poll_event) 561 | 562 | let mask_in_out t = 563 | (t:> 564 | [`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 565 | Socket.t 566 | ), In_out 567 | 568 | let mask_in t = 569 | (t:> 570 | [`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 571 | Socket.t 572 | ), In 573 | 574 | let mask_out t = 575 | (t:> 576 | [`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 577 | Socket.t 578 | ), Out 579 | 580 | external mask_of : 'a poll_mask array -> t = "caml_zmq_poll_of_pollitem_array" 581 | external of_masks : 'a poll_mask array -> t = "caml_zmq_poll_of_pollitem_array" 582 | external native_poll: t -> int -> poll_event option array = "caml_zmq_poll" 583 | 584 | let poll ?(timeout = -1) items = native_poll items timeout 585 | 586 | end 587 | 588 | module Monitor = struct 589 | type t = string 590 | 591 | type address = string 592 | type error_no = int 593 | type error_text = string 594 | 595 | type event = 596 | | Connected of address * Unix.file_descr 597 | | Connect_delayed of address 598 | | Connect_retried of address * int (*interval*) 599 | | Listening of address * Unix.file_descr 600 | | Bind_failed of address * error_no * error_text 601 | | Accepted of address * Unix.file_descr 602 | | Accept_failed of address * error_no * error_text 603 | | Closed of address * Unix.file_descr 604 | | Close_failed of address * error_no * error_text 605 | | Disconnected of address * Unix.file_descr 606 | | Monitor_stopped of address 607 | | Handshake_failed_no_detail of address 608 | | Handshake_succeeded of address 609 | | Handshake_failed_protocol of address * int 610 | | Handshake_failed_auth of address * int 611 | 612 | external socket_monitor: 'a Socket.t -> string -> unit = "caml_zmq_socket_monitor" 613 | 614 | let create socket = 615 | (* Construct an anonymous inproc channel name *) 616 | let socket_id = Hashtbl.hash (Socket.get_fd socket) in 617 | let address = Printf.sprintf "inproc://_socket_monitor-%d-%x.%x" 618 | (Unix.getpid ()) 619 | socket_id 620 | (Random.bits ()) 621 | in 622 | socket_monitor socket address; 623 | address 624 | 625 | let connect ctx t = 626 | let s = Socket.create ctx Socket.pair in 627 | Socket.connect s t; 628 | s 629 | 630 | external decode_monitor_event : string -> string -> event = "caml_decode_monitor_event" 631 | 632 | let recv ?block socket = 633 | let event = Socket.recv ?block socket in 634 | assert (Socket.has_more socket); 635 | let addr = Socket.recv ~block:false socket in 636 | decode_monitor_event event addr 637 | 638 | let get_peer_address fd = 639 | try 640 | let sockaddr = Unix.getpeername fd in 641 | let domain = match Unix.domain_of_sockaddr sockaddr with 642 | | Unix.PF_UNIX -> "unix" 643 | | Unix.PF_INET -> "tcp" 644 | | Unix.PF_INET6 -> "tcp6" 645 | in 646 | match sockaddr with 647 | | Unix.ADDR_UNIX s -> Printf.sprintf "%s://%s" domain s; 648 | | Unix.ADDR_INET (addr, port) -> Printf.sprintf "%s://%s:%d" domain (Unix.string_of_inet_addr addr) port 649 | with 650 | | Unix.Unix_error _ -> "unknown" 651 | 652 | let internal_string_of_event push_address pop_address = function 653 | | Connected (addr, fd) -> Printf.sprintf "Connect: %s. peer %s" addr (push_address fd) 654 | | Connect_delayed addr -> Printf.sprintf "Connect delayed: %s" addr 655 | | Connect_retried (addr, interval) -> Printf.sprintf "Connect retried: %s - %d" addr interval 656 | | Listening (addr, fd) -> Printf.sprintf "Listening: %s - peer %s" addr (push_address fd) 657 | | Bind_failed (addr, error_no, error_text) -> Printf.sprintf "Bind failed: %s. %d:%s" addr error_no error_text 658 | | Accepted (addr, fd) -> Printf.sprintf "Accepted: %s. peer %s" addr (push_address fd) 659 | | Accept_failed (addr, error_no, error_text) -> Printf.sprintf "Accept failed: %s. %d:%s" addr error_no error_text 660 | | Closed (addr, fd) -> Printf.sprintf "Closed: %s. peer %s" addr (pop_address fd) 661 | | Close_failed (addr, error_no, error_text) -> Printf.sprintf "Close failed: %s. %d:%s" addr error_no error_text 662 | | Disconnected (addr, fd) -> Printf.sprintf "Disconnect: %s. peer %s" addr (pop_address fd) 663 | | Monitor_stopped addr -> Printf.sprintf "Monitor_stopped: %s" addr 664 | | Handshake_failed_no_detail addr -> Printf.sprintf "Handshake_failed_no_detail: %s" addr 665 | | Handshake_succeeded addr -> Printf.sprintf "Handshake_succeeded: %s" addr 666 | | Handshake_failed_protocol (addr, code) -> Printf.sprintf "Handshake_failed_protocol: %s - %d" addr code 667 | | Handshake_failed_auth (addr, code) -> Printf.sprintf "Handshake_failed_auth: %s - %d" addr code 668 | 669 | let string_of_event event = internal_string_of_event get_peer_address get_peer_address event 670 | 671 | let mk_string_of_event () = 672 | let state = ref [] in 673 | 674 | let pop_address fd = 675 | let rec pop acc = function 676 | | [] -> (get_peer_address fd, acc) 677 | | (fd', address) :: xs when fd' = fd -> (address, acc @ xs) 678 | | x :: xs -> pop (x :: acc) xs 679 | in 680 | let (address, new_state) = pop [] !state in 681 | state := new_state; 682 | address 683 | in 684 | 685 | let push_address fd = 686 | let address = get_peer_address fd in 687 | state := (fd, address) :: !state; 688 | address 689 | in 690 | internal_string_of_event push_address pop_address 691 | 692 | end 693 | 694 | module Z85 = struct 695 | external encode : string -> string = "caml_z85_encode" 696 | external decode : string -> string = "caml_z85_decode" 697 | end 698 | 699 | module Curve = struct 700 | external keypair : unit -> string * string = "caml_curve_keypair" 701 | end 702 | 703 | (* The following code is called by fail.c *) 704 | 705 | [@@@warning "-37"] 706 | type internal_error = 707 | (* zmq.h defines the following Unix error codes if they are not already defined 708 | * by the system headers *) 709 | | I_ENOTSUP 710 | | I_EPROTONOSUPPORT 711 | | I_ENOBUFS 712 | | I_ENETDOWN 713 | | I_EADDRINUSE 714 | | I_EADDRNOTAVAIL 715 | | I_ECONNREFUSED 716 | | I_EINPROGRESS 717 | | I_ENOTSOCK 718 | | I_EMSGSIZE 719 | | I_EAFNOSUPPORT 720 | | I_ENETUNREACH 721 | | I_ECONNABORTED 722 | | I_ECONNRESET 723 | | I_ENOTCONN 724 | | I_ETIMEDOUT 725 | | I_EHOSTUNREACH 726 | | I_ENETRESET 727 | (* The following error codes are ZMQ-specific *) 728 | | I_EFSM 729 | | I_ENOCOMPATPROTO 730 | | I_ETERM 731 | | I_EMTHREAD 732 | | I_EUNKNOWN 733 | [@@@warning "+37"] 734 | 735 | (* All Unix-type errors are mapped to their corresponding constructor in 736 | * Unix -- except I_ENOTSUP, which is mapped to EOPNOTSUPP ("Operation not 737 | * supported on socket") since there is no Unix.ENOTSUP. 738 | * ZMQ-specific errors are mapped to the constructors of Zmq.error. *) 739 | let zmq_raise e str func_name = 740 | let exn = match e with 741 | | I_ENOTSUP -> Unix.(Unix_error (EOPNOTSUPP , func_name, "")) 742 | | I_EPROTONOSUPPORT -> Unix.(Unix_error (EPROTONOSUPPORT, func_name, "")) 743 | | I_ENOBUFS -> Unix.(Unix_error (ENOBUFS , func_name, "")) 744 | | I_ENETDOWN -> Unix.(Unix_error (ENETDOWN , func_name, "")) 745 | | I_EADDRINUSE -> Unix.(Unix_error (EADDRINUSE , func_name, "")) 746 | | I_EADDRNOTAVAIL -> Unix.(Unix_error (EADDRNOTAVAIL , func_name, "")) 747 | | I_ECONNREFUSED -> Unix.(Unix_error (ECONNREFUSED , func_name, "")) 748 | | I_EINPROGRESS -> Unix.(Unix_error (EINPROGRESS , func_name, "")) 749 | | I_ENOTSOCK -> Unix.(Unix_error (ENOTSOCK , func_name, "")) 750 | | I_EMSGSIZE -> Unix.(Unix_error (EMSGSIZE , func_name, "")) 751 | | I_EAFNOSUPPORT -> Unix.(Unix_error (EAFNOSUPPORT , func_name, "")) 752 | | I_ENETUNREACH -> Unix.(Unix_error (ENETUNREACH , func_name, "")) 753 | | I_ECONNABORTED -> Unix.(Unix_error (ECONNABORTED , func_name, "")) 754 | | I_ECONNRESET -> Unix.(Unix_error (ECONNRESET , func_name, "")) 755 | | I_ENOTCONN -> Unix.(Unix_error (ENOTCONN , func_name, "")) 756 | | I_ETIMEDOUT -> Unix.(Unix_error (ETIMEDOUT , func_name, "")) 757 | | I_EHOSTUNREACH -> Unix.(Unix_error (EHOSTUNREACH , func_name, "")) 758 | | I_ENETRESET -> Unix.(Unix_error (ENETRESET , func_name, "")) 759 | | I_EFSM -> ZMQ_exception (EFSM , str) 760 | | I_ENOCOMPATPROTO -> ZMQ_exception (ENOCOMPATPROTO, str) 761 | | I_ETERM -> ZMQ_exception (ETERM , str) 762 | | I_EMTHREAD -> ZMQ_exception (EMTHREAD , str) 763 | | I_EUNKNOWN -> ZMQ_exception (EUNKNOWN , str) 764 | in 765 | 766 | raise exn 767 | 768 | 769 | let () = Callback.register "Zmq.zmq_raise" zmq_raise 770 | -------------------------------------------------------------------------------- /zmq/src/zmq.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2011 Pedro Borges and contributors *) 2 | 3 | (** Module Exceptions *) 4 | type error = 5 | | EFSM 6 | | ENOCOMPATPROTO 7 | | ETERM 8 | | EMTHREAD 9 | | EUNKNOWN 10 | 11 | exception ZMQ_exception of error * string 12 | 13 | val version : unit -> int * int * int 14 | 15 | module Context : sig 16 | type t 17 | 18 | val create : unit -> t 19 | val terminate : t -> unit 20 | 21 | val get_io_threads : t -> int 22 | val set_io_threads : t -> int -> unit 23 | val get_max_sockets : t -> int 24 | val set_max_sockets : t -> int -> unit 25 | val get_ipv6 : t -> bool 26 | val set_ipv6 : t -> bool -> unit 27 | end 28 | 29 | module Msg : sig 30 | type t 31 | 32 | type bigstring = 33 | (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 34 | 35 | (** Initialize a new message with the given data. The data will be 36 | kept alive for the lifetime of the message. 37 | 38 | @param offset specifies an offset from the start of the given block 39 | to use. Defaults to [0]. 40 | @param length specifies the number of bytes, starting from [offset], 41 | to use. Defaults the [length of data - offset]. 42 | *) 43 | val init_data : ?offset:int -> ?length:int -> bigstring -> t 44 | 45 | (** Size of the message in bytes *) 46 | val size : t -> int 47 | 48 | (** Retrieve a copy of the data contained in the message. *) 49 | val copy_data : t -> bigstring 50 | 51 | (** Retrieve the data contained in the message. 52 | 53 | This is considered {b unsafe} because the underlying data may be freed 54 | when the message's lifetime expires. 55 | *) 56 | val unsafe_data : t -> bigstring 57 | 58 | (** Free the message. This will be done automatically when the message 59 | is garbage collected. 60 | *) 61 | val close : t -> unit 62 | 63 | (** Retrieve a property attached to a message. Property are simple strings. 64 | Example of properties include: "Socket-Type", "Identity", "Resource", 65 | but underlying transport and security mechanism may add more. 66 | *) 67 | val gets : t -> string -> string 68 | end 69 | 70 | module Socket : sig 71 | 72 | type + 'a t 73 | type 'a kind 74 | 75 | val pair : [`Pair] kind 76 | val pub : [`Pub] kind 77 | val sub : [`Sub] kind 78 | val req : [`Req] kind 79 | val rep : [`Rep] kind 80 | val dealer : [`Dealer] kind 81 | val router : [`Router] kind 82 | val pull : [`Pull] kind 83 | val push : [`Push] kind 84 | val xsub : [`Xsub] kind 85 | val xpub : [`Xpub] kind 86 | val stream : [`Stream] kind 87 | 88 | (** Creation and Destruction *) 89 | val create : Context.t -> 'a kind -> 'a t 90 | val close : 'a t -> unit 91 | 92 | (** Wiring *) 93 | val connect : 'a t -> string -> unit 94 | val disconnect : 'a t -> string -> unit 95 | val bind : 'a t -> string -> unit 96 | val unbind : 'a t -> string -> unit 97 | 98 | (** Read a message from the socket. 99 | block indicates if the call should be blocking or non-blocking. 100 | If block is [false], [recv] will raise [Unix.Unix_error (Unix.EAGAIN, _, _)] if there are no messages available to receive on the specified socket. 101 | Default true 102 | *) 103 | val recv : ?block:bool -> 'a t -> string 104 | 105 | (** Read a complete multipart message from the socket. 106 | block indicates if the call should be blocking or non-blocking. Default true 107 | *) 108 | val recv_all : ?block:bool -> 'a t -> string list 109 | 110 | (** Send a message to the socket. 111 | block indicates if the call should be blocking or non-blocking. Default true 112 | more is used for multipart messages, and indicates that the more message parts will follow. Default false 113 | *) 114 | val send : ?block:bool -> ?more:bool -> 'a t -> string -> unit 115 | 116 | (** Send a multipart message to the socket. 117 | block indicates if the call should be blocking or non-blocking. Default true 118 | *) 119 | val send_all : ?block:bool -> 'a t -> string list -> unit 120 | 121 | (** Receive a {!Msg.t} on the socket. 122 | 123 | @param block indicates if the call should be blocking or non-blocking. 124 | Defaults to [true]. 125 | *) 126 | val recv_msg : ?block:bool -> 'a t -> Msg.t 127 | 128 | (** Receive a multi-part message on the socket. 129 | 130 | @param block indicates if the call should be blocking or non-blocking. 131 | Defaults to [true]. 132 | *) 133 | val recv_msg_all : ?block:bool -> 'a t -> Msg.t list 134 | 135 | (** Send a {!Msg.t} to the socket. 136 | 137 | @param block indicates if the call should be blocking or non-blocking. 138 | Defaults to [true]. 139 | @param more is used for multipart messages Set to [true] to indicate that 140 | more message parts will follow. Defaults to [false]. 141 | *) 142 | val send_msg : ?block:bool -> ?more:bool -> 'a t -> Msg.t -> unit 143 | 144 | (** Send a multi-part message to the socket. 145 | 146 | @param block indicates if the call should be blocking or non-blocking. 147 | Defaults to [true]. 148 | *) 149 | val send_msg_all : ?block:bool -> 'a t -> Msg.t list -> unit 150 | 151 | (** Option Getter and Setters *) 152 | 153 | (** Set the maximum message size of a message sent in this context, 154 | represented as a signed integer. A value of -1 will set the max 155 | message size to 2^64-1. *) 156 | val set_max_message_size : 'a t -> int -> unit 157 | 158 | (** Get the maximum message size for this context represented as a signed integer. 159 | A value of -1 equals to 2^64-1. *) 160 | val get_max_message_size : 'a t -> int 161 | 162 | (** Set thread affinity. Affinity is represented as a bit vector *) 163 | val set_affinity : 'a t -> int -> unit 164 | 165 | (** Get thread affinity, represented as a bit vector. *) 166 | val get_affinity : 'a t -> int 167 | 168 | val set_identity : 'a t -> string -> unit 169 | val get_identity : 'a t -> string 170 | val subscribe : [< `Sub] t -> string -> unit 171 | val unsubscribe : [< `Sub] t -> string -> unit 172 | val get_last_endpoint : 'a t -> string 173 | val set_tcp_accept_filter : 'a t -> string -> unit 174 | val set_rate : 'a t -> int -> unit 175 | val get_rate : 'a t -> int 176 | val set_recovery_interval : 'a t -> int -> unit 177 | val get_recovery_interval : 'a t -> int 178 | val set_send_buffer_size : 'a t -> int -> unit 179 | val get_send_buffer_size : 'a t -> int 180 | val set_receive_buffer_size : 'a t -> int -> unit 181 | val get_receive_buffer_size : 'a t -> int 182 | val has_more : 'a t -> bool 183 | val set_linger_period : 'a t -> int -> unit 184 | val get_linger_period : 'a t -> int 185 | val set_reconnect_interval : 'a t -> int -> unit 186 | val get_reconnect_interval : 'a t -> int 187 | val set_connection_backlog : 'a t -> int -> unit 188 | val get_connection_backlog : 'a t -> int 189 | val set_reconnect_interval_max : 'a t -> int -> unit 190 | val get_reconnect_interval_max : 'a t -> int 191 | val set_send_high_water_mark : 'a t -> int -> unit 192 | val get_send_high_water_mark : 'a t -> int 193 | val set_receive_high_water_mark : 'a t -> int -> unit 194 | val get_receive_high_water_mark : 'a t -> int 195 | val set_multicast_hops : 'a t -> int -> unit 196 | val get_multicast_hops : 'a t -> int 197 | val set_receive_timeout : 'a t -> int -> unit 198 | val get_receive_timeout : 'a t -> int 199 | val set_send_timeout : 'a t -> int -> unit 200 | val get_send_timeout : 'a t -> int 201 | val set_ipv6 : 'a t -> bool -> unit 202 | val get_ipv6 : 'a t -> bool 203 | val set_router_mandatory : [> `Router] t -> bool -> unit 204 | val get_router_mandatory : [> `Router] t -> bool 205 | val set_tcp_keepalive : 'a t -> [ `Default | `Value of bool ] -> unit 206 | val get_tcp_keepalive : 'a t -> [ `Default | `Value of bool ] 207 | val set_tcp_keepalive_idle : 'a t -> [ `Default | `Value of int ] -> unit 208 | val get_tcp_keepalive_idle : 'a t -> [ `Default | `Value of int ] 209 | val set_tcp_keepalive_count : 'a t -> [ `Default | `Value of int ] -> unit 210 | val get_tcp_keepalive_count : 'a t -> [ `Default | `Value of int ] 211 | val set_tcp_keepalive_interval : 'a t -> [ `Default | `Value of int ] -> unit 212 | val get_tcp_keepalive_interval : 'a t -> [ `Default | `Value of int ] 213 | val set_immediate : 'a t -> bool -> unit 214 | val get_immediate : 'a t -> bool 215 | val set_xpub_verbose : [< `Xpub] t -> bool -> unit 216 | val set_probe_router : [< `Router | `Dealer | `Req ] t -> bool -> unit 217 | val set_req_correlate : [< `Req ] t -> bool -> unit 218 | val set_req_relaxed : [< `Req ] t -> bool -> unit 219 | val set_plain_server : 'a t -> bool -> unit 220 | val set_plain_username : 'a t -> string -> unit 221 | val get_plain_username : 'a t -> string 222 | val set_plain_password : 'a t -> string -> unit 223 | val get_plain_password : 'a t -> string 224 | val set_curve_server : 'a t -> bool -> unit 225 | val set_curve_publickey : 'a t -> string -> unit 226 | val get_curve_publickey : 'a t -> string 227 | val set_curve_secretkey : 'a t -> string -> unit 228 | val get_curve_secretkey : 'a t -> string 229 | val set_curve_serverkey : 'a t -> string -> unit 230 | val get_curve_serverkey : 'a t -> string 231 | val get_mechanism : 'a t -> [`Null | `Plain | `Curve] 232 | val set_zap_domain : 'a t -> string -> unit 233 | val get_zap_domain : 'a t -> string 234 | val set_conflate : [< `Pull | `Push | `Sub | `Pub | `Dealer] t -> bool -> unit 235 | val set_stream_notify : [< `Stream ] t -> bool -> unit 236 | 237 | val get_fd : 'a t -> Unix.file_descr 238 | 239 | type event = No_event | Poll_in | Poll_out | Poll_in_out | Poll_error 240 | val events : 'a t -> event 241 | 242 | end 243 | 244 | module Proxy : sig 245 | val create: ?capture:[< `Pub|`Dealer|`Push|`Pair] Socket.t -> 'a Socket.t -> 'b Socket.t -> unit 246 | end 247 | 248 | module Poll : sig 249 | 250 | type t 251 | 252 | type poll_event = In | Out | In_out 253 | type 'a poll_mask = ('a Socket.t * poll_event) 254 | 255 | val mask_in_out : 256 | [<`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 257 | Socket.t 258 | -> 259 | [`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 260 | poll_mask 261 | (** @since 5.1.4 *) 262 | 263 | val mask_in : 264 | [<`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 265 | Socket.t 266 | -> 267 | [`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 268 | poll_mask 269 | (** @since 5.1.4 *) 270 | 271 | val mask_out : 272 | [<`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 273 | Socket.t 274 | -> 275 | [`Pair|`Pub|`Sub|`Req|`Rep|`Dealer|`Router|`Pull|`Push|`Xsub|`Xpub|`Stream] 276 | poll_mask 277 | (** @since 5.1.4 *) 278 | 279 | val mask_of : 'a poll_mask array -> t 280 | (** This function will be deprecated in a future release. 281 | Consider using the synonym function {!of_masks} instead. *) 282 | 283 | val of_masks : 'a poll_mask array -> t 284 | 285 | val poll : ?timeout:int -> t -> poll_event option array 286 | end 287 | 288 | module Monitor : sig 289 | type t 290 | 291 | type address = string 292 | type error_no = int 293 | type error_text = string 294 | 295 | type event = 296 | | Connected of address * Unix.file_descr 297 | | Connect_delayed of address 298 | | Connect_retried of address * int (*interval*) 299 | | Listening of address * Unix.file_descr 300 | | Bind_failed of address * error_no * error_text 301 | | Accepted of address * Unix.file_descr 302 | | Accept_failed of address * error_no * error_text 303 | | Closed of address * Unix.file_descr 304 | | Close_failed of address * error_no * error_text 305 | | Disconnected of address * Unix.file_descr 306 | | Monitor_stopped of address 307 | | Handshake_failed_no_detail of address 308 | | Handshake_succeeded of address 309 | | Handshake_failed_protocol of address * int 310 | | Handshake_failed_auth of address * int 311 | 312 | 313 | val create: 'a Socket.t -> t 314 | val connect: Context.t -> t -> [<`Monitor] Socket.t 315 | 316 | (** Receive an event from the monitor socket. 317 | block indicates if the call should be blocking or non-blocking. Default true 318 | *) 319 | val recv: ?block:bool -> [< `Monitor ] Socket.t -> event 320 | 321 | val string_of_event: event -> string 322 | 323 | (** Create a memorizing function for converting an event to a string. 324 | As its it not possible to reliably retrieve the peer address of a closed socket 325 | dues to a race condition, this function pairs connects and disconnects and returns the matching 326 | connect peer address to disconnects. 327 | 328 | Note that it is not possible to retrieve the peer address of connect events is the peer has disconnected 329 | before string_of_event is called 330 | *) 331 | val mk_string_of_event: unit -> (event -> string) 332 | 333 | end 334 | 335 | module Z85 : sig 336 | val encode : string -> string 337 | val decode : string -> string 338 | end 339 | 340 | module Curve : sig 341 | (** [keypair ()] returns a pair [public, secret] of Z85 encoded keys. *) 342 | val keypair : unit -> string * string 343 | end 344 | -------------------------------------------------------------------------------- /zmq/test/curve.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | (* random key generated with `curve_keygen` *) 4 | let z85_public = "^fh#binNS?sWfA=FHY#Rw2b{1{1kzB+Vr.kZzIAA" 5 | let z85_secret = "E9.KnISxjbj*R x) in 9 | let ctx = Zmq.Context.create () in 10 | let sock = Zmq.Socket.create ctx Zmq.Socket.pub in 11 | Zmq.Socket.set_curve_publickey sock z85_public; 12 | let pub = Zmq.Socket.get_curve_publickey sock in 13 | assert_equal ~msg:"Matching public key" z85_public pub; 14 | Zmq.Socket.set_curve_secretkey sock z85_secret; 15 | let sec = Zmq.Socket.get_curve_secretkey sock in 16 | assert_equal ~msg:"Matching private key" z85_secret sec; 17 | Zmq.Socket.set_curve_serverkey sock z85_public; 18 | let servpub = Zmq.Socket.get_curve_serverkey sock in 19 | assert_equal ~msg:"Matching server key" z85_public servpub; 20 | 21 | Zmq.Socket.close sock; 22 | Zmq.Context.terminate ctx 23 | 24 | let suite = "curve" >::: [ 25 | "set/get key" >:: test_set_get_key 26 | ] 27 | -------------------------------------------------------------------------------- /zmq/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries ounit2 zmq threads)) 4 | 5 | (rule 6 | (alias runtest) 7 | (deps 8 | (:test test.exe)) 9 | (action 10 | (run %{test}))) 11 | -------------------------------------------------------------------------------- /zmq/test/fd_usage.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open Zmq 3 | 4 | 5 | let string_of_event = function 6 | | Socket.No_event -> "No_event" 7 | | Poll_in -> "Poll_in" 8 | | Poll_out -> "Poll_out" 9 | | Poll_in_out -> "Poll_in_out" 10 | | Poll_error -> "Poll_error" 11 | 12 | (* Test fd, Send message, Test df, Read event, Test *) 13 | 14 | type 'a socket = { 15 | socket: 'a Socket.t; 16 | fd: Unix.file_descr; 17 | } 18 | 19 | let can_read socket = 20 | match Unix.select [socket.fd] [] [] 0.001 with 21 | | [], _, _ -> false 22 | | _, _, _ -> true 23 | 24 | let wait_readable socket = 25 | let rec inner = function 26 | | 0 -> false 27 | | n -> begin 28 | match can_read socket with 29 | | true -> true 30 | | false -> inner (n - 1) 31 | end 32 | in 33 | inner 10 34 | 35 | let wait_not_readable socket = 36 | let rec inner = function 37 | | 0 -> false 38 | | n -> begin 39 | match can_read socket with 40 | | true -> 41 | Socket.events socket.socket |> ignore; 42 | inner (n - 1) 43 | | false -> true 44 | end 45 | in 46 | inner 10 47 | 48 | 49 | (** Assert that t goes from last state to a new state when calling function f *) 50 | let assert_state ?msg ?f socket state = 51 | assert_bool "Fd did not settle into a non readable state" (wait_not_readable socket); 52 | let prev_state = Socket.events socket.socket in 53 | 54 | begin 55 | match f with 56 | | None -> () 57 | | Some f -> f (); 58 | end; 59 | 60 | (* Only expect the fd to become readable, if the state has a meaningfull change *) 61 | let expect_fd_change = match prev_state, state with 62 | | s, s' when s = s' -> false (* No state change *) 63 | | _, Socket.No_event (* From more to less *) 64 | | Poll_in_out, _ -> false 65 | | _ -> true 66 | in 67 | 68 | begin 69 | match expect_fd_change with 70 | | true -> 71 | begin 72 | match wait_readable socket with 73 | | true -> () 74 | | false -> 75 | let msg = Printf.sprintf "Socket did not become readable: %s -> %s (expected %s)" 76 | (string_of_event prev_state) 77 | (string_of_event (Socket.events socket.socket)) 78 | (string_of_event state) 79 | in 80 | assert_failure msg 81 | end 82 | | false -> () 83 | end; 84 | 85 | assert_equal ?msg 86 | ~printer:string_of_event state (Socket.events socket.socket); 87 | assert_bool "Fd did not settle into a non readable state" (wait_not_readable socket); 88 | assert_equal ?msg 89 | ~printer:string_of_event state (Socket.events socket.socket); 90 | () 91 | 92 | 93 | let setup typ_a typ_b _ = 94 | let ctx = Context.create () in 95 | let create typ = 96 | let socket = Zmq.Socket.create ctx typ in 97 | let fd = Socket.get_fd socket in 98 | Socket.set_send_high_water_mark socket 1; 99 | Socket.set_receive_high_water_mark socket 1; 100 | 101 | { socket; fd } 102 | in 103 | let a = create typ_a in 104 | let b = create typ_b in 105 | 106 | 107 | (ctx, a, b) 108 | 109 | let teardown (ctx, push, pull) = 110 | Socket.close pull.socket; 111 | Socket.close push.socket; 112 | Zmq.Context.terminate ctx 113 | 114 | let send ?more s () = 115 | Socket.send ?more s.socket ~block:false "test msg" 116 | 117 | let recv s () = 118 | Socket.recv s.socket |> ignore 119 | 120 | 121 | let test_unidir (_ctx, push, pull) = 122 | assert_state push Socket.No_event; 123 | assert_state pull Socket.No_event; 124 | 125 | (* Bind to an endpoint*) 126 | let endpoint = "inproc://fd_bidir_test" in 127 | Zmq.Socket.bind push.socket endpoint; 128 | 129 | (* I would have expected the socket to go into a Pull_out state *) 130 | assert_state push Socket.No_event; 131 | 132 | assert_state push Socket.Poll_out 133 | ~f:(fun () -> Socket.connect pull.socket endpoint); 134 | 135 | assert_state pull Socket.No_event; 136 | 137 | (* Sending a message will change the state of pull *) 138 | assert_state pull Socket.Poll_in ~f:(send push); 139 | assert_state push Socket.Poll_out; 140 | 141 | (* Reading the message will change the state of pull, as there are 142 | no more messages *) 143 | assert_state pull Socket.No_event ~f:(recv pull); 144 | assert_state push Socket.Poll_out; 145 | 146 | 147 | (* Fill up the queues *) 148 | assert_state pull Socket.Poll_in ~f:(send push); 149 | assert_state push Socket.Poll_out; 150 | assert_state push Socket.No_event ~f:(send push); 151 | assert_state pull Socket.Poll_in; 152 | 153 | (* Reading a message will make the push socket ready for send again *) 154 | assert_state push Socket.Poll_out ~f:(recv pull); 155 | assert_state pull Socket.Poll_in; 156 | 157 | (* We can send more after the first send_more. *) 158 | assert_state push Socket.Poll_out ~f:(send ~more:true push); 159 | assert_state push Socket.Poll_out ~f:(send ~more:true push); 160 | 161 | (* Reading off the next message will yeild no more message *) 162 | assert_state pull Socket.No_event ~f:(recv pull); 163 | 164 | assert_state pull Socket.Poll_in ~f:(send ~more:false push); 165 | 166 | assert_state push Socket.No_event ~f:(send push); 167 | 168 | (* Starting to read the multipart message will not allow us to send more *) 169 | assert_state push Socket.No_event ~f:(recv pull); 170 | assert_state pull Socket.Poll_in; 171 | assert_bool "Expected more messages" (Socket.has_more pull.socket); 172 | 173 | assert_state push Socket.No_event ~f:(recv pull); 174 | assert_state pull Socket.Poll_in; 175 | assert_bool "Expected more messages" (Socket.has_more pull.socket); 176 | 177 | (* Reading off the last message will make the push socket ready again *) 178 | assert_state push Socket.Poll_out ~f:(recv pull); 179 | assert_state pull Socket.Poll_in; 180 | assert_bool "no more messages expected" (Socket.has_more pull.socket |> not); 181 | 182 | () 183 | 184 | let test_bidir (_ctx, s_a, s_b) = 185 | (* Test how socket notifies state based on event avilability *) 186 | let endpoint = "inproc://fd_bidir_test" in 187 | Zmq.Socket.bind s_a.socket endpoint; 188 | Zmq.Socket.connect s_b.socket endpoint; 189 | 190 | (* all buffers are empty, all can send *) 191 | assert_state s_a Socket.Poll_out; 192 | assert_state s_b Socket.Poll_out; 193 | 194 | (* Push a message on a will not change a's state but b can receive *) 195 | assert_state s_b Socket.Poll_in_out ~f:(send s_a); 196 | assert_state s_a Socket.Poll_out; 197 | 198 | (* Send again, and s_a cannot send any more *) 199 | assert_state s_a Socket.No_event ~f:(send s_a); 200 | 201 | (* Send from b -> a, makes are readable *) 202 | assert_state s_a Socket.Poll_in ~f:(send s_b); 203 | assert_state s_b Socket.Poll_in_out; 204 | 205 | (* Send again => all queues are full. 206 | and b can only read *) 207 | assert_state s_a Socket.Poll_in ~f:(send s_b); 208 | assert_state s_b Socket.Poll_in; 209 | 210 | (* Reading a message on a changes b's state *) 211 | assert_state s_b Socket.Poll_in_out ~f:(recv s_a); 212 | () 213 | 214 | 215 | let suite = 216 | "zmq" >::: 217 | [ 218 | "unidir" >:: bracket (setup Zmq.Socket.push Zmq.Socket.pull) 219 | test_unidir 220 | teardown; 221 | 222 | "bidir" >:: bracket (setup Zmq.Socket.pair Zmq.Socket.pair) 223 | test_bidir 224 | teardown; 225 | ] 226 | -------------------------------------------------------------------------------- /zmq/test/test.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | let suite = "Zmq" >::: 4 | [ 5 | Zmq_test.suite; 6 | Fd_usage.suite; 7 | Curve.suite; 8 | ] 9 | 10 | let _ = 11 | run_test_tt_main suite 12 | -------------------------------------------------------------------------------- /zmq/test/zmq_test.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | open Zmq 4 | open Zmq.Context 5 | open Zmq.Socket 6 | open Zmq.Poll 7 | 8 | let debug fmt = 9 | Printf.ksprintf (fun s -> print_endline s; flush stdout) fmt 10 | 11 | let sleep t = ignore(Unix.select [] [] [] ((float t) /. 1000.0)) 12 | 13 | let dump_events l = 14 | let f = function 15 | | None -> "None" 16 | | Some In -> "In" 17 | | Some Out -> " Out" 18 | | Some In_out -> "In/Out" 19 | in 20 | let l = Array.to_list (Array.map f l) in 21 | "[|" ^ (String.concat "; " l) ^ "|]" 22 | 23 | let test_ctx_options () = 24 | let ctx = Context.create () in 25 | 26 | let test_set_get_int msg setter getter ctx v = 27 | let default = getter ctx in 28 | setter ctx v; 29 | assert_equal ~msg ~printer:string_of_int v (getter ctx); 30 | setter ctx default; 31 | assert_equal ~msg default (getter ctx); 32 | () 33 | in 34 | 35 | let test_set_get_bool msg setter getter ctx v = 36 | let default = getter ctx in 37 | setter ctx v; 38 | assert_equal ~msg ~printer:string_of_bool v (getter ctx); 39 | setter ctx default; 40 | assert_equal ~msg default (getter ctx); 41 | () 42 | in 43 | 44 | test_set_get_int "IO threads" set_io_threads get_io_threads ctx 1; 45 | test_set_get_int "Max sockets" set_max_sockets get_max_sockets ctx 1024; 46 | test_set_get_bool "IPv6" Context.set_ipv6 Context.get_ipv6 ctx false; 47 | Context.terminate ctx 48 | 49 | let test_socket_options () = 50 | let ctx = Context.create () in 51 | let socket = create ctx push in 52 | 53 | 54 | let test_set_get_int msg setter getter socket v = 55 | let default = getter socket in 56 | setter socket v; 57 | assert_equal ~msg ~printer:string_of_int v (getter socket); 58 | setter socket default; 59 | assert_equal ~msg default (getter socket); 60 | () 61 | in 62 | 63 | let test_set_get_value msg setter getter socket v = 64 | let default = getter socket in 65 | setter socket v; 66 | assert_equal ~msg ~printer:(function `Default -> "default" | `Value n -> string_of_int n) v (getter socket); 67 | setter socket default; 68 | assert_equal ~msg default (getter socket); 69 | () 70 | in 71 | 72 | (* Verify that the default max_message_size returns is -1 *) 73 | assert_equal ~msg:"Default max message size" ~printer:string_of_int (get_max_message_size socket) (-1); 74 | 75 | test_set_get_int "Highwatermark" set_receive_high_water_mark get_receive_high_water_mark socket 1235; 76 | test_set_get_int "Affinity" set_affinity get_affinity socket 3; 77 | test_set_get_int "Max message size" set_max_message_size get_max_message_size socket 65537; 78 | test_set_get_int "Receive timeout" set_receive_timeout get_receive_timeout socket 1000; 79 | test_set_get_value "Tcp keepalive interval" set_tcp_keepalive_interval get_tcp_keepalive_interval socket (`Value 1000); 80 | 81 | Socket.close socket; 82 | 83 | (* Must be a `Stream. No getter so just test that it doesn't explode. *) 84 | let stream_socket = create ctx stream in 85 | set_stream_notify stream_socket true; 86 | set_stream_notify stream_socket false; 87 | Socket.close stream_socket; 88 | 89 | Context.terminate ctx; 90 | () 91 | 92 | let test_monitor () = 93 | let endpoint = "ipc://monitor_socket" in 94 | let expect_handshake = match Zmq.version () with 95 | | (4, n, _) when n < 3 -> false 96 | | (3, _, _) -> failwith "Only zmq version 4 or higher is supported" 97 | | _ -> true 98 | in 99 | 100 | let assert_event name socket event = 101 | let printer x = x in 102 | let rec cmp str1 str2 = 103 | match String.length str1 <= String.length str2 with 104 | | true -> String.sub str2 0 (String.length str1) = str1 105 | | false -> cmp str2 str1 106 | in 107 | let rec receive_event ~end_time = 108 | match Zmq.Monitor.recv ~block:false socket with 109 | | event -> Zmq.Monitor.string_of_event event 110 | | exception Invalid_argument(s) -> 111 | Printf.eprintf "Warning: Invalid_argument: %s\n" s; 112 | receive_event ~end_time 113 | | exception Unix.Unix_error(Unix.EAGAIN, _, _) when end_time > (Unix.gettimeofday ()) -> 114 | sleep 10; 115 | receive_event ~end_time 116 | | exception Unix.Unix_error(Unix.EAGAIN, _, _) -> "No event received" 117 | in 118 | let received = receive_event ~end_time:(Unix.gettimeofday () +. 1.0) in 119 | assert_equal ~msg:(Printf.sprintf "Wrong event received on %s" name) ~printer ~cmp 120 | (Printf.sprintf "%s: %s" event endpoint) received 121 | in 122 | let ctx = Context.create () in 123 | let s1 = Zmq.Socket.create ctx Zmq.Socket.pair in 124 | let s2 = Zmq.Socket.create ctx Zmq.Socket.pair in 125 | let m1 = 126 | let mon_t = Zmq.Monitor.create s1 in 127 | Zmq.Monitor.connect ctx mon_t 128 | in 129 | let m2 = 130 | let mon_t = Zmq.Monitor.create s2 in 131 | Zmq.Monitor.connect ctx mon_t 132 | in 133 | Zmq.Socket.bind s1 endpoint; 134 | assert_event "m1" m1 "Listening"; 135 | Zmq.Socket.connect s2 endpoint; 136 | assert_event "m1" m1 "Accepted"; 137 | assert_event "m2" m2 "Connect"; 138 | if (expect_handshake) then begin 139 | assert_event "m1" m1 "Handshake_succeeded"; 140 | assert_event "m2" m2 "Handshake_succeeded" 141 | end; 142 | Zmq.Socket.close s1; 143 | assert_event "m1" m1 "Closed"; 144 | assert_event "m1" m1 "Monitor_stopped"; 145 | assert_event "m2" m2 "Disconnect"; 146 | Zmq.Socket.close s2; 147 | 148 | Zmq.Socket.close m2; 149 | Zmq.Socket.close m1; 150 | Context.terminate ctx; 151 | () 152 | 153 | let test_proxy () = 154 | let ctx = Zmq.Context.create () in 155 | let pull_endpoint = "inproc://pull" in 156 | let pub_endpoint = "inproc://pub" in 157 | let pull = Zmq.Socket.create ctx pull in 158 | let pub = Zmq.Socket.create ctx pub in 159 | 160 | let proxy (pull, pub) = 161 | Zmq.Socket.bind pull pull_endpoint; 162 | Zmq.Socket.bind pub pub_endpoint; 163 | (* Start the proxy and start relaying messages *) 164 | try 165 | Zmq.Proxy.create pull pub; 166 | assert_failure "Proxy.create must raise an exception when completed" 167 | with 168 | Unix.Unix_error (Unix.ENOTSOCK, _, _) -> () 169 | in 170 | 171 | let _thread = Thread.create proxy (pull, pub) in 172 | sleep 10; (* Wait until the proxy has been created *) 173 | let sub = 174 | let s = Zmq.Socket.create ctx sub in 175 | Zmq.Socket.connect s pub_endpoint; 176 | Zmq.Socket.subscribe s ""; 177 | s 178 | in 179 | let push = 180 | let s = Zmq.Socket.create ctx push in 181 | Zmq.Socket.connect s pull_endpoint; 182 | s 183 | in 184 | let msg1 = "Message1" in 185 | let msg2 = "Message2" in 186 | Zmq.Socket.send push msg1; 187 | Zmq.Socket.send push msg2; 188 | assert_equal msg1 (Zmq.Socket.recv sub); 189 | assert_equal msg2 (Zmq.Socket.recv sub); 190 | 191 | (* Epilog *) 192 | Zmq.Socket.close sub; 193 | Zmq.Socket.close push; 194 | Zmq.Socket.close pull; 195 | Zmq.Socket.close pub; 196 | Zmq.Context.terminate ctx; 197 | () 198 | 199 | (** Simple test to test interrupted exception, while in the C lib. *) 200 | let test_unix_exceptions = bracket 201 | (fun () -> 202 | let ctx = Zmq.Context.create () in 203 | let s = Zmq.Socket.create ctx pull in 204 | (ctx, s) 205 | ) 206 | (fun (_, s) -> 207 | 208 | let mask = Zmq.Poll.of_masks [| s, Zmq.Poll.In |] in 209 | Sys.(set_signal sigalrm (Signal_handle (fun _ -> ()))); 210 | ignore (Unix.alarm 1); 211 | assert_raises ~msg:"Failed to raise EINTR" Unix.(Unix_error(EINTR, "zmq_poll", "")) (fun _ -> Zmq.Poll.poll ~timeout:2000 mask); 212 | () 213 | ) 214 | (fun (ctx, s) -> 215 | Zmq.Socket.close s; 216 | Zmq.Context.terminate ctx 217 | ) 218 | 219 | (** Test a Zmq specific exception *) 220 | let test_zmq_exception = bracket 221 | (fun () -> 222 | let ctx = Zmq.Context.create () in 223 | let socket = Zmq.Socket.create ctx req in 224 | (ctx, socket) 225 | ) 226 | (fun (_, socket) -> 227 | assert_raises 228 | (Zmq.ZMQ_exception(Zmq.EFSM, "Operation cannot be accomplished in current state")) 229 | (fun () -> Zmq.Socket.recv socket); 230 | ) 231 | (fun (ctx, socket) -> 232 | Zmq.Socket.close socket; 233 | Zmq.Context.terminate ctx; 234 | ) 235 | 236 | let test_socket_gc () = 237 | let sock = 238 | let ctx = Zmq.Context.create () in 239 | Zmq.Socket.create ctx Zmq.Socket.req 240 | in 241 | (* This will hang trying to terminate the context if socket doesn't keep it alive *) 242 | Gc.compact (); 243 | Zmq.Socket.close sock; 244 | Gc.compact () (* Clean up the context.*) 245 | 246 | let test_context_gc () = 247 | let ctx = 248 | let ctx = Zmq.Context.create () in 249 | let sock = Zmq.Socket.create ctx Zmq.Socket.pair in 250 | Zmq.Socket.connect sock "ipc://context_gc_socket"; 251 | Zmq.Socket.send sock "test"; 252 | ctx 253 | in 254 | (* At this point, ctx is alive. The garbage collector needs to set 255 | so_linger when closing the socket, or it the system will hang when 256 | trying to terminate the context. *) 257 | Gc.compact (); 258 | Zmq.Context.terminate ctx; 259 | () 260 | 261 | let test_z85 () = 262 | let binary = "\xBB\x88\x47\x1D\x65\xE2\x65\x9B" ^ 263 | "\x30\xC5\x5A\x53\x21\xCE\xBB\x5A" ^ 264 | "\xAB\x2B\x70\xA3\x98\x64\x5C\x26" ^ 265 | "\xDC\xA2\xB2\xFC\xB4\x3F\xC5\x18" in 266 | let ascii = "Yne@$w-vo Zmq.Z85.encode "123"); 271 | assert_raises (Invalid_argument "zmq_z85_decode") (fun () -> Zmq.Z85.decode "123"); 272 | () 273 | 274 | let suite = 275 | "zmq test" >::: 276 | [ 277 | "request reply" >:: 278 | (bracket 279 | (fun () -> 280 | let ctx = Zmq.Context.create () in 281 | let req = create ctx req in 282 | let rep = create ctx rep in 283 | ctx, req, rep 284 | ) 285 | (fun (_, req, rep) -> 286 | let endpoint = "inproc://endpoint" in 287 | bind rep endpoint; 288 | connect req endpoint; 289 | send req "request"; 290 | let msg = recv rep in 291 | assert_equal "request" msg; 292 | send rep "reply"; 293 | let msg = recv req in 294 | assert_equal "reply" msg 295 | ) 296 | (fun (ctx, req, rep) -> 297 | close req; 298 | close rep; 299 | Zmq.Context.terminate ctx 300 | )); 301 | 302 | "request reply (multi-part)" >:: 303 | (bracket 304 | (fun () -> 305 | let ctx = Zmq.Context.create () in 306 | let req = create ctx req in 307 | let rep = create ctx rep in 308 | ctx, req, rep 309 | ) 310 | (fun (_, req, rep) -> 311 | let endpoint = "inproc://endpoint" in 312 | bind rep endpoint; 313 | connect req endpoint; 314 | send_all req ["request"; "and more"]; 315 | let msg = recv_all rep in 316 | assert_equal ["request"; "and more"] msg; 317 | send_all rep ["reply"; "and more"]; 318 | let msg = recv_all req in 319 | assert_equal ["reply"; "and more"] msg 320 | ) 321 | (fun (ctx, req, rep) -> 322 | close req; 323 | close rep; 324 | Zmq.Context.terminate ctx 325 | )); 326 | 327 | "poll" >:: 328 | (bracket 329 | (fun () -> 330 | let ctx = Zmq.Context.create () in 331 | let req = create ctx req in 332 | let rep = create ctx rep in 333 | let sub = create ctx sub in 334 | ctx, req, rep, sub 335 | ) 336 | (fun (_, req, rep, sub) -> 337 | let endpoint = "inproc://endpoint" in 338 | 339 | bind rep endpoint; 340 | connect req endpoint; 341 | subscribe sub ""; 342 | let mask = of_masks [| Poll.mask_in_out req; Poll.mask_in_out rep; Poll.mask_in_out sub |] in 343 | assert_equal [| Some Out; None; None |] (poll ~timeout:1000 mask); 344 | send req "request"; 345 | assert_equal [| None; Some In; None |] (poll ~timeout:1000 mask); 346 | let msg = recv ~block:false rep in 347 | assert_equal "request" msg; 348 | send rep "reply"; 349 | assert_equal [| Some In; None; None |] (poll ~timeout:1000 mask); 350 | let msg = recv req in 351 | assert_equal "reply" msg; 352 | ) 353 | (fun (ctx, req, rep, sub) -> 354 | close req; 355 | close rep; 356 | close sub; 357 | Zmq.Context.terminate ctx; 358 | )); 359 | "get/set context options" >:: test_ctx_options; 360 | "get/set socket options" >:: test_socket_options; 361 | "proxy" >:: test_proxy; 362 | "monitor" >:: test_monitor; 363 | "z85 encoding/decoding" >:: test_z85; 364 | "unix exceptions" >:: test_unix_exceptions; 365 | "zmq exceptions" >:: test_zmq_exception; 366 | (* Gc tests disabled, as resources will not be freed through finalisers 367 | "socket gc" >:: test_socket_gc; 368 | "context gc" >:: test_context_gc; 369 | *) 370 | ] 371 | --------------------------------------------------------------------------------