├── .github └── workflows │ └── workflow.yml ├── .gitignore ├── .gitmodules ├── Changelog ├── Makefile ├── README.md ├── TODO ├── amqp-client-async.opam ├── amqp-client-lwt.opam ├── amqp-client.opam ├── async ├── src │ ├── amqp.ml │ ├── channel.ml │ ├── channel.mli │ ├── connection.ml │ ├── connection.mli │ ├── dune │ ├── exchange.ml │ ├── exchange.mli │ ├── framing.ml │ ├── framing.mli │ ├── message.ml │ ├── message.mli │ ├── protocol_helpers.ml │ ├── queue.ml │ ├── queue.mli │ ├── rpc.ml │ ├── rpc.mli │ ├── thread.ml │ └── thread.mli └── test │ ├── amqp.ml │ ├── channel_test.ml │ ├── close_test.ml │ ├── connect_uri_test.ml │ ├── connection_fail_test.ml │ ├── connection_test.ml │ ├── dune │ ├── exchange_test.ml │ ├── mandatory_test.ml │ ├── queue_cancel_test.ml │ ├── queue_declare_test.ml │ ├── queue_test.ml │ ├── repeat.ml │ ├── rpc_async_test.ml │ ├── rpc_test.ml │ ├── vhost_test.ml │ └── with_confirm_test.ml ├── dune-project ├── examples ├── dune ├── main.ml ├── multi_receive.ml ├── on_closed.ml ├── rpc_client.ml └── rpc_server.ml ├── lib ├── dune ├── io.ml ├── mlist.ml ├── ocaml_lib.ml ├── option.ml ├── protocol.ml ├── test │ ├── dune │ └── mlist_test.ml ├── thread.ml └── types.ml ├── license.txt ├── link ├── async_link.ml ├── dune └── lwt_link.ml ├── lwt ├── src │ ├── dune │ ├── thread.ml │ └── thread.mli └── test │ ├── amqp.ml │ └── dune ├── other ├── .gitignore ├── Makefile ├── amqp.py ├── netamqp_test.ml ├── pika_async.py └── rabbitmq-c.c └── spec ├── amqp0-9-1.extended.xml ├── dune └── gen_spec.ml /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | - push 5 | - workflow_dispatch 6 | 7 | jobs: 8 | build: 9 | services: 10 | rabbitmq: 11 | image: rabbitmq 12 | ports: 13 | - 5672/tcp 14 | 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | os: 19 | - ubuntu-latest 20 | ocaml-compiler: 21 | - 4.14.0 22 | - 5 23 | concurrency: 24 | - async 25 | - lwt 26 | 27 | runs-on: ${{ matrix.os }} 28 | 29 | steps: 30 | - name: Checkout code 31 | uses: actions/checkout@v3 32 | 33 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 34 | uses: ocaml/setup-ocaml@v2 35 | with: 36 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 37 | 38 | - run: opam pin . --no-action 39 | - run: opam install amqp-client amqp-client-${{ matrix.concurrency }} --deps-only --with-doc --with-test 40 | - run: opam exec -- dune build -p amqp-client,amqp-client-${{ matrix.concurrency }} 41 | - run: opam exec -- dune runtest -p amqp-client,amqp-client-${{ matrix.concurrency }} 42 | 43 | - run: opam exec -- dune build @integration -p amqp-client,amqp-client-${{ matrix.concurrency }} 44 | env: 45 | AMQP_PORT: ${{ job.services.rabbitmq.ports[5672] }} 46 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | _build 3 | \#*# 4 | .#* 5 | html 6 | .merlin 7 | amqp-client*.install 8 | tests/jbuild 9 | amqp-client.[0-9].* 10 | /_opam/ 11 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "html"] 2 | path = html 3 | url = git@github.com:andersfugmann/ocaml-amqp.git 4 | branch = gh-pages 5 | -------------------------------------------------------------------------------- /Changelog: -------------------------------------------------------------------------------- 1 | 2.3.0: (2023-12-21) 2 | * Add optional `how` parameter to thread list init signature 3 | * async: Upgrade min required async version to v0.16.0 4 | * async: Replace usage of deprecated `Core.Time` with `Core.Time_float` 5 | * Allow creation of internal exchanges (only useful for use with rabbitmq). Thanks hongchangwu 6 | * Update amqp spec 7 | * Remove dependency on ocplib-endian 8 | * Bump minimum ocaml version to 4.14 9 | 10 | 2.2.2: (2020-05-10) 11 | * Switch to (ez)xmlm as build dependency 12 | * Add optional argument `autogenerate` to allow declaring queues with 13 | empty names (by NightBlues) 14 | 15 | 2.2.1: (2019-09-03) 16 | * Fix RPC client ttl second and millis mismatch. 17 | The ttl is now consistently in milli seconds, and ttl set on the message sent is 18 | the same as the maximum wait time (previous behaviour was to wait ttl * 1000 ms). 19 | (by AndreasDahl) 20 | * Handle errors when establishing connection early (#35) 21 | * Add grace_time_ms to rpc calls to give the remote rpc server some time to process the message 22 | 23 | 2.2.0: (2019-07-23) 24 | * Make Pipe.Reader / Pipe.write non-opaque for async version 25 | * Fix handling of on_closed if the connection is unexpectedly closed by the server. 26 | * Fix incorrect order when handling responses for the same message type (#32) 27 | 28 | 2.1.0: (2018-10-26) 29 | * Use dune commands in makefile 30 | * Reimplement Ivar for lwt based on Lwt.wait 31 | * Add on_closed function for channels and connections 32 | * Support consumer cancellation from server 33 | * Add connect_uri to connect using uri. 34 | 35 | 2.0.3: 36 | * Fix compilation on 4.07 37 | * Switch to dune build system 38 | 39 | 2.0.2: 40 | * Add rabbitmq AMQP spec to git repository to fix sandbox compilation 41 | (Leonidas-from-XIV) 42 | 43 | 2.0.1: 44 | * Compatibility with lwt 4.0.0 45 | 46 | 2.0.0: 47 | * Split into amqp-client-async and amqp-client-lwt 48 | 49 | 1.1.5: 50 | * Compatible with core/async v0.10 51 | 52 | 1.1.4: 53 | * Support immutable strings 54 | 55 | 1.1.3: 56 | * Fix bug in handling confirmation message with would cause a hang when 57 | sending multiple messages concurrently 58 | 59 | 1.1.2: 60 | * Reinclude async version of the library 61 | 62 | 1.1.1: 63 | * Let jbuilder wrap the library 64 | * Use jbuilder to generate documentation 65 | * Allow empty queue name to have AMQP specify name (closes #4) 66 | 67 | 1.1.0: 68 | * Handle mandatory flag on channels with confirm set 69 | * Fix bug where message would always be signalled as delivered 70 | successfully even if delivery failed. 71 | * Allow multiple listeners for returned messages 72 | * Minor optimizations and code improvements 73 | * Fixed bug in lwt thread causing flush to hang for ever if 74 | there are no consumers 75 | * Switch build system to jbuild 76 | * Add backward compatabilty to async < 0.9 77 | * Allow specification of correlation id per rpc call 78 | * Wait at most ttl for rpc replies (by Leonidas-from-XIV) 79 | 80 | 1.0.7: 81 | * Enable travis ci 82 | 83 | 1.0.6: 84 | * Delete amqp_thread.mli, as it makes Deferred.t opaque and makes it 85 | impossible to use with existing threading system (lwt / async) as 86 | intended. Tests has been exteded to make sure this does not happen again. 87 | 88 | 1.0.5: 89 | * Compile against async 0.9 90 | 91 | 1.0.4: 92 | * Fix lwt compilation 93 | 94 | 1.0.3: 95 | * Fix parsing of array in message headers. 96 | * Log through thread library (Async.Std.Log / Lwt_log_core) 97 | * Copy .cmx files to avoid warning 58 - patch by Satoshi Ogasawara 98 | 99 | 1.0.2: 100 | * Allow buffers to be in the output chain forever. 101 | * Fix crash when all channels are requested blocked / unblocked by the server 102 | 103 | 1.0.0: 104 | * Compatible with 4.03.0 105 | * Allow extra arguments to exchange declare 106 | 107 | 0.9.9: 108 | * Improve error handling when connection closes unexpectedly 109 | 110 | 0.9.0: 111 | * Added support for Lwt in addition to Async 112 | * Remove dependency on Core 113 | * Split into amqp-client.async and amqp-client.lwt findlib packages 114 | and autodetect which libraries are installed and install appropriate versions 115 | of the library 116 | 117 | 0.2.0: 118 | * Library renamed to amqp-client 119 | * Fix bug when heartbeats are disabled serverside. 120 | * Use polymorphic variants when binding to exchanges 121 | 122 | 0.1.1: 123 | * Flush on channel / connection close 124 | * Implement connection close 125 | * Replace hash tables with arrays 126 | * Add per channel transaction support 127 | * Limit number of queued messages 128 | * Add channel recover 129 | * Allow specification of hearbeat freq to detect connection stalls 130 | 131 | 0.1.0: 132 | * Less data copying when constructing messages 133 | * Use Core's endian functions 134 | * Exchange.t is now a gadt to indicate type of bind arguments 135 | * Handle channel flow messages. 136 | Publishing messages will now wait until the channel is open 137 | * Handle RabbitMQ's Connection block / unblock messages 138 | * Some refactoring of protocol helpers 139 | 140 | 141 | 0.0.1: Initial release 142 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all build clean test install update-version update-spec doc commit-doc 2 | all: build 3 | 4 | build: 5 | dune build @all 6 | 7 | clean: 8 | dune clean 9 | 10 | test: 11 | dune runtest 12 | 13 | install: 14 | dune build @install 15 | dune install 16 | 17 | uninstall: 18 | dune uninstall 19 | 20 | # Run tests. 21 | tests/%.exe: tests/%.ml 22 | dune build $@ 23 | 24 | integration: 25 | dune build @integration 26 | 27 | examples: 28 | dune build @examples 29 | 30 | update-version: VERSION=$(shell head -n 1 Changelog | sed 's/:.*//') 31 | update-version: 32 | @echo "Set version to: $(VERSION)" 33 | @git tag --force $(VERSION) 34 | @sed -i 's/version = ".*"/version = "$(VERSION)"/' async/src/connection.ml 35 | 36 | update-spec: 37 | @echo "Retrieving AMQP spec from RabbitMQ servers" 38 | curl --fail https://www.rabbitmq.com/resources/specs/amqp0-9-1.extended.xml > spec/amqp0-9-1.extended.xml 39 | 40 | doc: 41 | dune build @doc 42 | 43 | gh-pages: doc 44 | git clone `git config --get remote.origin.url` .gh-pages --reference . 45 | git -C .gh-pages checkout --orphan gh-pages 46 | git -C .gh-pages reset 47 | git -C .gh-pages clean -dxf 48 | cp -r _build/default/_doc/_html/* .gh-pages 49 | git -C .gh-pages add . 50 | git -C .gh-pages config user.email 'docs@amqp-client' 51 | git -C .gh-pages commit -m "Update documentation" 52 | git -C .gh-pages push origin gh-pages -f 53 | rm -rf .gh-pages 54 | 55 | release: update-version 56 | opam publish 57 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OCaml client library for AMQP 2 | ============================= 3 | [![Main workflow](https://github.com/andersfugmann/amqp-client/actions/workflows/workflow.yml/badge.svg)](https://github.com/andersfugmann/amqp-client/actions/workflows/workflow.yml) 4 | 5 | Amqp-client is a AMQP client library written in pure OCaml. The 6 | library implements AMQP protocol version 0.9.1 as well as RabbitMQ-specific 7 | extensions. It supports both Core Async and Lwt threading models. 8 | 9 | Amqp-client is tested extensively against RabbitMQ, but should work 10 | with any AMQP server. 11 | 12 | The library exposes low level protocol handling through ```Amqp_spec``` 13 | and ```Amqp_framing``` modules as well as a high level interface 14 | though module ```Amqp```. 15 | 16 | The high level interface exposes usage patterns such as 17 | * create queue 18 | * consume from a queue 19 | * post message to a queue 20 | * create exchange 21 | * bind a queue to an exchange 22 | * post message to an exchange 23 | * RPC client / server 24 | 25 | The library requires all resources to be explicitly allocated to avoid 26 | crashes because a service is relying on other services to allocate 27 | AMQP resources (exchanges, queues etc.). 28 | 29 | Channels and consumers are tagged with an id, host name, pid etc. to 30 | ease tracing on AMQP level. 31 | 32 | The design philiosiphy of the library is *fail fast*, meaning that if 33 | any external state changes (e.g. connection closes unexpectibly, queu 34 | consumption is cancelled) an exception is raised, and It is adviced to 35 | let the process crash and restart initialization rather than going 36 | through the complex task of reparing the state. 37 | 38 | [Documentation for the API](http://andersfugmann.github.io/amqp-client/index.html). 39 | 40 | ### Build infrastructure 41 | 42 | The system is not functorized over an abstraction to the threading 43 | model. Instead the build system chooses which threading model 44 | abstraction to be used and stacially compiles it in. This has the 45 | advantage that files do not need to carry functor boilerplate 46 | 47 | The disadvantage is that it does not allow users to supply their own 48 | threading model implementation. 49 | 50 | #### Opam 51 | It is recommended to install the package though opam. 52 | You should choose the package matching the concurrency library that your application will use 53 | 54 | For Janestreet async: `opam install amqp-client-async` 55 | 56 | For Ocsigen Lwt: `opam install amqp-client-lwt` 57 | 58 | #### Manual build 59 | 60 | To build the library 61 | 62 | ```make build``` 63 | 64 | ```make install``` will install both Lwt and Async versions. 65 | 66 | ### Using the library 67 | 68 | To compile using Async do: 69 | 70 | ```ocamlfind ocamlopt -thread -package amqp-client-async myprog.ml``` 71 | 72 | To compile using the Lwt version of the library do: 73 | 74 | ```ocamlfind ocamlopt -thread -package amqp-client-lwt myprog.ml``` 75 | 76 | ### Examples 77 | 78 | #### Async 79 | Install the async version of the library: `opam install amqp-client-async` 80 | 81 | ```ocaml 82 | open Async 83 | open Amqp_client_async 84 | 85 | let host = "localhost" 86 | 87 | let run () = 88 | Amqp.Connection.connect ~id:"MyConnection" host >>= fun connection -> 89 | Amqp.Connection.open_channel ~id:"MyChannel" Amqp.Channel.no_confirm connection >>= fun channel -> 90 | Amqp.Queue.declare channel "MyQueue" >>= fun queue -> 91 | Amqp.Queue.publish channel queue (Amqp.Message.make "My Message Payload") >>= function `Ok -> 92 | Amqp.Channel.close channel >>= fun () -> 93 | Amqp.Connection.close connection >>= fun () -> 94 | Shutdown.shutdown 0; return () 95 | 96 | let _ = 97 | Thread_safe.block_on_async_exn run 98 | ``` 99 | 100 | Compile with: 101 | ``` 102 | $ ocamlfind ocamlopt -thread -package amqp-client-async amqp_example.ml -linkpkg -o amqp_example 103 | ``` 104 | 105 | #### Lwt 106 | Install the lwt version of the library: `opam install amqp-client-lwt` 107 | 108 | ```ocaml 109 | open Lwt.Infix 110 | open Amqp_client_lwt 111 | 112 | let host = "localhost" 113 | 114 | let run () = 115 | Amqp.Connection.connect ~id:"MyConnection" host >>= fun connection -> 116 | Amqp.Connection.open_channel ~id:"MyChannel" Amqp.Channel.no_confirm connection >>= fun channel -> 117 | Amqp.Queue.declare channel "MyQueue" >>= fun queue -> 118 | Amqp.Queue.publish channel queue (Amqp.Message.make "My Message Payload") >>= function `Ok -> 119 | Amqp.Channel.close channel >>= fun () -> 120 | Amqp.Connection.close connection >>= fun () -> 121 | Lwt.return () 122 | 123 | let _ = 124 | Lwt_main.run (run ()) 125 | ``` 126 | 127 | Compile with: 128 | 129 | ``` 130 | $ ocamlfind ocamlopt -thread -package amqp-client-lwt amqp_example.ml -linkpkg -o amqp_example 131 | ``` 132 | 133 | More examples are available here: https://github.com/andersfugmann/amqp-client/tree/master/examples 134 | 135 | To compile the examples do: `make examples`, which will place the 136 | binaries under `_build/default/examples/`. 137 | 138 | It is recommended to use *dune* for building projects and not invoke 139 | ocaml/ocamlfind from the command line explicitly. 140 | 141 | A simple dune file for a project with one file called: `example.ml` looks like this: 142 | 143 | ```lisp 144 | (executable 145 | (name example) 146 | (libraies amqp-client-async) 147 | ) 148 | ``` 149 | To build do `dune build example.exe`. For more information on dune, 150 | see https://dune.readthedocs.io/en/latest/ 151 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * Fix connection stalls 2 | * Fix non-existing vhosts connection stalls 3 | -------------------------------------------------------------------------------- /amqp-client-async.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: [ "Anders Fugmann" ] 4 | homepage: "https://github.com/andersfugmann/amqp-client" 5 | bug-reports: "https://github.com/andersfugmann/amqp-client/issues" 6 | dev-repo: "git+https://github.com/andersfugmann/amqp-client.git" 7 | doc: "https://andersfugmann.github.io/amqp-client/amqp-client-async/Amqp_client_async/" 8 | license: "BSD-3-Clause" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.14.0"} 15 | "dune" {>= "2.0"} 16 | "amqp-client" {= version} 17 | "async" {>= "v0.16.0"} 18 | "uri" 19 | ] 20 | synopsis: "Amqp client library, async version" 21 | -------------------------------------------------------------------------------- /amqp-client-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: [ "Anders Fugmann" ] 4 | homepage: "https://github.com/andersfugmann/amqp-client" 5 | bug-reports: "https://github.com/andersfugmann/amqp-client/issues" 6 | dev-repo: "git+https://github.com/andersfugmann/amqp-client.git" 7 | doc: "https://andersfugmann.github.io/amqp-client/amqp-client-lwt/Amqp_client_lwt/" 8 | license: "BSD-3-Clause" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.14.0"} 15 | "dune" {>= "2.0"} 16 | "amqp-client" {= version} 17 | "lwt" {>= "2.4.6"} 18 | "lwt_log" 19 | "uri" 20 | ] 21 | synopsis: "Amqp client library, lwt version" 22 | -------------------------------------------------------------------------------- /amqp-client.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: [ "Anders Fugmann" ] 4 | homepage: "https://github.com/andersfugmann/amqp-client" 5 | bug-reports: "https://github.com/andersfugmann/amqp-client/issues" 6 | dev-repo: "git+https://github.com/andersfugmann/amqp-client.git" 7 | doc: "https://andersfugmann.github.io/amqp-client/" 8 | license: "BSD-3-Clause" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.14.0"} 15 | "dune" {>= "2.0"} 16 | "ezxmlm" {build} 17 | "async" {with-test} 18 | "lwt" {with-test} 19 | ] 20 | synopsis: "Amqp client base library" 21 | description: """ 22 | This library provides high level client bindings for amqp. The library 23 | is tested with rabbitmq, but should work with other amqp 24 | servers. The library is written in pure OCaml. 25 | 26 | This is the base library required by lwt/async versions. 27 | You should install either amqp-client-async or amqp-client-lwt 28 | for actual client functionality.""" 29 | -------------------------------------------------------------------------------- /async/src/amqp.ml: -------------------------------------------------------------------------------- 1 | open Amqp_client_lib 2 | 3 | module Channel = Channel 4 | module Connection = Connection 5 | module Exchange = Exchange 6 | module Message = Message 7 | module Queue = Queue 8 | module Rpc = Rpc 9 | module Types = Types 10 | -------------------------------------------------------------------------------- /async/src/channel.ml: -------------------------------------------------------------------------------- 1 | open Thread 2 | open Spec 3 | open Amqp_client_lib 4 | 5 | type no_confirm = [ `Ok ] 6 | type with_confirm = [ `Ok | `Failed ] 7 | 8 | 9 | type _ confirms = 10 | | No_confirm: no_confirm confirms 11 | | With_confirm: with_confirm confirms 12 | 13 | let no_confirm = No_confirm 14 | let with_confirm = With_confirm 15 | 16 | type on_cancel = unit -> unit 17 | type consumer = Basic.Deliver.t * Basic.Content.t * string -> unit 18 | type consumers = (string, consumer * on_cancel) Hashtbl.t 19 | 20 | type result = Delivered | Rejected | Undeliverable 21 | type message_info = { delivery_tag: int; 22 | routing_key: string; 23 | exchange_name: string; 24 | result_handler: result -> unit; 25 | } 26 | 27 | type publish_confirm = { mutable message_count: int; 28 | unacked: message_info Mlist.t } 29 | 30 | type _ pcp = 31 | | Pcp_no_confirm: no_confirm pcp 32 | | Pcp_with_confirm: publish_confirm -> with_confirm pcp 33 | 34 | type return_handler = (Basic.Return.t * (Basic.Content.t * string)) option -> unit 35 | 36 | type 'a t = { framing: Framing.t; 37 | channel_no: int; 38 | consumers: consumers; 39 | id: string; 40 | mutable counter: int; 41 | publish_confirm: 'a pcp; 42 | mutable return_handlers: return_handler list; 43 | mutable closed: unit Ivar.t option; 44 | } 45 | 46 | let channel { framing; channel_no; _ } = (framing, channel_no) 47 | 48 | module Internal = struct 49 | let next_counter t = 50 | t.counter <- t.counter + 1; 51 | t.counter 52 | 53 | let unique_id t = 54 | Printf.sprintf "%s.%d" t.id (next_counter t) 55 | 56 | let register_deliver_handler t = 57 | let open Basic in 58 | let handler (deliver, (content, data)) = 59 | match Hashtbl.find t.consumers deliver.Deliver.consumer_tag with 60 | | handler, _ -> 61 | handler (deliver, content, data); 62 | (* Keep the current handler *) 63 | | exception Not_found -> 64 | failwith ("No consumers for: " ^ deliver.Deliver.consumer_tag) 65 | in 66 | let read = snd Deliver.Internal.read in 67 | read ~once:false handler (channel t) 68 | 69 | let register_consumer_handler t consumer_tag handler on_cancel = 70 | if Hashtbl.mem t.consumers consumer_tag then raise Types.Busy; 71 | Hashtbl.add t.consumers consumer_tag (handler, on_cancel) 72 | 73 | let deregister_consumer_handler t consumer_tag = 74 | Hashtbl.remove t.consumers consumer_tag 75 | 76 | let set_result ivar = function 77 | | Delivered -> 78 | Ivar.fill ivar `Ok 79 | | Rejected -> 80 | Ivar.fill ivar `Failed 81 | | Undeliverable -> 82 | Ivar.fill ivar `Failed 83 | 84 | (* Need to add if we should expect returns also. *) 85 | let wait_for_confirm: type a. a t -> routing_key:string -> exchange_name:string -> a Deferred.t = fun t ~routing_key ~exchange_name -> 86 | match t.publish_confirm with 87 | | Pcp_with_confirm t -> 88 | let var = Ivar.create () in 89 | let result_handler = set_result var in 90 | t.message_count <- t.message_count + 1; 91 | let delivery_tag = t.message_count in 92 | Mlist.append t.unacked {delivery_tag; routing_key; exchange_name; result_handler}; 93 | (Ivar.read var : [`Ok | `Failed] Deferred.t) 94 | | Pcp_no_confirm -> return `Ok 95 | end 96 | 97 | let close_handler t channel_no close = 98 | Log.info "Channel closed: %d" channel_no; 99 | Log.info "Reply code: %d\n" close.Channel.Close.reply_code; 100 | Log.info "Reply text: %s\n" close.Channel.Close.reply_text; 101 | Log.info "Message: (%d, %d)\n" close.Channel.Close.class_id close.Channel.Close.method_id; 102 | match t.closed with 103 | | None -> raise (Types.Channel_closed channel_no) 104 | | Some ivar -> 105 | Ivar.fill ivar (); 106 | return () 107 | 108 | let consumer_cancel_handler t (cancel : Basic.Cancel.t) = 109 | let consumer_tag = cancel.Basic.Cancel.consumer_tag in 110 | match Hashtbl.find t.consumers consumer_tag with 111 | | _, on_cancel -> 112 | Hashtbl.remove t.consumers consumer_tag; 113 | on_cancel () 114 | | exception Not_found -> 115 | failwith 116 | ("Cannot cancel consumer, as no handler was found for consumer: " ^ consumer_tag) 117 | 118 | let register_flow_handler t = 119 | let (_, read) = Channel.Flow.Internal.read in 120 | let handler { Channel.Flow.active } = 121 | Framing.set_flow t.framing t.channel_no active; 122 | spawn (Channel.Flow_ok.Internal.write (channel t) { Channel.Flow_ok.active }) 123 | in 124 | read ~once:false handler (channel t) 125 | 126 | let handle_confirms channel t = 127 | let confirm multiple result tag = 128 | let results = match multiple with 129 | | true -> Mlist.take_while ~pred:(fun m -> m.delivery_tag <= tag) t.unacked 130 | | false -> Mlist.take ~pred:(fun m -> m.delivery_tag = tag) t.unacked 131 | |> Option.map_default ~f:(fun v -> [v]) ~default:[] 132 | in 133 | List.iter (fun m -> m.result_handler result) results 134 | in 135 | 136 | let return_handler = function 137 | | Some (r, _) -> begin 138 | let pred message = 139 | message.routing_key = r.Basic.Return.routing_key && message.exchange_name = r.Basic.Return.exchange 140 | in 141 | 142 | match Mlist.take ~pred t.unacked with 143 | | None -> Log.error "No messages found to mark as undeliverable. This would indicate a library error" 144 | | Some m -> m.result_handler Undeliverable 145 | end 146 | | None -> () 147 | in 148 | 149 | let open Basic in 150 | let read_ack = snd Ack.Internal.read in 151 | let read_reject = snd Reject.Internal.read in 152 | read_ack ~once:false (fun m -> confirm m.Ack.multiple Delivered m.Ack.delivery_tag) channel; 153 | read_reject ~once:false (fun m -> confirm false Rejected m.Reject.delivery_tag) channel; 154 | 155 | Confirm.Select.request channel { Confirm.Select.nowait = false } >>= fun () -> 156 | return return_handler 157 | 158 | let register_return_handler t = 159 | let (_, read) = Basic.Return.Internal.read in 160 | let handler m = List.iter (fun h -> h (Some m)) t.return_handlers in 161 | read ~once:false handler (channel t) 162 | 163 | 164 | let create: type a. id:string -> a confirms -> Framing.t -> Framing.channel_no -> a t Deferred.t = fun ~id confirm_type framing channel_no -> 165 | let consumers = Hashtbl.create 0 in 166 | let id = Printf.sprintf "%s.%s.%d" (Framing.id framing) id channel_no in 167 | Framing.open_channel framing channel_no >>= fun () -> 168 | let publish_confirm : a pcp = match confirm_type with 169 | | With_confirm -> 170 | Pcp_with_confirm { message_count = 0; unacked = Mlist.create () } 171 | | No_confirm -> 172 | Pcp_no_confirm 173 | in 174 | let t = 175 | { framing; channel_no; consumers; id; counter = 0; 176 | publish_confirm; return_handlers = []; closed = None; } 177 | in 178 | 179 | spawn (Channel.Close.reply (framing, channel_no) (close_handler t channel_no)); 180 | let (_, read) = Basic.Cancel.Internal.read in 181 | read ~once:false (consumer_cancel_handler t) (framing, channel_no); 182 | 183 | Channel.Open.request (framing, channel_no) () >>= fun () -> 184 | 185 | begin match publish_confirm with 186 | | Pcp_with_confirm t -> 187 | handle_confirms (framing, channel_no) t >>= fun return_handler -> 188 | return [return_handler] 189 | | Pcp_no_confirm -> 190 | return [] 191 | end >>= fun return_handlers -> 192 | t.return_handlers <- return_handlers; 193 | Internal.register_deliver_handler t; 194 | 195 | register_flow_handler t; 196 | register_return_handler t; 197 | return t 198 | 199 | let close { framing; channel_no; return_handlers; _ } = 200 | let open Channel.Close in 201 | request (framing, channel_no) 202 | { reply_code=200; 203 | reply_text="Closed on user request"; 204 | class_id=0; 205 | method_id=0; } >>= fun () -> 206 | Framing.close_channel framing channel_no >>= fun () -> 207 | List.iter (fun h -> h None) return_handlers; 208 | return () 209 | 210 | let on_return t = 211 | let reader, writer = Pipe.create () in 212 | let handler = function 213 | | Some m -> Pipe.write_without_pushback writer m 214 | | None -> Pipe.close_without_pushback writer 215 | in 216 | t.return_handlers <- handler :: t.return_handlers; 217 | reader 218 | 219 | let on_closed t = 220 | let ivar = 221 | match t.closed with 222 | | Some ivar -> 223 | ivar 224 | | None -> 225 | let ivar = Ivar.create () in 226 | t.closed <- Some ivar; 227 | ivar 228 | in 229 | Ivar.read ivar 230 | 231 | let flush t = 232 | Framing.flush_channel t.framing t.channel_no 233 | 234 | let id t = t.id 235 | 236 | let channel_no t = t.channel_no 237 | 238 | let set_prefetch ?(count=0) ?(size=0) t = 239 | Basic.Qos.request (channel t) { Basic.Qos.prefetch_count=count; 240 | prefetch_size=size; 241 | global=false } 242 | 243 | let set_global_prefetch ?(count=0) ?(size=0) t = 244 | Basic.Qos.request (channel t) { Basic.Qos.prefetch_count=count; 245 | prefetch_size=size; 246 | global=true } 247 | 248 | module Transaction = struct 249 | type tx = EChannel: _ t -> tx 250 | 251 | open Spec.Tx 252 | let start t = 253 | Select.request (channel t) () >>= fun () -> 254 | return (EChannel t) 255 | 256 | let commit (EChannel t) = 257 | Commit.request (channel t) () 258 | 259 | let rollback (EChannel t) = 260 | Rollback.request (channel t) () 261 | end 262 | -------------------------------------------------------------------------------- /async/src/channel.mli: -------------------------------------------------------------------------------- 1 | (** Operations on channels *) 2 | open Thread 3 | open Spec 4 | 5 | (**/**) 6 | type on_cancel = unit -> unit 7 | type consumer = Basic.Deliver.t * Basic.Content.t * string -> unit 8 | type consumers = (string, consumer * on_cancel) Hashtbl.t 9 | (**/**) 10 | 11 | type _ t 12 | 13 | (**/**) 14 | val channel : _ t -> Framing.t * int 15 | 16 | module Internal : sig 17 | val register_consumer_handler : _ t -> string -> consumer -> on_cancel -> unit 18 | val deregister_consumer_handler : _ t -> string -> unit 19 | val wait_for_confirm : 'a t -> routing_key:string -> exchange_name:string -> 'a Deferred.t 20 | val unique_id : _ t -> string 21 | end 22 | (**/**) 23 | 24 | type 'a confirms 25 | 26 | type no_confirm = [ `Ok ] 27 | type with_confirm = [ `Ok | `Failed ] 28 | 29 | val no_confirm: no_confirm confirms 30 | val with_confirm: with_confirm confirms 31 | 32 | (** Create a new channel. 33 | Use Connection.open_channel rather than this method directly *) 34 | val create : id:string -> 'a confirms -> 35 | Framing.t -> Framing.channel_no -> 'a t Deferred.t 36 | 37 | (** Close the channel *) 38 | val close : _ t -> unit Deferred.t 39 | 40 | (** [on_closed] becomes determined after then channel is closed. 41 | 42 | If there are no consumers of this when the channel is close 43 | [Connection_closed] will be raised to the governing exception 44 | handler (the parent monitor in async, or [Lwt.async_exception_hook] 45 | in lwt). 46 | *) 47 | val on_closed : _ t -> unit Deferred.t 48 | 49 | (** Receive all returned messages. Reutnred message will be send to 50 | all readers returned from call to this function. Listening for 51 | returned messages are useful in e.g. rpc to know that message 52 | delivery failed and then stop waiting for a response. 53 | 54 | Note that channels in ack mode there is no need to listen for 55 | returned messages, as message delivery will fail synchoniously. 56 | *) 57 | val on_return : _ t -> 58 | (Basic.Return.t * (Basic.Content.t * string)) Pipe.Reader.t 59 | 60 | (** Get the id of the channel *) 61 | val id : _ t -> string 62 | 63 | (** Get the channel_no of the connection *) 64 | val channel_no : _ t -> int 65 | 66 | val set_prefetch : ?count:int -> ?size:int -> _ t -> unit Deferred.t 67 | (** Set prefetch counters for a channel. 68 | @param count Maximum messages inflight (un-acked) 69 | @param size Maximum amount of bytes inflight 70 | 71 | Note. if using rabbitmq, the prefetch limits are set per consumer on the channel, 72 | rather than per channel (across consumers) 73 | *) 74 | 75 | val set_global_prefetch : ?count:int -> ?size:int -> _ t -> unit Deferred.t 76 | (** Set global prefetch counters. 77 | @param count Maximum messages inflight (un-acked) 78 | @param size Maximum amount of bytes inflight 79 | 80 | Note: if using rabbitmq, the prefetch limits are set per channel (across consumers), 81 | If not, the global prefetch settings is applied globally - across consumers and channels. 82 | *) 83 | 84 | (** Flush the channel, making sure all messages have been sent *) 85 | val flush : _ t -> unit Deferred.t 86 | 87 | (** Transactions. 88 | Transactions can be made per channel. 89 | 90 | After a transaction is started, all published messages and all changes 91 | (queue/exchange bindings, creations or deletions) and message 92 | acknowledgements are not visible outside the transaction. 93 | 94 | The changes becomes visible after a [commit] or canceled by call to [rollback]. 95 | *) 96 | module Transaction : sig 97 | type tx 98 | 99 | (** Start a transacction *) 100 | val start : _ t -> tx Deferred.t 101 | 102 | (** Commit an transaction *) 103 | val commit : tx -> unit Deferred.t 104 | 105 | (** Rollback a transaction, discarding all changes and messages *) 106 | val rollback : tx -> unit Deferred.t 107 | end 108 | -------------------------------------------------------------------------------- /async/src/connection.ml: -------------------------------------------------------------------------------- 1 | open Thread 2 | open Amqp_client_lib 3 | open Spec.Connection 4 | 5 | let version = "2.3.0" 6 | 7 | let string_until c str = 8 | try 9 | let index = String.index str c in 10 | String.sub str 0 index 11 | with 12 | | Not_found -> str 13 | 14 | type t = { framing: Framing.t; 15 | virtual_host: string; 16 | mutable channel: int; 17 | mutable closing: bool; 18 | mutable closed: unit Ivar.t option; 19 | } 20 | 21 | let reply_start framing (username, password) = 22 | let print_item table s = 23 | let open Types in 24 | match List.assoc s table with 25 | | VLongstr v -> Log.info "%s: %s" s v 26 | | _ -> () 27 | | exception _ -> () 28 | in 29 | 30 | let reply { Start.version_major; 31 | version_minor; 32 | server_properties; 33 | mechanisms = _; 34 | locales } = 35 | 36 | let open Types in 37 | ["product"; "version" ] |> List.iter (print_item server_properties); 38 | Log.info "Amqp: %d.%d" version_major version_minor; 39 | 40 | return { 41 | Start_ok.mechanism = "PLAIN"; 42 | response = "\x00" ^ username ^ "\x00" ^ password; 43 | locale = string_until ';' locales; 44 | Start_ok.client_properties = [ 45 | "platform", VLongstr (Sys.os_type); 46 | "library", VLongstr "amqp-client (ocaml)"; 47 | "version", VLongstr version; 48 | "client id", VLongstr (Framing.id framing); 49 | "capabilities", VTable [ 50 | "publisher_confirms", VBoolean true; 51 | "exchange_exchange_bindings", VBoolean true; 52 | "basic.nack", VBoolean true; 53 | "consumer_cancel_notify", VBoolean true; 54 | "connection.blocked", VBoolean true; 55 | "consumer_priorities", VBoolean true; 56 | "authentication_failure_close", VBoolean true; 57 | "per_consumer_qos", VBoolean true; 58 | ] 59 | ]; 60 | } 61 | in 62 | Start.reply (framing, 0) reply 63 | 64 | 65 | let reply_tune framing = 66 | let var = Ivar.create () in 67 | let reply { Tune.channel_max; 68 | frame_max; heartbeat; } = 69 | Log.debug "Channel max: %d" channel_max; 70 | Log.debug "Frame_max: %d" frame_max; 71 | Log.debug "Heartbeat: %d" heartbeat; 72 | Ivar.fill var (if heartbeat = 0 then `Disabled else `Heartbeat heartbeat); 73 | Framing.set_max_length framing frame_max; 74 | return { 75 | Tune_ok.channel_max; 76 | frame_max; 77 | heartbeat; 78 | } 79 | in 80 | Tune.reply (framing, 0) reply >>= fun () -> 81 | Ivar.read var >>= fun v -> 82 | return v 83 | 84 | let reply_close _t framing = 85 | let reply { Close.reply_code; 86 | reply_text; 87 | class_id = _; 88 | method_id = _; 89 | } = 90 | Log.info "Closed code: %d" reply_code; 91 | Log.info "Closed text: %s" reply_text; 92 | (* Ivar.fill t.closed (); *) 93 | return () 94 | in 95 | Close.reply (framing, 0) reply 96 | 97 | let rec send_heartbeat delay t = 98 | after (float delay *. 1000.0) >>= fun () -> 99 | if t.closing then 100 | return () 101 | else begin 102 | Framing.send_heartbeat t.framing >>= fun () -> 103 | send_heartbeat delay t 104 | end 105 | 106 | let register_blocked_handler framing = 107 | let (_, read_blocked) = Blocked.Internal.read in 108 | let (_, read_unblocked) = Unblocked.Internal.read in 109 | let blocked_handler { Blocked.reason } = 110 | Log.info "Connection blocked: %s" reason; 111 | Framing.set_flow_all framing true 112 | in 113 | let unblocked_handler () = 114 | Framing.set_flow_all framing false 115 | in 116 | read_blocked ~once:false blocked_handler (framing, 0); 117 | read_unblocked ~once:false unblocked_handler (framing, 0) 118 | 119 | let open_connection { framing; virtual_host; _ } = 120 | Open.request (framing, 0) { Open.virtual_host } >>= fun x -> 121 | return x 122 | 123 | let connection_closed t _s = 124 | match t with 125 | | { closed = Some ivar; _ } when Ivar.is_full ivar -> 126 | return () 127 | | { closed = Some ivar; _ } -> 128 | Ivar.fill ivar (); 129 | Framing.close t.framing 130 | | { closing = false; _ } -> 131 | raise Types.Connection_closed 132 | | { closing = true; _ } -> 133 | return () 134 | 135 | let on_closed t = 136 | let ivar = match t.closed with 137 | | None -> 138 | let ivar = Ivar.create () in 139 | t.closed <- Some ivar; 140 | ivar 141 | | Some ivar -> 142 | ivar 143 | in 144 | Ivar.read ivar 145 | 146 | let connect ~id ?(virtual_host="/") ?(port=5672) ?(credentials=("guest", "guest")) ?heartbeat host = 147 | 148 | let tcp_error_handler = ref (fun exn -> raise exn) in 149 | 150 | Tcp.connect ~exn_handler:(fun exn -> !tcp_error_handler exn) ~nodelay:() host port >>= fun (input, output) -> 151 | 152 | let framing = Framing.init ~id input output in 153 | let t = 154 | { framing; virtual_host; channel = 0; closing = false; 155 | closed = None } 156 | in 157 | let exn_handler exn = connection_closed t (Printexc.to_string exn) in 158 | tcp_error_handler := exn_handler; 159 | Framing.start framing (connection_closed t) >>= fun () -> 160 | spawn ~exn_handler (reply_close t framing); 161 | reply_start framing credentials >>= fun () -> 162 | reply_tune framing >>= fun server_heartbeat -> 163 | begin 164 | match heartbeat, server_heartbeat with 165 | | None, `Disabled -> () 166 | | Some hb, `Disabled 167 | | None, `Heartbeat hb -> 168 | spawn ~exn_handler (send_heartbeat hb t); 169 | | Some hb, `Heartbeat hb' -> 170 | spawn ~exn_handler (send_heartbeat (min hb hb') t); 171 | end; 172 | open_connection t >>= fun () -> 173 | register_blocked_handler framing; 174 | return t 175 | 176 | let connect_uri ~id uri = 177 | let u = Uri.of_string uri in 178 | let () = match Uri.scheme u with 179 | | None -> raise (Invalid_argument "scheme required") 180 | | Some "amqp" -> () 181 | | Some scheme -> raise (Invalid_argument ("Unsupported scheme: " ^ scheme)) 182 | in 183 | let credentials = match Uri.user u, Uri.password u with 184 | | Some user, Some password -> Some (user, password) 185 | | None, None -> None 186 | | _ -> failwith "Both user and password must be supplied" 187 | in 188 | 189 | let virtual_host = match Uri.path u with 190 | | "" -> None 191 | | vhost -> Some vhost 192 | in 193 | let heartbeat = 194 | match List.assoc "heartbeat_interval" (Uri.query u) with 195 | | [interval] -> 196 | Some (int_of_string interval) 197 | | _ -> 198 | raise (Invalid_argument "heartbeat_interval specified multiple times") 199 | | exception Not_found -> None 200 | in 201 | 202 | let host = match Uri.host u with 203 | | None -> raise (Invalid_argument "Uri must contain a host part") 204 | | Some h -> h 205 | in 206 | connect ~id ?virtual_host ?port:(Uri.port u) ?credentials ?heartbeat host 207 | 208 | let open_channel ~id confirms t = 209 | t.channel <- t.channel + 1; 210 | Channel.create ~id confirms t.framing t.channel 211 | 212 | let close t = 213 | t.closing <- true; 214 | Framing.flush t.framing >>= fun () -> 215 | Close.request (t.framing, 0) { Close.reply_code = 200; 216 | reply_text = "Closed on user request"; 217 | class_id = 0; 218 | method_id = 0; 219 | } >>= fun () -> 220 | Framing.close t.framing 221 | -------------------------------------------------------------------------------- /async/src/connection.mli: -------------------------------------------------------------------------------- 1 | open Thread 2 | 3 | (** Connection *) 4 | type t 5 | 6 | (** Connect to an Amqp server. 7 | 8 | [connect ~id:"test" localhost] connects to localhost using default guest credentials, with identity "test" 9 | 10 | @param id an identifier of the connection used for tracing and debugging 11 | @param credentials a tuple of username * password. The credentials are transmitted in plain text 12 | @param virtual_host Named of the virtual host. 13 | Virtual must be defined on the amqp-server prior to connecting them. 14 | Default "/" 15 | @param port The port to connect to 16 | @param heartbeat Delay between heartbeats in seconds. Lower the number to detect connection loss faster. 17 | 18 | 19 | If an error occurs an exception is raised. To capture and handle 20 | exceptions it is advised to detach a monitor [Core.Async.Monitor] 21 | and handle raised exceptions. 22 | 23 | The most important exception is [Connection_closed]. As the 24 | connection is stateful (channels are tied to connections e.g), 25 | the connection cannot be re-established without redoing all 26 | initalization. 27 | *) 28 | val connect : 29 | id:string -> 30 | ?virtual_host:string -> 31 | ?port:int -> 32 | ?credentials:string * string -> 33 | ?heartbeat:int -> 34 | string -> t Deferred.t 35 | 36 | (** Connect to amqp using an uri. 37 | 38 | [connect_uri ~id:"test" "amqp://localhost/"] connects to amqp server on localhost using default port and default username/password. 39 | 40 | The uri must be on the form: [ampq://user:password@hostname:port/vhost?params]. 41 | Currently only 'heartbeat_interval=' parameter is used. 42 | *) 43 | val connect_uri : 44 | id:string -> 45 | string -> t Deferred.t 46 | 47 | (** Open a new channel. 48 | @param id identifies the channel for tracing and debugging 49 | *) 50 | val open_channel : id:string -> 'a Channel.confirms -> t -> 'a Channel.t Deferred.t 51 | val close : t -> unit Deferred.t 52 | 53 | (** [on_closed] becomes ready when the connection has been closed. *) 54 | val on_closed : t -> unit Deferred.t 55 | -------------------------------------------------------------------------------- /async/src/dune: -------------------------------------------------------------------------------- 1 | ; Copy autogenerated files 2 | (rule (copy ../../spec/spec.ml spec.ml)) 3 | (rule (copy ../../spec/constants.ml constants.ml)) 4 | 5 | (library 6 | (name amqp_client_async) 7 | (public_name amqp-client-async) 8 | (synopsis "Amqp client using async for concurrency") 9 | (libraries amqp-client.lib async uri) 10 | ) 11 | -------------------------------------------------------------------------------- /async/src/exchange.ml: -------------------------------------------------------------------------------- 1 | open Thread 2 | open Amqp_client_lib 3 | open Spec.Exchange 4 | 5 | (* type match_type = Any | All *) 6 | 7 | type _ exchange_type = 8 | | Direct: [`Queue of string] exchange_type 9 | | Fanout: unit exchange_type 10 | | Topic: [`Topic of string] exchange_type 11 | | Match: [`Headers of Types.header list] exchange_type 12 | 13 | let direct_t = Direct 14 | let fanout_t = Fanout 15 | let topic_t = Topic 16 | let match_t = Match 17 | 18 | type 'a t = { name : string; 19 | exchange_type: 'a exchange_type } 20 | 21 | (** Predefined Default exchange *) 22 | let default = { name=""; exchange_type = Direct } 23 | 24 | (** Predefined Direct exchange *) 25 | let amq_direct = { name = "amq.direct"; exchange_type = Direct } 26 | 27 | (** Predefined Fanout exchange *) 28 | let amq_fanout = { name = "amq.fanout"; exchange_type = Fanout } 29 | 30 | (** Predefined topic exchange *) 31 | let amq_topic = { name = "amq.topic"; exchange_type = Topic } 32 | 33 | (** Predefined match (header) exchange *) 34 | let amq_match = { name = "amq.match"; exchange_type = Match } 35 | 36 | let string_of_exchange_type: type a. a exchange_type -> string = function 37 | | Direct -> "direct" 38 | | Fanout -> "fanout" 39 | | Topic -> "topic" 40 | | Match -> "match" 41 | 42 | module Internal = struct 43 | let bind_queue: type a. _ Channel.t -> a t -> string -> a -> unit Deferred.t = 44 | let open Spec.Queue in 45 | fun channel { name; exchange_type} queue -> 46 | let bind ?(routing_key="") ?(arguments=[]) () = 47 | let query = { Bind.queue; 48 | exchange = name; 49 | routing_key; 50 | no_wait = false; 51 | arguments; 52 | } 53 | in 54 | Bind.request (Channel.channel channel) query 55 | in 56 | match exchange_type with 57 | | Direct -> fun (`Queue routing_key) -> bind ~routing_key () 58 | | Fanout -> fun () -> bind () 59 | | Topic -> fun (`Topic routing_key) -> bind ~routing_key () 60 | | Match -> fun (`Headers arguments) -> bind ~arguments () 61 | 62 | let unbind_queue: type a. _ Channel.t -> a t -> string -> a -> unit Deferred.t = 63 | let open Spec.Queue in 64 | fun channel { name; exchange_type} queue -> 65 | let unbind ?(routing_key="") ?(arguments=[]) () = 66 | let query = { Unbind.queue; 67 | exchange = name; 68 | routing_key; 69 | arguments; 70 | } 71 | in 72 | Unbind.request (Channel.channel channel) query 73 | in 74 | match exchange_type with 75 | | Direct -> fun (`Queue routing_key) -> unbind ~routing_key () 76 | | Fanout -> fun () -> unbind () 77 | | Topic -> fun (`Topic routing_key) -> unbind ~routing_key () 78 | | Match -> fun (`Headers arguments) -> unbind ~arguments () 79 | end 80 | 81 | 82 | let declare: type a. ?passive:bool -> ?durable:bool -> ?auto_delete:bool -> ?internal:bool -> 83 | _ Channel.t -> a exchange_type -> ?arguments:Types.table -> string -> a t Deferred.t = 84 | fun ?(passive=false) ?(durable=false) ?(auto_delete=false) ?(internal=false) 85 | channel exchange_type ?(arguments=[]) name -> 86 | Declare.request (Channel.channel channel) 87 | { Declare.exchange = name; 88 | amqp_type = (string_of_exchange_type exchange_type); 89 | passive; 90 | durable; 91 | auto_delete; 92 | internal; 93 | no_wait = false; 94 | arguments; } >>= fun () -> 95 | return { name; exchange_type } 96 | 97 | let delete ?(if_unused=false) channel t = 98 | Delete.request (Channel.channel channel) 99 | { Delete.exchange = t.name; 100 | if_unused; 101 | no_wait = false; 102 | } 103 | 104 | let bind: type a. _ Channel.t -> destination:_ t -> source:a t -> a -> unit Deferred.t= 105 | fun channel ~destination ~source -> 106 | let bind ?(routing_key="") ?(arguments=[]) () = 107 | let query = { Bind.destination = destination.name; 108 | source = source.name; 109 | routing_key; 110 | no_wait = false; 111 | arguments; 112 | } 113 | in 114 | Bind.request (Channel.channel channel) query 115 | in 116 | match source.exchange_type with 117 | | Direct -> fun (`Queue routing_key) -> bind ~routing_key () 118 | | Fanout -> fun () -> bind () 119 | | Topic -> fun (`Topic routing_key) -> bind ~routing_key () 120 | | Match -> fun (`Headers arguments) -> bind ~arguments () 121 | 122 | let unbind: type a. _ Channel.t -> destination:_ t -> source:a t -> a -> unit Deferred.t= 123 | fun channel ~destination ~source -> 124 | let unbind ?(routing_key="") ?(arguments=[]) () = 125 | let query = { Unbind.destination = destination.name; 126 | source = source.name; 127 | routing_key; 128 | no_wait = false; 129 | arguments; 130 | } 131 | in 132 | Unbind.request (Channel.channel channel) query 133 | in 134 | match source.exchange_type with 135 | | Direct -> fun (`Queue routing_key) -> unbind ~routing_key () 136 | | Fanout -> fun () -> unbind () 137 | | Topic -> fun (`Topic routing_key) -> unbind ~routing_key () 138 | | Match -> fun (`Headers arguments) -> unbind ~arguments () 139 | 140 | let publish channel t 141 | ?(mandatory=false) 142 | ~routing_key 143 | (header, body) = 144 | 145 | let open Spec.Basic in 146 | let header = match header.Content.app_id with 147 | | Some _ -> header 148 | | None -> { header with Content.app_id = Some (Channel.id channel) } 149 | in 150 | let wait_for_confirm = Channel.Internal.wait_for_confirm channel in 151 | Publish.request (Channel.channel channel) 152 | ({Publish.exchange = t.name; 153 | routing_key; 154 | mandatory; 155 | immediate=false}, 156 | header, body) >>= fun () -> 157 | wait_for_confirm ~routing_key ~exchange_name:t.name 158 | 159 | let name t = t.name 160 | -------------------------------------------------------------------------------- /async/src/exchange.mli: -------------------------------------------------------------------------------- 1 | (** Operations on exchanges *) 2 | open Thread 3 | open Amqp_client_lib 4 | 5 | type _ t 6 | 7 | type _ exchange_type 8 | 9 | val direct_t : [`Queue of string] exchange_type 10 | val fanout_t : unit exchange_type 11 | val topic_t : [`Topic of string] exchange_type 12 | val match_t : [`Headers of Types.header list] exchange_type 13 | 14 | val default : [`Queue of string] t 15 | val amq_direct : [`Queue of string] t 16 | val amq_fanout : unit t 17 | val amq_topic : [`Topic of string] t 18 | val amq_match : [`Headers of Types.header list] t 19 | 20 | (**/**) 21 | module Internal : sig 22 | val bind_queue : _ Channel.t -> 'a t -> string -> 'a -> unit Deferred.t 23 | val unbind_queue : _ Channel.t -> 'a t -> string -> 'a -> unit Deferred.t 24 | end 25 | (**/**) 26 | 27 | (** Declare a exchange *) 28 | val declare : 29 | ?passive:bool -> 30 | ?durable:bool -> 31 | ?auto_delete:bool -> 32 | ?internal:bool -> 33 | _ Channel.t -> 34 | 'a exchange_type -> 35 | ?arguments:Types.table -> 36 | string -> 'a t Deferred.t 37 | 38 | (** Delete exchange *) 39 | val delete : 40 | ?if_unused:bool -> 41 | _ Channel.t -> _ t -> unit Deferred.t 42 | 43 | (** Bind exchange [t] to exchange using [routing_key], so messages are routed from exchange to [t] *) 44 | val bind : _ Channel.t -> destination:_ t -> source:'a t -> 'a -> unit Deferred.t 45 | 46 | (** Remove exchange to exchange binding *) 47 | val unbind : _ Channel.t -> destination:_ t -> source:'a t -> 'a -> unit Deferred.t 48 | 49 | (** Publish a message directly to an exchange. *) 50 | val publish : 51 | 'a Channel.t -> 52 | _ t -> 53 | ?mandatory:bool -> 54 | routing_key:string -> 55 | Message.message -> 'a Deferred.t 56 | 57 | (** Name of the exchange *) 58 | val name : _ t -> string 59 | -------------------------------------------------------------------------------- /async/src/framing.ml: -------------------------------------------------------------------------------- 1 | (** Internal *) 2 | open Thread 3 | open Amqp_client_lib 4 | module S = Protocol.Spec 5 | 6 | type channel_no = int 7 | 8 | type channel_state = 9 | | Ready 10 | | Waiting of Types.class_id * Io.Input.t * int * Bytes.t 11 | 12 | type message = 13 | | Method of Types.message_id * Io.Input.t 14 | | Content of Types.class_id * Io.Input.t * string 15 | 16 | type data = Io.Input.t 17 | 18 | type content_handler = data * string -> unit 19 | type method_handler = data -> unit 20 | 21 | type channel = { mutable state: channel_state; 22 | method_handlers: (Types.message_id * method_handler) Mlist.t; 23 | content_handlers: (Types.class_id * content_handler) Mlist.t; 24 | writer: String.t Pipe.Writer.t; 25 | mutable ready: unit Ivar.t; 26 | } 27 | 28 | type close_handler = string -> unit Deferred.t 29 | type t = { input: Reader.t; output: Writer.t; 30 | multiplex: String.t Pipe.Reader.t Pipe.Writer.t; 31 | multiplex_reader: String.t Pipe.Reader.t Pipe.Reader.t; 32 | mutable channels: channel option array; 33 | mutable max_length: int; 34 | id: string; 35 | mutable flow: bool; 36 | } 37 | 38 | let protocol_header = "AMQP\x00\x00\x09\x01" 39 | let read_method_frame = S.read S.(Short :: Short :: []) 40 | let read_content_header = S.read S.(Short :: Short :: Longlong :: []) 41 | 42 | 43 | let read_frame_header, write_frame_header = 44 | let open Protocol.Spec in 45 | let spec = Octet :: Short :: Long :: [] in 46 | read spec, write spec 47 | 48 | let channel t channel_no = 49 | match t.channels.(channel_no) with 50 | | None -> raise (Types.Channel_not_found channel_no) 51 | | Some ch -> ch 52 | 53 | let size_of_writer writer = 54 | Io.Output.sizer () 55 | |> writer 56 | |> Io.Output.size 57 | 58 | let create_frame channel_no tpe writer = 59 | let length = size_of_writer writer in 60 | let output = Io.Output.create (1+2+4+length+1) in 61 | 62 | write_frame_header output tpe channel_no length 63 | |> writer 64 | |> fun w -> Io.Output.octet w Constants.frame_end; 65 | Io.Output.get output 66 | |> Bytes.unsafe_to_string 67 | 68 | let write_method_id = 69 | let open Protocol.Spec in 70 | write (Short :: Short :: []) 71 | 72 | let create_method_frame channel_no (cid, mid) writer = 73 | let writer output = 74 | write_method_id output cid mid 75 | |> writer 76 | in 77 | create_frame channel_no Constants.frame_method writer 78 | 79 | let create_content_header = 80 | let open Protocol.Spec in 81 | write (Short :: Short :: Longlong :: []) 82 | 83 | let add_content_frames queue max_length channel_no class_id writer data = 84 | let length = String.length data in 85 | let writer output = 86 | create_content_header output class_id 0 length 87 | |> writer 88 | in 89 | let msg = create_frame channel_no Constants.frame_header writer in 90 | Ocaml_lib.Queue.add msg queue; 91 | 92 | (* Send the data *) 93 | let rec send offset = 94 | if offset < length then 95 | let size = min max_length (length - offset) in 96 | let msg = 97 | create_frame channel_no Constants.frame_body 98 | (fun output -> Io.Output.string output ~src_pos:offset ~len:size data; output) 99 | in 100 | Ocaml_lib.Queue.add msg queue; 101 | send (offset + max_length) 102 | else 103 | () 104 | in 105 | send 0 106 | 107 | let write_message (t, channel_no) (message_id, writer) content = 108 | let channel = channel t channel_no in 109 | match content with 110 | | Some (class_id, c_writer, data) -> 111 | Ivar.read channel.ready >>= fun () -> 112 | let frames = Ocaml_lib.Queue.create () in 113 | let msg = create_method_frame channel_no message_id writer in 114 | Ocaml_lib.Queue.add msg frames; 115 | add_content_frames frames t.max_length channel_no class_id c_writer data; 116 | Pipe.transfer_in channel.writer ~from:frames 117 | | None -> 118 | create_method_frame channel_no message_id writer 119 | |> Pipe.write channel.writer 120 | 121 | let send_heartbeat t = 122 | let channel = channel t 0 in 123 | create_frame 0 Constants.frame_heartbeat (fun i -> i) 124 | |> Pipe.write channel.writer 125 | 126 | (** read_frame reads a frame from the input, and sends the data to 127 | the channel writer *) 128 | let decode_message t tpe channel_no size input = 129 | let channel = channel t channel_no in 130 | match channel.state, tpe with 131 | | Ready, n when n = Constants.frame_method -> 132 | (* Standard method message *) 133 | let message_id = read_method_frame (fun a b -> a, b) input in 134 | let handler = 135 | Mlist.take ~pred:(fun elt -> fst elt = message_id) channel.method_handlers 136 | |> Option.get_exn ~exn:Types.No_handler_found 137 | |> snd 138 | in 139 | Mlist.prepend channel.method_handlers (message_id, handler); 140 | handler input; 141 | | Ready, n when n = Constants.frame_header -> 142 | let class_id, _weight, size = 143 | read_content_header (fun a b c -> a, b, c) input 144 | in 145 | 146 | if size = 0 then begin 147 | let handler = 148 | Mlist.take ~pred:(fun elt -> fst elt = class_id) channel.content_handlers 149 | |> Option.get_exn ~exn:Types.No_handler_found 150 | |> snd 151 | in 152 | Mlist.prepend channel.content_handlers (class_id, handler); 153 | handler (input, "") 154 | end 155 | else 156 | channel.state <- Waiting (class_id, input, 0, Bytes.create size) 157 | | Waiting (class_id, content, offset, buffer), n when n = Constants.frame_body -> 158 | Io.Input.copy input ~dst_pos:offset ~len:size buffer; 159 | if (Bytes.length buffer = offset + size) then begin 160 | channel.state <- Ready; 161 | let handler = 162 | Mlist.take ~pred:(fun elt -> fst elt = class_id) channel.content_handlers 163 | |> Option.get_exn ~exn:Types.No_handler_found 164 | |> snd 165 | in 166 | Mlist.prepend channel.content_handlers (class_id, handler); 167 | handler (content, Bytes.unsafe_to_string buffer); 168 | end 169 | else 170 | channel.state <- Waiting (class_id, content, offset + size, buffer) 171 | | _, n when n = Constants.frame_heartbeat -> () 172 | | _, n -> raise (Types.Unknown_frame_type n) 173 | 174 | let rec read_frame t close_handler = 175 | let header = Bytes.create (1+2+4) in 176 | Reader.read t.input header >>= function 177 | | `Eof n -> 178 | close_handler (Bytes.sub_string header 0 n) 179 | | `Ok -> 180 | let input = Io.Input.init (Bytes.unsafe_to_string header) in 181 | let tpe, channel_no, length = read_frame_header (fun a b c -> a, b, c) input in 182 | let buf = Bytes.create (length+1) in 183 | Reader.read t.input buf >>= function 184 | | `Eof n -> 185 | let s = Bytes.extend header 0 n in 186 | Bytes.blit buf 0 s (1+2+4) n; 187 | close_handler (Bytes.to_string s) 188 | | `Ok -> match Bytes.get buf length |> Char.code with 189 | | n when n = Constants.frame_end -> 190 | let input = Io.Input.init (Bytes.unsafe_to_string buf) in 191 | decode_message t tpe channel_no length input; 192 | read_frame t close_handler 193 | | n -> failwith (Printf.sprintf "Unexpected frame end: %x" n) 194 | 195 | let register_method_handler (t, channel_no) message_id handler = 196 | let c = channel t channel_no in 197 | Mlist.append c.method_handlers (message_id, handler) 198 | 199 | let register_content_handler (t, channel_no) class_id handler = 200 | let c = channel t channel_no in 201 | Mlist.prepend c.content_handlers (class_id, handler) 202 | 203 | let deregister_method_handler (t, channel_no) message_id = 204 | let c = channel t channel_no in 205 | let (_ : 'a option) = Mlist.take ~pred:(fun (id, _) -> id = message_id) c.method_handlers in 206 | () 207 | 208 | let deregister_content_handler (t, channel_no) class_id = 209 | let c = channel t channel_no in 210 | let (_ : 'a option) = Mlist.take ~pred:(fun (id, _) -> id = class_id) c.content_handlers in 211 | () 212 | 213 | let set_flow_on_channel c = function 214 | | true -> 215 | if Ivar.is_full c.ready then 216 | c.ready <- Ivar.create () 217 | | false -> 218 | Ivar.fill_if_empty c.ready () 219 | 220 | 221 | let set_flow t channel_no active = 222 | let c = channel t channel_no in 223 | set_flow_on_channel c active 224 | 225 | let set_flow_all t active = 226 | t.flow <- active; 227 | Array.iter (function Some c -> set_flow_on_channel c active | None -> ()) t.channels 228 | 229 | let open_channel t channel_no = 230 | (* Grow the array if needed *) 231 | let len = Array.length t.channels in 232 | if (len <= channel_no) then 233 | t.channels <- Array.append t.channels (Array.make len None); 234 | 235 | let reader, writer = Pipe.create () in 236 | Pipe.set_size_budget writer 4; 237 | let ready = match t.flow with 238 | | true -> Ivar.create () 239 | | false -> Ivar.create_full () 240 | in 241 | t.channels.(channel_no) <- 242 | Some { state = Ready; 243 | method_handlers = Mlist.create (); 244 | content_handlers = Mlist.create (); 245 | writer; 246 | ready; 247 | }; 248 | 249 | Pipe.write t.multiplex reader 250 | 251 | let flush t = 252 | Array.to_list t.channels 253 | |> List.map (function None -> return () | Some channel -> Pipe.flush channel.writer >>= fun _ -> return ()) 254 | |> Deferred.all_unit >>= fun () -> 255 | Writer.flush t.output 256 | 257 | let flush_channel t channel_no = 258 | let channel = channel t channel_no in 259 | Pipe.flush channel.writer >>= fun _ -> 260 | Writer.flush t.output 261 | 262 | let close t = 263 | let l = Array.to_list t.channels in 264 | Deferred.List.iter ~f:(function None -> return () | Some ch -> Pipe.close ch.writer) l >>= fun () -> 265 | Reader.close t.input >>= fun () -> 266 | Writer.close t.output >>= fun () -> 267 | return () 268 | 269 | let close_channel t channel_no = 270 | let channel = channel t channel_no in 271 | t.channels.(channel_no) <- None; 272 | Pipe.close channel.writer >>= fun _ -> 273 | flush t 274 | 275 | let rec start_writer output channels = 276 | Pipe.read channels >>= function 277 | | `Ok data -> 278 | Writer.write output data; 279 | start_writer output channels 280 | | `Eof -> return () 281 | 282 | let id {id; _} = id 283 | 284 | (** [writer] is channel 0 writer. It must be attached *) 285 | let init ~id input output = 286 | let id = Printf.sprintf "%s.%s.%s.%s" id (Unix.gethostname ()) (Unix.getpid () |> string_of_int) (Sys.executable_name |> Filename.basename) in 287 | let reader, writer = Pipe.create () in 288 | { input; 289 | output; 290 | max_length = 1024; 291 | channels = Array.make 256 None; 292 | multiplex = writer; 293 | multiplex_reader = reader; 294 | id; 295 | flow = false; 296 | } 297 | 298 | let start t close_handler = 299 | let exn_handler exn = close_handler (Printexc.to_string exn) in 300 | spawn ~exn_handler (start_writer t.output (Pipe.interleave_pipe t.multiplex_reader)); 301 | Writer.write t.output protocol_header; 302 | spawn ~exn_handler (read_frame t close_handler); 303 | open_channel t 0 304 | 305 | let set_max_length t max_length = 306 | t.max_length <- max_length; 307 | -------------------------------------------------------------------------------- /async/src/framing.mli: -------------------------------------------------------------------------------- 1 | (** Internal *) 2 | open Thread 3 | open Amqp_client_lib 4 | type channel_no = int 5 | 6 | 7 | type message = Method of Types.message_id * Io.Input.t 8 | | Content of Types.class_id * Io.Input.t * string 9 | 10 | type data = Io.Input.t 11 | type content_handler = data * string -> unit 12 | type method_handler = data -> unit 13 | 14 | type close_handler = string -> unit Deferred.t 15 | type t 16 | 17 | val write_message : t * channel_no -> 18 | Types.message_id * (Io.Output.t -> Io.Output.t) -> 19 | (Types.class_id * (Io.Output.t -> Io.Output.t) * string) option -> 20 | unit Deferred.t 21 | 22 | val send_heartbeat: t -> unit Deferred.t 23 | 24 | val register_method_handler : t * channel_no -> Types.message_id -> method_handler -> unit 25 | val register_content_handler : t * channel_no -> Types.class_id -> content_handler -> unit 26 | val deregister_method_handler : t * channel_no -> Types.message_id -> unit 27 | val deregister_content_handler : t * channel_no -> Types.class_id -> unit 28 | 29 | val set_flow : t -> channel_no -> bool -> unit 30 | val set_flow_all : t -> bool -> unit 31 | 32 | 33 | val open_channel : t -> channel_no -> unit Deferred.t 34 | val close_channel : t -> channel_no -> unit Deferred.t 35 | 36 | val flush_channel : t -> channel_no -> unit Deferred.t 37 | val flush : t -> unit Deferred.t 38 | 39 | val id : t -> string 40 | 41 | val init : id:string -> Reader.t -> Writer.t -> t 42 | val start: t -> close_handler -> unit Deferred.t 43 | val close : t -> unit Deferred.t 44 | 45 | val set_max_length : t -> int -> unit 46 | -------------------------------------------------------------------------------- /async/src/message.ml: -------------------------------------------------------------------------------- 1 | open Spec.Basic 2 | open Amqp_client_lib 3 | 4 | type message = (Content.t * string) 5 | 6 | let string_header key value = key, Types.VLongstr value 7 | let int_header key value = key, Types.VLonglong value 8 | 9 | type t = 10 | { delivery_tag : int; 11 | redelivered : bool; 12 | exchange : string; 13 | routing_key : string; 14 | message: message; (* Could be in or out of the record *) 15 | } 16 | 17 | let make 18 | ?(content_type:string option) 19 | ?(content_encoding: string option) 20 | ?(headers: Types.table option) 21 | ?(delivery_mode: int option) 22 | ?(priority: int option) 23 | ?(correlation_id: string option) 24 | ?(reply_to: string option) 25 | ?(expiration: int option) 26 | ?(message_id: string option) 27 | ?(timestamp: int option) 28 | ?(amqp_type: string option) 29 | ?(user_id: string option) 30 | ?(app_id: string option) 31 | body : message = 32 | let expiration = match expiration with 33 | | None -> None 34 | | Some n -> Some (string_of_int n) 35 | in 36 | 37 | ({ Content.content_type; 38 | content_encoding; 39 | headers; 40 | delivery_mode; 41 | priority; 42 | correlation_id; 43 | reply_to; 44 | expiration; 45 | message_id; 46 | timestamp; 47 | amqp_type; 48 | user_id; 49 | app_id; 50 | reserved = None; 51 | }, body) 52 | 53 | let ack channel t = 54 | let open Spec.Basic in 55 | Ack.request (Channel.channel channel) 56 | { Ack.delivery_tag = t.delivery_tag; multiple = false } 57 | 58 | let reject ~requeue channel t = 59 | let open Spec.Basic in 60 | Reject.request (Channel.channel channel) 61 | { Reject.delivery_tag = t.delivery_tag; requeue } 62 | 63 | 64 | let recover ~requeue channel = 65 | Spec.Basic.Recover.request (Channel.channel channel) { Spec.Basic.Recover.requeue } 66 | -------------------------------------------------------------------------------- /async/src/message.mli: -------------------------------------------------------------------------------- 1 | (** Amqp message type and functions *) 2 | 3 | open Thread 4 | open Amqp_client_lib 5 | type message = Spec.Basic.Content.t * string 6 | 7 | val string_header: string -> string -> Types.header 8 | val int_header: string -> int -> Types.header 9 | 10 | 11 | type t = { 12 | delivery_tag : int; 13 | redelivered : bool; 14 | exchange : string; 15 | routing_key : string; 16 | message : message; 17 | } 18 | 19 | val make : 20 | ?content_type:string -> 21 | ?content_encoding:string -> 22 | ?headers:Types.table -> 23 | ?delivery_mode:int -> 24 | ?priority:int -> 25 | ?correlation_id:string -> 26 | ?reply_to:string -> 27 | ?expiration:int -> 28 | ?message_id:string -> 29 | ?timestamp:int -> 30 | ?amqp_type:string -> 31 | ?user_id:string -> ?app_id:string -> string -> message 32 | 33 | (** Acknowledge a message. 34 | Messages {e must} be acknowledged on the same channel as they are received 35 | *) 36 | val ack: _ Channel.t -> t -> unit Deferred.t 37 | 38 | (** Reject (Nack) a message. 39 | Messages {e must} be rejected on the same channel as they are received 40 | @param requeue If true, the message will be requeued (default) 41 | *) 42 | val reject: requeue:bool -> _ Channel.t -> t -> unit Deferred.t 43 | 44 | (** Ask the server to resend or discard all outstanding messages on the channel 45 | This is essentially the same as calling nack on all outstanding messages. 46 | @param requeue if true messages are redelivered 47 | *) 48 | val recover: requeue:bool -> _ Channel.t -> unit Deferred.t 49 | -------------------------------------------------------------------------------- /async/src/protocol_helpers.ml: -------------------------------------------------------------------------------- 1 | (** Internal *) 2 | open Thread 3 | module Protocol = Amqp_client_lib.Protocol 4 | module Io = Amqp_client_lib.Io 5 | 6 | type 'a post_handler = ('a -> unit) option 7 | 8 | let bit_string v length = 9 | let rec loop acc v = function 10 | | 0 -> acc 11 | | n -> loop ((if v land 1 = 1 then "1" else "0") :: acc) (v lsr 1) (n-1) 12 | in 13 | String.concat "" (loop [] v length) 14 | 15 | let update_property_flag v word flags = 16 | word ((v lsl (16 - flags)) land 0xffff) 17 | 18 | let read_property_flag word flags = 19 | let word = (word land 0xffff) lsr (16 - flags) in 20 | 21 | (* Reverse the bits *) 22 | let rec rev v word = function 23 | | 0 -> v 24 | | n -> 25 | rev ((v lsl 1) lor (word land 0x1)) (word lsr 1) (n - 1) 26 | in 27 | rev 0 word flags 28 | 29 | let rec list_create f = function 30 | | 0 -> [] 31 | | n -> f () :: list_create f (n - 1) 32 | 33 | let write_method (message_id, spec, _make, apply) = 34 | let write = Protocol.Spec.write spec in 35 | let writer msg output = apply (write output) msg in 36 | fun channel msg -> 37 | Framing.write_message channel (message_id, (writer msg)) None 38 | 39 | let read_method (message_id, spec, make, _apply) = 40 | let read = Protocol.Spec.read spec in 41 | let read ~once (handler: 'a -> unit) channel : unit = 42 | let handler data = 43 | let req = read make data in 44 | handler req; 45 | if (once) then begin 46 | Framing.deregister_method_handler channel message_id 47 | end 48 | in 49 | Framing.register_method_handler channel message_id handler 50 | in 51 | (message_id, read) 52 | 53 | let write_method_content (message_id, spec, _make, apply) ((c_method, _), c_spec, _c_make, c_apply) = 54 | let write = Protocol.Spec.write spec in 55 | let c_write = Protocol.Content.write c_spec in 56 | let property_bits = Protocol.Content.length c_spec in 57 | assert (property_bits <= 15); 58 | let write_method msg output = 59 | apply (write output) msg 60 | in 61 | let write_content content output = 62 | let property_flags = ref 0 in 63 | let property_word = Io.Output.short_ref output in 64 | let output = c_apply (c_write property_flags output) content in 65 | update_property_flag !property_flags property_word property_bits; 66 | output 67 | in 68 | 69 | fun channel (meth, content, data) -> 70 | Framing.write_message channel (message_id, (write_method meth)) 71 | (Some (c_method, (write_content content), data)) 72 | 73 | let read_method_content (message_id, spec, make, _apply) ((c_method, _), c_spec, c_make, _c_apply) = 74 | let read = Protocol.Spec.read spec in 75 | let c_read = Protocol.Content.read c_spec in 76 | let flags = Protocol.Content.length c_spec in 77 | 78 | let read ~once (handler: 'a -> unit) channel : unit = 79 | let c_handler req (content, data) = 80 | let property_flags = read_property_flag (Io.Input.short content) flags in 81 | let header = c_read c_make property_flags content in 82 | let message = (req, (header, data)) in 83 | handler message; 84 | Framing.deregister_content_handler channel c_method 85 | in 86 | let handler data = 87 | let req = read make data in 88 | if (once) then begin 89 | Framing.deregister_method_handler channel message_id 90 | end; 91 | Framing.register_content_handler channel c_method (c_handler req) 92 | in 93 | Framing.register_method_handler channel message_id handler 94 | in 95 | (message_id, read) 96 | 97 | 98 | let request0 req = 99 | fun channel msg -> 100 | req channel msg 101 | 102 | let reply0 (_, read) ?(once=true) channel = 103 | let var = Ivar.create () in 104 | read ~once (Ivar.fill var) channel; 105 | Ivar.read var 106 | 107 | let request1 write (_, read) channel msg = 108 | let var = Ivar.create () in 109 | read ~once:true (Ivar.fill var) channel; 110 | write channel msg >>= fun () -> 111 | Ivar.read var 112 | 113 | let reply1 (_, read) write ?(once=true) channel handler = 114 | let var = Ivar.create () in 115 | read ~once (Ivar.fill var) channel; 116 | Ivar.read var >>= handler >>= fun msg -> 117 | write channel msg 118 | 119 | let request2 req (mid1, rep1) id1 (mid2, rep2) id2 channel message = 120 | let var = Ivar.create () in 121 | let handler id mid msg = 122 | Ivar.fill var (id msg); 123 | Framing.deregister_method_handler channel mid 124 | in 125 | rep1 ~once:true (handler id1 mid2) channel; 126 | rep2 ~once:true (handler id2 mid1) channel; 127 | req channel message >>= fun () -> 128 | Ivar.read var 129 | -------------------------------------------------------------------------------- /async/src/queue.ml: -------------------------------------------------------------------------------- 1 | open Thread 2 | open Amqp_client_lib 3 | open Spec.Queue 4 | 5 | type t = { name: string } 6 | 7 | let message_ttl v = "x-message-ttl", Types.VLonglong v 8 | let auto_expire v = "x-expires", Types.VLonglong v 9 | let max_length v = "x-max-length", Types.VLonglong v 10 | let max_length_bytes v = "x-max-length-bytes", Types.VLonglong v 11 | let dead_letter_exchange v = "x-dead-letter-exchange", Types.VLongstr v 12 | let dead_letter_routing_key v = "x-dead-letter-routing-key", Types.VLongstr v 13 | let maximum_priority v = "x-max-priority", Types.VLonglong v 14 | 15 | let declare channel ?(durable=false) ?(exclusive=false) ?(auto_delete=false) ?(passive=false) ?(arguments=[]) ?(autogenerate=false) name = 16 | if autogenerate && String.length name != 0 then 17 | invalid_arg "Queue.declare name must be empty if autogenerate is true."; 18 | if not autogenerate && String.length name == 0 then 19 | invalid_arg "Queue.declare autogenerate must be true if name is empty."; 20 | let channel = Channel.channel channel in 21 | let req = { Declare.queue=name; passive; durable; exclusive; 22 | auto_delete; no_wait=false; arguments } 23 | in 24 | Declare.request channel req >>= fun rep -> 25 | if not autogenerate && name <> rep.Declare_ok.queue then 26 | failwith "Queue name returned by server doesn't match requested."; 27 | return { name = rep.Declare_ok.queue } 28 | 29 | let get ~no_ack channel t = 30 | let open Spec.Basic in 31 | let channel = Channel.channel channel in 32 | Get.request channel { Get.queue=t.name; no_ack } >>= function 33 | | `Get_empty () -> 34 | return None 35 | | `Get_ok (get_ok, (header, body)) -> 36 | return (Some { Message.delivery_tag = get_ok.Get_ok.delivery_tag; 37 | Message.redelivered = get_ok.Get_ok.redelivered; 38 | Message.exchange = get_ok.Get_ok.exchange; 39 | Message.routing_key = get_ok.Get_ok.routing_key; 40 | Message.message = (header, body) }) 41 | 42 | (** Publish a message directly to a queue *) 43 | let publish channel t ?mandatory message = 44 | Exchange.publish channel Exchange.default ?mandatory 45 | ~routing_key:t.name 46 | message 47 | 48 | type 'a consumer = { channel: 'a Channel.t; 49 | tag: string; 50 | writer: Message.t Pipe.Writer.t } 51 | 52 | (** Consume message from a queue. *) 53 | let consume ~id ?(no_local=false) ?(no_ack=false) ?(exclusive=false) ?(arguments=[]) 54 | ?on_cancel channel t = 55 | let open Spec.Basic in 56 | let (reader, writer) = Pipe.create () in 57 | let consumer_tag = Printf.sprintf "%s.%s" (Channel.Internal.unique_id channel) id 58 | in 59 | let on_cancel () = 60 | Pipe.close_without_pushback writer; 61 | match on_cancel with 62 | | Some f -> f () 63 | | None -> raise (Types.Consumer_cancelled consumer_tag) 64 | in 65 | 66 | let to_writer (deliver, header, body) = 67 | { Message.delivery_tag = deliver.Deliver.delivery_tag; 68 | Message.redelivered = deliver.Deliver.redelivered; 69 | Message.exchange = deliver.Deliver.exchange; 70 | Message.routing_key = deliver.Deliver.routing_key; 71 | Message.message = (header, body) } 72 | |> Pipe.write_without_pushback writer 73 | in 74 | let req = { Consume.queue=t.name; 75 | consumer_tag; 76 | no_local; 77 | no_ack; 78 | exclusive; 79 | no_wait = false; 80 | arguments; 81 | } 82 | in 83 | let var = Ivar.create () in 84 | let on_receive consume_ok = 85 | Channel.Internal.register_consumer_handler channel consume_ok.Consume_ok.consumer_tag to_writer on_cancel; 86 | Ivar.fill var consume_ok 87 | in 88 | let read = snd Consume_ok.Internal.read in 89 | read ~once:true on_receive (Channel.channel channel); 90 | 91 | Consume.Internal.write (Channel.channel channel) req >>= fun () -> 92 | Ivar.read var >>= fun rep -> 93 | let tag = rep.Consume_ok.consumer_tag in 94 | return ({ channel; tag; writer }, reader) 95 | 96 | let cancel consumer = 97 | let open Spec.Basic in 98 | Cancel.request (Channel.channel consumer.channel) { Cancel.consumer_tag = consumer.tag; no_wait = false } >>= fun _rep -> 99 | Channel.Internal.deregister_consumer_handler consumer.channel consumer.tag; 100 | Pipe.close consumer.writer 101 | 102 | let bind channel t exchange = Exchange.Internal.bind_queue channel exchange t.name 103 | let unbind channel t exchange = Exchange.Internal.unbind_queue channel exchange t.name 104 | 105 | (** Purge the queue *) 106 | let purge channel t = 107 | Purge.request (Channel.channel channel) 108 | { Purge.queue = t.name; 109 | no_wait = false; 110 | } >>= fun _rep -> 111 | return () 112 | 113 | (** Delete the queue. *) 114 | let delete ?(if_unused=false) ?(if_empty=false) channel t = 115 | Delete.request (Channel.channel channel) 116 | { Delete.queue = t.name; 117 | if_unused; 118 | if_empty; 119 | no_wait = false; 120 | } >>= fun _rep -> return () 121 | 122 | 123 | (** Name of the queue *) 124 | let name t = t.name 125 | 126 | (** Construct a queue without any validation *) 127 | let fake _channel name = return { name } 128 | -------------------------------------------------------------------------------- /async/src/queue.mli: -------------------------------------------------------------------------------- 1 | open Thread 2 | open Amqp_client_lib 3 | 4 | (** Operations on Queues *) 5 | type t 6 | type 'a consumer 7 | 8 | val message_ttl : int -> string * Types.value 9 | val auto_expire : int -> string * Types.value 10 | val max_length : int -> string * Types.value 11 | val max_length_bytes : int -> string * Types.value 12 | val dead_letter_exchange : string -> string * Types.value 13 | val dead_letter_routing_key : string -> string * Types.value 14 | val maximum_priority : int -> string * Types.value 15 | 16 | (** Declare a queue. 17 | 18 | To use server-generated queue name explicitly pass 19 | [~autogenerate:true] and empty name: [declare channel ~autogenerate:true ""]. 20 | Reason for making [autogenerate] param explicit is inability in production 21 | to find out which services are leaking queues with auto-generated names. 22 | We advice not to use this feature in production. 23 | *) 24 | val declare : 25 | _ Channel.t -> 26 | ?durable:bool -> 27 | ?exclusive:bool -> 28 | ?auto_delete:bool -> 29 | ?passive:bool -> 30 | ?arguments:Types.table -> 31 | ?autogenerate:bool -> 32 | string -> t Deferred.t 33 | 34 | (** Get a single message from the queue. 35 | The function automatically handles ack. 36 | 37 | If [no_ack] is false (default), the message is requsted with expicit 38 | ack and the caller is responsible for ack'ing or rejecting the message. 39 | *) 40 | val get : 41 | no_ack:bool -> 42 | _ Channel.t -> 43 | t -> Message.t option Deferred.t 44 | 45 | (** Publish a message directly to a queue *) 46 | val publish : 47 | 'a Channel.t -> t -> 48 | ?mandatory:bool -> 49 | Message.message -> 'a Deferred.t 50 | 51 | (** Setup consumption of a queue. Remember to ack messages. 52 | 53 | All messages are processed concurrently. To limit number of 54 | concurrent processes, set the prefetch threshold. 55 | 56 | [on_cancel] is called if the server cancels consumption. This may 57 | happen if e.g. the queue is deleted. If the argument is not 58 | provided and exception is raised. 59 | 60 | *) 61 | val consume : 62 | id:string -> 63 | ?no_local:bool -> 64 | ?no_ack:bool -> 65 | ?exclusive:bool -> 66 | ?arguments:Types.table -> 67 | ?on_cancel:(unit -> unit) -> 68 | 'a Channel.t -> 69 | t -> 70 | ('a consumer * Message.t Pipe.Reader.t) Deferred.t 71 | 72 | 73 | (** Cancel consumption. *) 74 | val cancel : _ consumer -> unit Deferred.t 75 | 76 | (** Bind a queue to an exchange. 77 | Messages posted on the exchange which match the routing key 78 | (and optionally match the headers) 79 | will be routed to the queue 80 | *) 81 | val bind : _ Channel.t -> t -> 'b Exchange.t -> 'b -> unit Deferred.t 82 | 83 | (** Remove a binding from an exchange to a queue *) 84 | val unbind : _ Channel.t -> t -> 'b Exchange.t -> 'b -> unit Deferred.t 85 | 86 | (** Purge all messages on a queue *) 87 | val purge : _ Channel.t -> t -> unit Deferred.t 88 | 89 | (** Delete a queue *) 90 | val delete : 91 | ?if_unused:bool -> 92 | ?if_empty:bool -> _ Channel.t -> t -> unit Deferred.t 93 | 94 | (** Name of the queue *) 95 | val name : t -> string 96 | 97 | (**/**) 98 | val fake : 'a -> string -> t Deferred.t 99 | (**/**) 100 | -------------------------------------------------------------------------------- /async/src/rpc.ml: -------------------------------------------------------------------------------- 1 | open Thread 2 | open Amqp_client_lib 3 | open Types 4 | open Spec.Basic 5 | 6 | module Client = struct 7 | 8 | type t = { queue: Queue.t; 9 | channel: [ `Ok ] Channel.t; 10 | id: string; 11 | outstanding: (string, Message.message option Ivar.t) Hashtbl.t; 12 | mutable counter: int; 13 | consumer: [ `Ok ] Queue.consumer; 14 | } 15 | 16 | let handle_reply t ok (content, body) = 17 | let reply = match ok with 18 | | true -> Some (content, body) 19 | | false -> None 20 | in 21 | match content.Content.correlation_id with 22 | | Some id -> 23 | begin match Hashtbl.find t.outstanding id with 24 | | var -> 25 | Ivar.fill var reply; 26 | Hashtbl.remove t.outstanding id; 27 | return () 28 | | exception Not_found -> 29 | (* maybe such a id never existed, maybe it arrived too late so 30 | * it was deleted in the meantime *) 31 | return () 32 | end 33 | | None -> failwith "No correlation id set" 34 | 35 | let init ~id connection = 36 | Connection.open_channel ~id:"rpc_client" Channel.no_confirm connection >>= fun channel -> 37 | let id = Printf.sprintf "%s.%s" (Channel.id channel) id in 38 | Queue.declare channel 39 | ~exclusive:true 40 | ~auto_delete:true 41 | id >>= fun queue -> 42 | 43 | Queue.bind channel queue Exchange.amq_match (`Headers ["reply_to", VLongstr (Queue.name queue)]) >>= fun () -> 44 | 45 | Queue.consume ~id:"rpc_client" ~no_ack:true ~exclusive:true channel queue >>= fun (consumer, reader) -> 46 | let t = { queue; channel; id; outstanding = Hashtbl.create 0; counter = 0; consumer } in 47 | spawn (Pipe.iter reader ~f:(fun { Message.message; routing_key; _ } -> handle_reply t (routing_key = Queue.name queue) message)); 48 | spawn (Pipe.iter (Channel.on_return channel) ~f:(fun (_, message) -> handle_reply t false message)); 49 | return t 50 | 51 | let call t ?correlation_id ~ttl ?(grace_time_ms=100) ~routing_key ~headers exchange (header, body) = 52 | let correlation_id_prefix = match correlation_id with 53 | | Some cid -> cid 54 | | None -> t.id 55 | in 56 | let correlation_id = Printf.sprintf "%s.%d" correlation_id_prefix t.counter in 57 | t.counter <- t.counter + 1; 58 | (* Register handler for the reply before sending the query *) 59 | let var = Ivar.create () in 60 | Hashtbl.add t.outstanding correlation_id var; 61 | let expiration = Some (string_of_int ttl) in 62 | (* Set headers so we can get timedout messages *) 63 | let header = { header with Content.correlation_id = Some correlation_id; 64 | expiration; 65 | reply_to = Some (Queue.name t.queue); 66 | headers = Some (Message.string_header "reply_to" (Queue.name t.queue) :: headers) 67 | } 68 | in 69 | Exchange.publish t.channel ~mandatory:true ~routing_key exchange (header, body) >>= function 70 | | `Ok -> with_timeout (ttl + grace_time_ms) (Ivar.read var) >>= function 71 | | `Timeout -> 72 | Hashtbl.remove t.outstanding correlation_id; 73 | return None 74 | | `Result a -> return a 75 | 76 | (** Release resources *) 77 | let close t = 78 | Hashtbl.iter (fun _ var -> Ivar.fill var None) t.outstanding; 79 | Queue.cancel t.consumer >>= fun () -> 80 | Queue.delete t.channel t.queue >>= fun () -> 81 | Channel.close t.channel >>= fun () -> 82 | return () 83 | end 84 | 85 | module Server = struct 86 | 87 | open Spec.Basic 88 | (* The server needs a queue name and a handler *) 89 | 90 | type 'a t = { consumer: 'a Queue.consumer } 91 | 92 | let queue_argument = Queue.dead_letter_exchange (Exchange.name Exchange.amq_match) 93 | 94 | let start ?(async=false) ?(discard_redelivered=false) channel queue handler = 95 | let handler ({ Message.message = (content, body); redelivered; _} as message) = 96 | 97 | let routing_key = match content.Content.reply_to with 98 | | Some r -> r 99 | | None -> failwith "Missing reply_to in reposnse" 100 | in 101 | 102 | let correlation_id = content.Content.correlation_id in 103 | match redelivered && discard_redelivered with 104 | | false -> begin 105 | handler (content, body) >>= fun (content, body) -> 106 | let content = { content with Content.correlation_id } in 107 | Exchange.publish channel Exchange.default ~routing_key (content, body) >>= function 108 | | `Ok -> Message.ack channel message 109 | | `Failed -> Message.reject ~requeue:true channel message 110 | end 111 | | true -> 112 | Message.reject ~requeue:false channel message 113 | in 114 | (* Start consuming. *) 115 | Queue.consume ~id:"rpc_server" channel queue >>= fun (consumer, reader) -> 116 | let read = match async with 117 | | true -> Pipe.iter_without_pushback reader ~f:(fun m -> spawn (handler m)) 118 | | false -> Pipe.iter reader ~f:handler 119 | in 120 | spawn read; 121 | return { consumer } 122 | 123 | let stop t = 124 | Queue.cancel t.consumer 125 | end 126 | -------------------------------------------------------------------------------- /async/src/rpc.mli: -------------------------------------------------------------------------------- 1 | (** Rpc client and server patterns *) 2 | 3 | open Thread 4 | open Amqp_client_lib 5 | 6 | (** Rpc Client pattern *) 7 | module Client : 8 | sig 9 | type t 10 | 11 | (** Initialize a client with the [id] for tracing *) 12 | val init : id:string -> Connection.t -> t Deferred.t 13 | 14 | (** Make an rpc call to the exchange using the routing key and headers. 15 | @param ttl is the message timeout in milliseconds. 16 | If the message is on the rpc endpoints queue for more than [ttl] 17 | milliseconds the message will be dead 18 | lettered and returned which will cause this function to timeout and 19 | return None. 20 | 21 | @param grace_time_ms is the time added to the ttl before the function times out and returns None 22 | This is to give the rpc serve a chance to process the message, 23 | in case the rpc server consumed the message from the queue close to ttl. 24 | Default 100ms. 25 | 26 | To call directly to a named queue, use 27 | [call t Exchange.default ~ttl:500 ~routing_key:"name_of_the_queue" ~headers:[]] 28 | 29 | [correlation_id] allows you to specify a correlation id. The 30 | id will be suffixed with an id to allow the caller to reuse 31 | correlation ids. This can be used for tracing by reusing 32 | correlation ids of incomming requests resulting in new 33 | calls. If no correlation is given the id of the [client] is used. 34 | 35 | The function allows the call to specify both a routing key and 36 | headers regardless of the type of exchange used, as exchanges 37 | may be chained in a way where both headers and routing keys 38 | are used. 39 | 40 | This function will timeout and return None, either if the request message is 41 | dead-lettered or if ttl + grace_time_ms has passed. 42 | *) 43 | val call : 44 | t -> 45 | ?correlation_id:string -> 46 | ttl:int -> 47 | ?grace_time_ms:int -> 48 | routing_key:string -> 49 | headers:Types.header list -> 50 | _ Exchange.t -> 51 | Spec.Basic.Content.t * string -> 52 | Message.message option Deferred.t 53 | 54 | (** Release resources *) 55 | val close : t -> unit Deferred.t 56 | end 57 | 58 | (** Rpc Server pattern *) 59 | module Server : 60 | sig 61 | type 'a t 62 | 63 | (** Recommended argument to add when declaring the rpc server queue. 64 | This will set the dead letter exchange to the header exchange to help 65 | clients to be notified if a request has timed out 66 | *) 67 | val queue_argument : Types.header 68 | 69 | (** Start an rpc server producing replies for requests coming in 70 | on the given queue. 71 | @param async If true, multiple requests can be handled concurrently. 72 | If false, message are handled synchronously (default) 73 | 74 | It is recommended to create the queue with the header_exchange 75 | as dead letter exchange. This will allow messages to be routed 76 | back the the sender at timeout. E.g: 77 | [ Queue.declare ~arguments:[Rpc.queue_argument] "rpcservice" ] 78 | *) 79 | val start : 80 | ?async:bool -> ?discard_redelivered:bool -> 81 | ([< `Failed | `Ok ] as 'a) Channel.t -> 82 | Queue.t -> 83 | (Message.message -> Message.message Deferred.t) -> 'a t Deferred.t 84 | 85 | (** Stop the server *) 86 | val stop : _ t -> unit Deferred.t 87 | end 88 | -------------------------------------------------------------------------------- /async/src/thread.ml: -------------------------------------------------------------------------------- 1 | (** Async compatibility layer *) 2 | open Amqp_client_lib 3 | open Async 4 | 5 | module Deferred = struct 6 | type 'a t = 'a Deferred.t 7 | let all_unit = Deferred.all_unit 8 | let try_with f = Monitor.try_with ~extract_exn:true f >>= function 9 | | Core.Result.Ok v -> return (`Ok v) 10 | | Core.Result.Error exn -> return (`Error exn) 11 | module List = struct 12 | let init ?(how:[`Sequential | `Parallel] = `Parallel) ~f n = Deferred.List.init ~how:(how :> Async_kernel.Monad_sequence.how) ~f n 13 | let iter ?(how:[`Sequential | `Parallel] = `Parallel) ~f l = Deferred.List.iter ~how:(how :> Async_kernel.Monad_sequence.how) ~f l 14 | end 15 | 16 | end 17 | 18 | let (>>=) = (>>=) 19 | let (>>|) = (>>|) 20 | let return a = return a 21 | let after ms = after (Core.Time_float.Span.of_ms ms) 22 | let spawn ?exn_handler t = 23 | don't_wait_for ( 24 | match exn_handler with 25 | | Some handler -> 26 | begin 27 | Monitor.try_with (fun () -> t) >>= function 28 | | Ok () -> return () 29 | | Error exn -> handler exn 30 | end 31 | | None -> t 32 | ) 33 | 34 | let with_timeout milliseconds deferred = 35 | let duration = Core.Time_float.Span.of_ms (float_of_int milliseconds) in 36 | Clock.with_timeout duration deferred 37 | 38 | module Ivar = struct 39 | include Ivar 40 | end 41 | 42 | module Reader = struct 43 | type t = Reader.t 44 | let close = Reader.close 45 | let read t buf = Reader.really_read t buf 46 | end 47 | 48 | module Writer = struct 49 | type t = Writer.t 50 | let write t buf = Writer.write t buf 51 | let close t = Writer.close t 52 | let flush t = Writer.flushed t 53 | end 54 | 55 | module Tcp = struct 56 | let connect ~exn_handler ?nodelay host port = 57 | let addr = Core.Host_and_port.create ~host ~port 58 | |> Tcp.Where_to_connect.of_host_and_port 59 | in 60 | let monitor = Monitor.create ~name:"Network" () in 61 | Monitor.Exported_for_scheduler.within' ~monitor(fun () -> Tcp.connect ~buffer_age_limit:`Unlimited addr) >>= fun (s, r, w) -> 62 | spawn (Monitor.detach_and_get_next_error monitor >>= exn_handler); 63 | (match nodelay with 64 | | Some () -> Socket.setopt s Socket.Opt.nodelay true 65 | | None -> ()); 66 | return (r, w) 67 | end 68 | 69 | module Log = struct 70 | (* Use of a predefiend tag allows the caller to disable logging if needed *) 71 | let tags = ["library", "amqp_client"] 72 | let debug fmt = Log.Global.debug ~tags fmt 73 | let info fmt = Log.Global.info ~tags fmt 74 | let error fmt = Log.Global.error ~tags fmt 75 | end 76 | 77 | (* Pipes *) 78 | module Pipe = struct 79 | module Writer = struct 80 | type 'a t = 'a Pipe.Writer.t 81 | end 82 | module Reader = struct 83 | type 'a t = 'a Pipe.Reader.t 84 | end 85 | 86 | let create () = Pipe.create () 87 | let set_size_budget t = Pipe.set_size_budget t 88 | let flush t = Pipe.downstream_flushed t >>= fun _ -> return () 89 | let interleave_pipe t = Pipe.interleave_pipe t 90 | let write r elm = Pipe.write r elm 91 | let write_without_pushback r elm = Pipe.write_without_pushback r elm 92 | 93 | let transfer_in ~from t = 94 | Ocaml_lib.Queue.iter (write_without_pushback t) from; 95 | return () 96 | 97 | let close_without_pushback t = Pipe.close t 98 | let close t = Pipe.close t; flush t >>= fun _ -> return () 99 | let read r = Pipe.read r 100 | let iter r ~f = Pipe.iter r ~f 101 | let iter_without_pushback r ~f = Pipe.iter_without_pushback r ~f 102 | 103 | end 104 | 105 | module Scheduler = struct 106 | let go () = Scheduler.go () |> ignore 107 | let shutdown n = Shutdown.shutdown n 108 | end 109 | -------------------------------------------------------------------------------- /async/src/thread.mli: -------------------------------------------------------------------------------- 1 | include Amqp_client_lib.Thread.T 2 | with type 'a Deferred.t = 'a Async_kernel.Deferred.t 3 | and type Writer.t = Async.Writer.t 4 | and type Reader.t = Async.Reader.t 5 | and type 'a Pipe.Reader.t = 'a Async.Pipe.Reader.t 6 | and type 'a Pipe.Writer.t = 'a Async.Pipe.Writer.t 7 | and type 'a Ivar.t = 'a Async_kernel.Ivar.t 8 | -------------------------------------------------------------------------------- /async/test/amqp.ml: -------------------------------------------------------------------------------- 1 | include Amqp_client_async 2 | -------------------------------------------------------------------------------- /async/test/channel_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let test = 8 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 9 | Connection.connect ~id:(uniq "ocaml-amqp-tests") ?port "localhost" >>= fun connection -> 10 | Log.info "Connection started"; 11 | Connection.open_channel ~id:(uniq "test") Channel.no_confirm connection >>= fun channel -> 12 | Log.info "Channel opened"; 13 | Channel.close channel >>= fun () -> 14 | Log.info "Channel closed"; 15 | Deferred.List.init 600 ~f:(fun _ -> Connection.open_channel ~id:(uniq "test") Channel.no_confirm connection) >>= fun channels -> 16 | Log.info "Channels opened"; 17 | Deferred.List.iter channels ~f:Channel.close >>= fun () -> 18 | Log.info "Channels closed"; 19 | Connection.close connection >>| fun () -> 20 | Log.info "Connection closed"; 21 | Scheduler.shutdown 0 22 | 23 | let _ = 24 | Scheduler.go () 25 | let () = Printf.printf "Done\n" 26 | -------------------------------------------------------------------------------- /async/test/close_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let handler var { Message.message = (_, body); _ } = Ivar.fill var body; return () 8 | 9 | let test () = 10 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 11 | Connection.connect ~virtual_host:"/" ~id:(uniq "ocaml-amqp-test") ?port "localhost" >>= fun connection -> 12 | Log.info "Connection started"; 13 | Connection.open_channel ~id:(uniq "queue.test") Channel.no_confirm connection >>= fun channel -> 14 | Log.info "Channel opened"; 15 | Queue.declare channel ~auto_delete:false (uniq "queue.test") >>= fun queue -> 16 | Log.info "Queue declared"; 17 | Queue.publish channel queue (Message.make "Test") >>= fun res -> 18 | assert (res = `Ok); 19 | Log.info "Message published"; 20 | Connection.close connection >>= fun () -> 21 | Log.info "Connection closed"; 22 | Connection.connect ~virtual_host:"/" ~id:(uniq "ocaml-amqp-test") "localhost" >>= fun connection -> 23 | Log.info "Connection started"; 24 | Connection.open_channel ~id:(uniq "queue.test") Channel.no_confirm connection >>= fun channel -> 25 | Log.info "Channel opened"; 26 | Queue.declare channel ~auto_delete:false (uniq "queue.test") >>= fun queue -> 27 | Log.info "Queue declared"; 28 | Queue.get ~no_ack:false channel queue >>= fun m -> 29 | (match m with 30 | | None -> failwith "No message" 31 | | Some _ -> () 32 | ); 33 | Log.info "Message received"; 34 | Queue.delete channel queue >>= fun () -> 35 | Log.info "Queue deleted"; 36 | Channel.close channel >>= fun () -> 37 | Log.info "Channel closed"; 38 | Connection.close connection >>| fun () -> 39 | Log.info "Connection closed"; 40 | Scheduler.shutdown 0 41 | 42 | let _ = 43 | test () |> ignore; 44 | Scheduler.go () 45 | let () = Printf.printf "Done\n" 46 | -------------------------------------------------------------------------------- /async/test/connect_uri_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let test = 8 | let port = Sys.getenv_opt "AMQP_PORT" in 9 | let uri1, uri2 = 10 | let u1 = Printf.sprintf "amqp://localhost%s%s" in 11 | let u2 = Printf.sprintf "amqp://guest:guest@localhost:%s/?heartbeat_interval=11" in 12 | match port with 13 | | Some port -> 14 | u1 ":" port, 15 | u2 port 16 | | None -> 17 | u1 "" "", 18 | u2 "5672" 19 | in 20 | Connection.connect_uri ~id:(uniq "1") uri1 >>= fun connection1 -> 21 | Connection.connect_uri ~id:(uniq "2") uri2 >>= fun connection2 -> 22 | Connection.close connection1 >>= fun () -> 23 | Connection.close connection2 >>| fun () -> 24 | Log.info "Connections closed"; 25 | Scheduler.shutdown 0 26 | 27 | let _ = 28 | Scheduler.go () 29 | let () = Printf.printf "Done\n" 30 | -------------------------------------------------------------------------------- /async/test/connection_fail_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let test = 8 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 9 | Thread.Deferred.try_with 10 | (fun () -> 11 | Connection.connect ~credentials:("invalid", "credentials") ~id:(uniq "ocaml-amqp-tests") ?port "localhost" >>= fun connection -> 12 | Connection.close connection 13 | ) >>| function 14 | | `Error Amqp_client_lib.Types.Connection_closed -> 15 | Scheduler.shutdown 0 16 | | _ -> 17 | Scheduler.shutdown 1 18 | 19 | let _ = 20 | Scheduler.go () 21 | 22 | let () = Printf.printf "Done\n" 23 | -------------------------------------------------------------------------------- /async/test/connection_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let test = 8 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 9 | Connection.connect ?port ~id:(uniq "ocaml-amqp-tests") "localhost" >>= fun connection1 -> 10 | Connection.connect ?port ~id:(uniq "ocaml-amqp-tests1") "localhost" >>= fun connection2 -> 11 | Connection.close connection1 >>= fun () -> 12 | Connection.close connection2 >>| fun () -> 13 | Log.info "Connections closed"; 14 | Scheduler.shutdown 0 15 | 16 | let _ = 17 | Scheduler.go () 18 | let () = Printf.printf "Done\n" 19 | -------------------------------------------------------------------------------- /async/test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names channel_test 3 | close_test 4 | connection_test 5 | connection_fail_test 6 | connect_uri_test 7 | exchange_test 8 | mandatory_test 9 | queue_test 10 | queue_declare_test 11 | repeat 12 | rpc_async_test 13 | rpc_test 14 | vhost_test 15 | with_confirm_test 16 | queue_cancel_test) 17 | (libraries amqp-client-async) 18 | ) 19 | 20 | (rule 21 | (alias integration) 22 | (action (run ./channel_test.exe)) 23 | (package amqp-client-async) 24 | ) 25 | 26 | (rule 27 | (alias integration) 28 | (action (run ./connection_test.exe)) 29 | (package amqp-client-async) 30 | ) 31 | 32 | (rule 33 | (alias integration) 34 | (action (run ./connection_fail_test.exe)) 35 | (package amqp-client-async) 36 | ) 37 | 38 | (rule 39 | (alias integration) 40 | (action (run ./connect_uri_test.exe)) 41 | (package amqp-client-async) 42 | ) 43 | 44 | (rule 45 | (alias integration) 46 | (action (run ./exchange_test.exe)) 47 | (package amqp-client-async) 48 | ) 49 | 50 | (rule 51 | (alias integration) 52 | (action (run ./mandatory_test.exe)) 53 | (package amqp-client-async) 54 | ) 55 | 56 | (rule 57 | (alias integration) 58 | (action (run ./queue_test.exe)) 59 | (package amqp-client-async) 60 | ) 61 | 62 | (rule 63 | (alias integration) 64 | (action (run ./queue_declare_test.exe)) 65 | (package amqp-client-async) 66 | ) 67 | 68 | ;(rule 69 | ; (alias integration) 70 | ; (action (run ./repeat.exe)) 71 | ; (package amqp-client-async) 72 | ;) 73 | 74 | (rule 75 | (alias integration) 76 | (action (run ./rpc_async_test.exe)) 77 | (package amqp-client-async) 78 | ) 79 | 80 | (rule 81 | (alias integration) 82 | (action (run ./rpc_test.exe)) 83 | (package amqp-client-async) 84 | ) 85 | 86 | (rule 87 | (alias integration) 88 | (action (run ./vhost_test.exe)) 89 | (package amqp-client-async) 90 | ) 91 | 92 | (rule 93 | (alias integration) 94 | (action (run ./with_confirm_test.exe)) 95 | (package amqp-client-async) 96 | ) 97 | 98 | (rule 99 | (alias integration) 100 | (action (run ./queue_cancel_test.exe)) 101 | (package amqp-client-async) 102 | ) 103 | -------------------------------------------------------------------------------- /async/test/exchange_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let test = 8 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 9 | Connection.connect ~id:(uniq "") ?port "localhost" >>= fun connection -> 10 | Log.info "Connection started"; 11 | Connection.open_channel ~id:(uniq "test") Channel.no_confirm connection >>= fun channel -> 12 | Log.info "Channel opened"; 13 | Exchange.declare channel ~auto_delete:true Exchange.direct_t (uniq "test1") >>= fun exchange1 -> 14 | Log.info "Exchange declared"; 15 | Exchange.declare channel ~auto_delete:true Exchange.direct_t (uniq "test2") >>= fun exchange2 -> 16 | Log.info "Exchange declared"; 17 | Exchange.bind channel ~source:exchange1 ~destination:exchange2 (`Queue (uniq "test")) >>= fun () -> 18 | Log.info "Exchange Bind"; 19 | Exchange.unbind channel ~source:exchange1 ~destination:exchange2 (`Queue (uniq "test")) >>= fun () -> 20 | Log.info "Exchange Unbind"; 21 | Exchange.delete channel exchange1 >>= fun () -> 22 | Log.info "Exchange deleted"; 23 | Exchange.delete channel exchange2 >>= fun () -> 24 | Log.info "Exchange deleted"; 25 | Channel.close channel >>= fun () -> 26 | Log.info "Channel closed"; 27 | Connection.close connection >>| fun () -> 28 | Log.info "Connection closed"; 29 | Scheduler.shutdown 0 30 | 31 | let _ = 32 | Scheduler.go () 33 | let () = Printf.printf "Done\n" 34 | -------------------------------------------------------------------------------- /async/test/mandatory_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let handler var { Message.message = (_, body); _ } = Ivar.fill var body; return () 8 | 9 | let assert_returned_message reader body = 10 | Pipe.read reader >>| function 11 | | `Ok (_, (_, m)) -> assert (m = body); () 12 | | `Eof -> assert false 13 | 14 | let assert_reader_closed reader = 15 | Pipe.read reader >>| function 16 | | `Ok _ -> assert false 17 | | `Eof -> () 18 | 19 | let print_r = function 20 | | `Ok -> Printf.eprintf "Got ok\n%!" 21 | | `Failed -> Printf.eprintf "Got failed\n%!" 22 | 23 | let test = 24 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 25 | Connection.connect ~id:(uniq "") ?port "localhost" >>= fun connection -> 26 | Log.info "Connection started"; 27 | Connection.open_channel ~id:(uniq "queue.test") Channel.with_confirm connection >>= fun channel -> 28 | Log.info "Channel opened"; 29 | 30 | Exchange.publish channel Exchange.amq_direct ~mandatory:false ~routing_key:"non_existant_queue" (Message.make "") >>= fun r -> 31 | assert (r = `Ok); 32 | Exchange.publish channel Exchange.amq_direct ~mandatory:true ~routing_key:"non_existant_queue" (Message.make "") >>= fun r -> 33 | assert (r = `Failed); 34 | 35 | (* Test on_return delivery handler *) 36 | let reader1 = Channel.on_return channel in 37 | let reader2 = Channel.on_return channel in 38 | let body = "Return this message" in 39 | Exchange.publish channel Exchange.amq_direct ~mandatory:true ~routing_key:"non_existant_queue" (Message.make body) >>= fun r -> 40 | assert (r = `Failed); 41 | assert_returned_message reader1 body >>= fun () -> 42 | assert_returned_message reader2 body >>= fun () -> 43 | 44 | Channel.close channel >>= fun () -> 45 | Log.info "Channel closed"; 46 | assert_reader_closed reader1 >>= fun () -> 47 | assert_reader_closed reader2 >>= fun () -> 48 | 49 | Connection.close connection >>| fun () -> 50 | Log.info "Connection closed"; 51 | Scheduler.shutdown 0 52 | 53 | let _ = 54 | Scheduler.go () 55 | let () = Printf.printf "Done\n" 56 | -------------------------------------------------------------------------------- /async/test/queue_cancel_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let handler var { Message.message = (_, body); _ } = Ivar.fill var body; return () 8 | 9 | let test = 10 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 11 | Connection.connect ~id:(uniq "") ?port "localhost" >>= fun connection -> 12 | Log.info "Connection started"; 13 | Connection.open_channel ~id:(uniq "queue.test") Channel.no_confirm connection >>= fun channel -> 14 | Log.info "Channel opened"; 15 | Queue.declare channel ~auto_delete:true (uniq "queue.test") >>= fun queue -> 16 | Log.info "Queue declared"; 17 | (* Start consuming *) 18 | let cancelled = ref false in 19 | Queue.consume ~id:(uniq "consume_test") ~on_cancel:(fun () -> cancelled := true) channel queue >>= fun (_consumer, reader) -> 20 | Queue.publish channel queue (Message.make "Test") >>= fun `Ok -> 21 | Pipe.read reader >>= fun res -> 22 | assert (res <> `Eof); 23 | Log.info "Message read"; 24 | 25 | (* Delete the queue *) 26 | Queue.delete channel queue >>= fun () -> 27 | Log.info "Queue deleted"; 28 | Pipe.read reader >>= fun res -> 29 | assert (res = `Eof); 30 | assert (!cancelled); 31 | Log.info "Consumer cancelled"; 32 | Channel.close channel >>= fun () -> 33 | Log.info "Channel closed"; 34 | Connection.close connection >>| fun () -> 35 | Log.info "Connection closed"; 36 | Scheduler.shutdown 0 37 | 38 | let _ = 39 | Scheduler.go () 40 | 41 | let () = Printf.printf "Done\n" 42 | -------------------------------------------------------------------------------- /async/test/queue_declare_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let handler var { Message.message = (_, body); _ } = Ivar.fill var body; return () 8 | 9 | let declare ~channel name = 10 | let queue_name = uniq name in 11 | Queue.declare channel ~auto_delete:true queue_name >>= fun queue -> 12 | Log.info "Created queue: %s === %s" (Queue.name queue) queue_name; 13 | match Queue.name queue = queue_name with 14 | | false -> failwith (Printf.sprintf "Queue name mismatch: %s != %s" (Queue.name queue) queue_name) 15 | | true -> return queue 16 | 17 | let check_declare_autogenerate ~channel = 18 | Queue.declare channel ~auto_delete:true ~autogenerate:true "" >>= fun queue -> 19 | Log.info "Created queue: %s" (Queue.name queue); 20 | let _ = try 21 | Queue.declare channel ~auto_delete:true 22 | ~autogenerate:true "non-empty-name" 23 | with Invalid_argument msg -> 24 | assert (msg = "Queue.declare name must be empty if autogenerate is true."); 25 | return queue 26 | in 27 | let _ = try 28 | Queue.declare channel ~auto_delete:true "" 29 | with Invalid_argument msg -> 30 | assert (msg = "Queue.declare autogenerate must be true if name is empty."); 31 | return queue 32 | in 33 | return queue 34 | 35 | 36 | let test = 37 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 38 | Connection.connect ~id:(uniq "") ?port "localhost" >>= fun connection -> 39 | Log.info "Connection started"; 40 | Connection.open_channel ~id:(uniq "queue.test") Channel.no_confirm connection >>= fun channel -> 41 | Log.info "Channel opened"; 42 | let queues = 43 | [0;1;2;3;4;5;6;7;8;9] 44 | |> List.map (fun i -> Printf.sprintf "queue.test_%d" i) 45 | |> List.map (declare ~channel) 46 | in 47 | let queues = check_declare_autogenerate ~channel :: queues in 48 | List.fold_left (fun acc queue -> acc >>= fun acc -> queue >>= fun queue -> return (queue :: acc)) (return []) queues >>= fun queues -> 49 | Log.info "Queues declared"; 50 | List.fold_left (fun acc queue -> acc >>= fun () -> Queue.delete channel queue) (return ()) queues >>= fun () -> 51 | Log.info "Queues deleted"; 52 | Channel.close channel >>= fun () -> 53 | Log.info "Channel closed"; 54 | Connection.close connection >>| fun () -> 55 | Log.info "Connection closed"; 56 | Scheduler.shutdown 0 57 | 58 | let _ = 59 | Scheduler.go () 60 | let () = Printf.printf "Done\n" 61 | -------------------------------------------------------------------------------- /async/test/queue_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let handler var { Message.message = (_, body); _ } = Ivar.fill var body; return () 8 | 9 | let test = 10 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 11 | Connection.connect ~id:(uniq "") ?port "localhost" >>= fun connection -> 12 | Log.info "Connection started"; 13 | Connection.open_channel ~id:(uniq "queue.test") Channel.no_confirm connection >>= fun channel -> 14 | Log.info "Channel opened"; 15 | Queue.declare channel ~auto_delete:true (uniq "queue.test") >>= fun queue -> 16 | Log.info "Queue declared"; 17 | Channel.set_prefetch channel ~count:100 >>= fun () -> 18 | Log.info "Prefetch set"; 19 | Queue.purge channel queue >>= fun () -> 20 | Log.info "Queue purged"; 21 | Queue.get ~no_ack:false channel queue >>= fun m -> 22 | assert (m = None); 23 | Log.info "Queue empty"; 24 | Queue.publish channel queue (Message.make "Test") >>= fun res -> 25 | assert (res = `Ok); 26 | Log.info "Message published"; 27 | Channel.flush channel >>= fun () -> 28 | Log.info "Channel flushed"; 29 | 30 | Queue.get ~no_ack:false channel queue >>= fun m -> 31 | let m = match m with 32 | | None -> failwith "No message" 33 | | Some m -> m 34 | in 35 | Log.info "Message received"; 36 | Message.ack channel m >>= fun () -> 37 | 38 | Exchange.declare channel Exchange.topic_t (uniq "test_exchange") >>= fun exchange -> 39 | Log.info "Exchange declared"; 40 | Queue.bind channel queue exchange (`Topic (uniq "test.#.key")) >>= fun () -> 41 | Log.info "Queue bind declared"; 42 | 43 | Exchange.publish channel exchange ~routing_key:(uniq "test.a.b.c.key") (Message.make "Test") >>= fun res -> 44 | assert (res = `Ok); 45 | Log.info "Message published"; 46 | Queue.get ~no_ack:false channel queue >>= fun m -> 47 | let m = match m with 48 | | None -> failwith "No message" 49 | | Some m -> m 50 | in 51 | Log.info "Message recieved"; 52 | Message.ack channel m >>= fun () -> 53 | Queue.delete channel queue >>= fun () -> 54 | Log.info "Queue deleted"; 55 | Channel.close channel >>= fun () -> 56 | Log.info "Channel closed"; 57 | Connection.close connection >>| fun () -> 58 | Log.info "Connection closed"; 59 | Scheduler.shutdown 0 60 | 61 | let _ = 62 | Scheduler.go () 63 | let () = Printf.printf "Done\n" 64 | -------------------------------------------------------------------------------- /async/test/repeat.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let rec repeat channel queue = 8 | Log.info "rep"; 9 | Queue.publish channel queue (Message.make "Test") >>= function 10 | | `Ok -> 11 | begin 12 | Queue.get ~no_ack:true channel queue >>= function 13 | | Some _ -> 14 | after 1000.0 >>= fun () -> 15 | repeat channel queue 16 | | None -> failwith "No message" 17 | end 18 | | _ -> failwith "Cannot publish" 19 | 20 | let test = 21 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 22 | Connection.connect ~id:(uniq "") ?port "localhost" >>= fun connection -> 23 | Log.info "Connection started"; 24 | Connection.open_channel ~id:(uniq "test.repeat") Channel.no_confirm connection >>= fun channel -> 25 | Queue.declare channel ~auto_delete:true (uniq "test.repeat") >>= fun queue -> 26 | repeat channel queue >>= fun () -> 27 | Connection.close connection >>= fun () -> 28 | Scheduler.shutdown 0 |> return 29 | 30 | let _ = 31 | Scheduler.go () 32 | -------------------------------------------------------------------------------- /async/test/rpc_async_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let req_queue = (uniq "test.rpc") 8 | 9 | let list_init ~f n = 10 | let rec inner = function 11 | | i when i = n -> [] 12 | | i -> f i :: inner (i + 1) 13 | in 14 | inner 0 15 | 16 | let start_server channel = 17 | let handler (content, body) = 18 | let i = int_of_string body in 19 | after (Random.float 100.0) >>= fun () -> 20 | return (content, (string_of_int (i * i))) 21 | in 22 | Queue.declare channel ~auto_delete:true req_queue >>= fun queue -> 23 | Rpc.Server.start ~async:true channel queue handler >>= fun _ -> 24 | return () 25 | 26 | let call rpc_client i = 27 | after (Random.float 100.0) >>= fun () -> 28 | Rpc.Client.call ~ttl:1000 rpc_client Exchange.default ~routing_key:req_queue ~headers:[] (Message.make (string_of_int i)) >>= function 29 | | Some (_, v) -> 30 | assert (int_of_string v = (i*i)); 31 | return () 32 | | None -> failwith "No reply" 33 | 34 | let test = 35 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 36 | Connection.connect ~id:(uniq "") ?port "localhost" >>= fun connection -> 37 | Log.info "Connection started"; 38 | Connection.open_channel ~id:(uniq "test") Channel.no_confirm connection >>= fun channel -> 39 | Log.info "Channel opened"; 40 | spawn (start_server channel); 41 | Log.info "Server started"; 42 | Rpc.Client.init ~id:(uniq "rpc.client.test") connection >>= fun client -> 43 | Log.info "Client initialized"; 44 | list_init 1000 ~f:(call client) |> Deferred.all_unit >>= fun () -> 45 | Log.info "All clients returned"; 46 | Channel.close channel >>= fun () -> 47 | Log.info "Channel closed"; 48 | Connection.close connection >>| fun () -> 49 | Log.info "Connection closed"; 50 | Scheduler.shutdown 0 51 | 52 | let _ = 53 | Scheduler.go () 54 | let () = Printf.printf "Done\n" 55 | -------------------------------------------------------------------------------- /async/test/rpc_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let req_queue = (uniq "test.rpc") 8 | 9 | let start_server channel = 10 | let handler (content, body) = 11 | let i = int_of_string body in 12 | return (content, (string_of_int (i * i))) 13 | in 14 | Queue.declare channel ~auto_delete:true req_queue >>= fun queue -> 15 | Rpc.Server.start channel queue handler >>= fun _ -> 16 | return () 17 | 18 | let rec run_tests rpc_client i = 19 | Rpc.Client.call ~ttl:100 rpc_client Exchange.default ~routing_key:req_queue ~headers:[] (Message.make (string_of_int i)) >>= function 20 | | Some (_, v) -> 21 | assert (int_of_string v = (i*i)); 22 | if (i < 100) then run_tests rpc_client (i+1) 23 | else return () 24 | | None -> failwith "No reply" 25 | 26 | let test = 27 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 28 | Connection.connect ~id:(uniq "") ?port "localhost" >>= fun connection -> 29 | Log.info "Connection started"; 30 | Connection.open_channel ~id:(uniq "test") Channel.no_confirm connection >>= fun channel -> 31 | Log.info "Channel opened"; 32 | spawn (start_server channel); 33 | Rpc.Client.init ~id:(uniq "rpc.client.test") connection >>= fun client -> 34 | run_tests client 0 >>= fun () -> 35 | Channel.close channel >>= fun () -> 36 | Log.info "Channel closed"; 37 | Connection.close connection >>| fun () -> 38 | Log.info "Connection closed"; 39 | Scheduler.shutdown 0 40 | 41 | let _ = 42 | Scheduler.go () 43 | let () = Printf.printf "Done\n" 44 | -------------------------------------------------------------------------------- /async/test/vhost_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let test = 8 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 9 | Deferred.try_with (fun () -> Connection.connect ~id:(uniq "ocaml-amqp-tests") ~virtual_host:"/not_there" ?port "localhost") >>= function 10 | | `Ok _ -> failwith "No exception raised" 11 | | `Error _ -> 12 | Log.info "Got expected exception"; 13 | Scheduler.shutdown 0; 14 | return () 15 | 16 | let _ = 17 | Scheduler.go () 18 | let () = Printf.printf "Done\n" 19 | -------------------------------------------------------------------------------- /async/test/with_confirm_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp 2 | open Thread 3 | 4 | let uniq s = 5 | Printf.sprintf "%s_%d_%s" (Filename.basename Sys.argv.(0)) (Unix.getpid ()) s 6 | 7 | let rec consume_queue channel queue = 8 | Queue.get ~no_ack:true channel queue >>= function 9 | | Some _ -> 10 | consume_queue channel queue >>| ((+) 1) 11 | | None -> return 0 12 | 13 | let rec list_create = function 14 | | 0 -> [] 15 | | n -> n :: list_create (n - 1) 16 | 17 | let test = 18 | let port = Sys.getenv_opt "AMQP_PORT" |> function Some port -> Some (int_of_string port) | None -> None in 19 | Connection.connect ~id:(uniq "integration_test") ?port "localhost" >>= fun connection -> 20 | Log.info "Connection started"; 21 | Connection.open_channel ~id:(uniq "with_confirm.test") Channel.with_confirm connection >>= fun channel -> 22 | Log.info "Channel opened"; 23 | Queue.declare channel ~auto_delete:true (uniq "with_confirm_test") >>= fun queue -> 24 | Queue.purge channel queue >>= fun () -> 25 | 26 | (* Publish 1000 messages in one go, and wait for all of them to complete *) 27 | let messages = 1000 in 28 | list_create messages 29 | |> Deferred.List.iter ~how:`Parallel ~f:(fun i -> Queue.publish channel queue (Message.make (string_of_int i)) >>| ignore) 30 | >>= fun () -> 31 | 32 | consume_queue channel queue >>= fun message_count -> 33 | assert (message_count = messages); 34 | 35 | Queue.delete channel queue >>= fun () -> 36 | 37 | Channel.close channel >>= fun () -> 38 | Connection.close connection >>| fun () -> 39 | Log.info "Connection closed"; 40 | Scheduler.shutdown 0 41 | 42 | let _ = 43 | Scheduler.go () 44 | let () = Printf.printf "Done\n" 45 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name amqp-client) 3 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names rpc_server rpc_client main on_closed multi_receive) 3 | (libraries amqp-client-async) 4 | ) 5 | 6 | (alias 7 | (name examples) 8 | (deps rpc_server.exe rpc_client.exe main.exe on_closed.exe multi_receive.exe) 9 | ) 10 | 11 | (alias 12 | (name runtest) 13 | (deps rpc_server.exe rpc_client.exe) 14 | (package amqp-client-async) 15 | ) 16 | -------------------------------------------------------------------------------- /examples/main.ml: -------------------------------------------------------------------------------- 1 | open Amqp_client_async 2 | open Thread 3 | 4 | (* Stress test message production and reception. *) 5 | 6 | let consume channel queue = 7 | let handler { Message.message = (_content, body); _ } = 8 | let i = int_of_string body in 9 | begin match i with 10 | | i when i mod 1000 = 0 -> 11 | Log.info "%i" i 12 | | 1 -> 13 | Log.info "Done"; 14 | Scheduler.shutdown 0 15 | | _ -> () 16 | end; 17 | in 18 | Queue.consume ~no_ack:true ~id:"test" channel queue >>= fun (_consumer, reader) -> 19 | spawn (Pipe.iter_without_pushback reader ~f:(fun m -> handler m)); 20 | return () 21 | 22 | let rec produce channel queue = function 23 | | 0 -> Channel.flush channel; 24 | | n -> 25 | Queue.publish channel queue (Message.make (string_of_int n)) >>= fun res -> 26 | assert (res = `Ok); 27 | produce channel queue (n-1) 28 | 29 | let _ = 30 | let _ = 31 | Connection.connect ~id:"fugmann" "localhost" >>= fun connection -> 32 | Log.info "Connection started"; 33 | Connection.open_channel Channel.no_confirm ~id:"test" connection >>= fun channel -> 34 | Log.info "Channel opened"; 35 | Queue.declare channel ~arguments:[] ~auto_delete:true "test.main" >>= fun queue -> 36 | 37 | spawn (consume channel queue); 38 | produce channel queue 50000 >>= fun () -> 39 | Log.info "Done producing"; 40 | return (); 41 | in 42 | Scheduler.go () 43 | -------------------------------------------------------------------------------- /examples/multi_receive.ml: -------------------------------------------------------------------------------- 1 | open Amqp_client_async 2 | open Thread 3 | 4 | (** Send an rpc request to queue a. 5 | We then read from queue a, post on queue b, read from b and then reply to 6 | the rpc request. 7 | 8 | We provide both a synchronous way to doing this and a parallel way, 9 | where queues are not consumed 'in order'. 10 | *) 11 | 12 | let handler_a queue_b channel message : unit Deferred.t = 13 | Queue.publish channel queue_b message.Message.message >>= fun `Ok -> 14 | return () 15 | 16 | (* Reply to the message *) 17 | let handler_b channel message = 18 | let content, data = message.Message.message in 19 | let reply_text = "Echo: " ^ data in 20 | let reply_message = 21 | Message.make ?correlation_id:content.correlation_id reply_text 22 | in 23 | match content with 24 | | { Spec.Basic.Content.reply_to = Some reply_to; _ } -> 25 | Exchange.publish channel Exchange.default ~routing_key:reply_to reply_message >>= fun `Ok -> 26 | return () 27 | | _ -> Printf.printf "No reply destination for message: %s" data; 28 | return () 29 | 30 | let consumer_cancelled () = 31 | Log.info "Consumer cancelled" 32 | 33 | let _ = 34 | (* Setup queue a *) 35 | Connection.connect ~id:"multi_receive_example" "localhost" >>= fun connection -> 36 | Log.info "Connection started"; 37 | Connection.open_channel Channel.no_confirm ~id:"test" connection >>= fun channel -> 38 | Log.info "Channel opened"; 39 | Queue.declare channel ~auto_delete:true "multi_receive_example.a" >>= fun queue_a -> 40 | Queue.declare channel ~auto_delete:true "multi_receive_example.b" >>= fun queue_b -> 41 | 42 | (* Setup a pipe for consuming messages from queue a. We do not ack 43 | the messages and require exclusive access to the queue, i.e. no 44 | other consumers must be present for the queue *) 45 | 46 | Queue.consume ~id:"relay_a" ~no_ack:true ~exclusive:true channel queue_a >>= fun (_consumer_a, reader_a) -> 47 | Queue.consume ~id:"reply_b" ~on_cancel:consumer_cancelled ~no_ack:true ~exclusive:true channel queue_b >>= fun (_consumer_b, reader_b) -> 48 | 49 | 50 | spawn (Pipe.iter reader_a ~f:(handler_a queue_b channel)); 51 | spawn (Pipe.iter reader_b ~f:(handler_b channel)); 52 | 53 | (* Now lets start query *) 54 | Rpc.Client.init ~id:"req" connection >>= fun rpc -> 55 | let rec request i = 56 | let message = Message.make (string_of_int i) in 57 | Rpc.Client.call rpc ~headers:[] ~ttl:5000 ~routing_key:(Queue.name queue_a) Exchange.default message >>= function 58 | | Some (_, data) -> 59 | Printf.printf "Reply: %s\n%!" data; 60 | request (i + 1) 61 | | None -> 62 | request (i + 1) 63 | in 64 | request 0 >>= fun () -> 65 | return () 66 | 67 | let () = 68 | Scheduler.go () 69 | -------------------------------------------------------------------------------- /examples/on_closed.ml: -------------------------------------------------------------------------------- 1 | open Amqp_client_async 2 | open Thread 3 | 4 | (* Demonstrate how on_close can be used *) 5 | 6 | let _ = 7 | let _ = 8 | Connection.connect ~id:"fugmann" ~heartbeat:10 "localhost" >>= fun connection -> 9 | spawn (Connection.on_closed connection >>= fun () -> 10 | Log.info "Connection closed"; 11 | return ()); 12 | 13 | Log.info "Connection started."; 14 | Connection.open_channel Channel.no_confirm ~id:"test" connection >>= fun channel -> 15 | Log.info "Channel opened"; 16 | spawn (Channel.on_closed channel >>= fun () -> 17 | Log.info "Channel closed - Handler"; 18 | return ()); 19 | 20 | spawn (Connection.on_closed connection >>= fun () -> 21 | Log.info "Connection closed - Handler"; 22 | return ()); 23 | Unix.sleep 300; 24 | (* 25 | Connection.close connection >>= fun () -> 26 | Log.info "Connection closed "; 27 | *) 28 | Log.info "Done"; 29 | return (); 30 | in 31 | Scheduler.go () 32 | -------------------------------------------------------------------------------- /examples/rpc_client.ml: -------------------------------------------------------------------------------- 1 | open Async 2 | open Amqp_client_async 3 | 4 | let rec request t i = 5 | let req = Printf.sprintf "Echo: %d" i in 6 | Rpc.Client.call ~ttl:1000 t Exchange.default ~routing_key:"rpc.server.echo_reply" ~headers:[] (Message.make (string_of_int i)) >>= fun res -> 7 | begin 8 | match res with 9 | | Some (_, rep) -> Log.Global.info "%s == %s" req rep; 10 | | None -> Log.Global.info "%s: no reply" req; 11 | end; 12 | request t (i+1) 13 | 14 | let test = 15 | Connection.connect ~id:"fugmann" "localhost" >>= fun connection -> 16 | Log.Global.info "Connection started"; 17 | (* 18 | Connection.open_channel ~id:"rpc_test" Channel.no_confirm connection >>= fun channel -> 19 | Queue.declare channel ~arguments:[Rpc.Server.queue_argument] "rpc.server.echo_reply" >>= fun _queue -> 20 | *) 21 | Rpc.Client.init ~id:"Test" connection >>= fun client -> 22 | request client 1 23 | 24 | let _ = 25 | Scheduler.go () 26 | -------------------------------------------------------------------------------- /examples/rpc_server.ml: -------------------------------------------------------------------------------- 1 | open Async 2 | open Amqp_client_async 3 | 4 | let handler (h, s) = 5 | Log.Global.info "Recieved request: %s" s; 6 | return (h, s) 7 | 8 | let start = 9 | Connection.connect ~id:"fugmann" "localhost" >>= fun connection -> 10 | Log.Global.info "Connection started"; 11 | Connection.open_channel ~id:"test" Channel.no_confirm connection >>= fun channel -> 12 | Log.Global.info "Channel opened"; 13 | Queue.declare channel ~arguments:[Rpc.Server.queue_argument] "rpc.server.echo_reply" >>= fun queue -> 14 | Rpc.Server.start channel queue handler >>= fun _server -> 15 | Log.Global.info "Listening for requsts"; 16 | 17 | return () 18 | 19 | let _ = 20 | Scheduler.go () 21 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name amqp_client_lib) 3 | (public_name amqp-client.lib) 4 | (synopsis "Layer providing access to pervasives modules + helper modules") 5 | ) 6 | -------------------------------------------------------------------------------- /lib/io.ml: -------------------------------------------------------------------------------- 1 | (** Internal *) 2 | 3 | module Input = struct 4 | type t = { buf: String.t; mutable offset: int } 5 | let init ?(offset=0) buf = { buf; offset } 6 | let read f n t = 7 | let r = f t.buf t.offset in 8 | t.offset <- t.offset + n; 9 | r 10 | 11 | let string t len = 12 | let s = String.sub t.buf t.offset len in 13 | t.offset <- t.offset + len; 14 | s 15 | 16 | let octet = read String.get_uint8 1 17 | let short = read String.get_uint16_be 2 18 | let long t = read String.get_int32_be 4 t |> Int32.to_int 19 | let longlong t = read String.get_int64_be 8 t |> Int64.to_int 20 | let float = read (fun s l -> String.get_int32_be s l |> Int32.float_of_bits) 2 21 | let double = read (fun s l -> String.get_int64_be s l |> Int64.float_of_bits) 8 22 | 23 | let length t = String.length t.buf - t.offset 24 | let has_data t = length t > 0 25 | let offset t = t.offset 26 | 27 | let copy t ~dst_pos ~len (dst:Bytes.t) = 28 | Bytes.blit_string t.buf t.offset dst dst_pos len; 29 | t.offset <- t.offset + len 30 | end 31 | 32 | module Output = struct 33 | type t = { mutable buf: Bytes.t; mutable offset: int; apply: bool } 34 | let create len = { buf = Bytes.create len; offset = 0; apply = true } 35 | 36 | (* The sizer dont actually do anything, but record space needed *) 37 | let sizer () = { buf = Bytes.create 0; offset = 0; apply = false } 38 | let write f n t v = 39 | if t.apply then 40 | f t.buf t.offset v; 41 | t.offset <- t.offset + n 42 | let get t : Bytes.t = t.buf 43 | let string t ?(src_pos=0) ?len src = 44 | let len = match len with 45 | | Some l -> l 46 | | None -> String.length src 47 | in 48 | if (t.apply) then 49 | Bytes.blit_string src src_pos t.buf t.offset len; 50 | t.offset <- t.offset + len 51 | 52 | let octet = write Bytes.set_int8 1 53 | let short = write Bytes.set_int16_be 2 54 | let short_ref t = 55 | let offset = t.offset in 56 | t.offset <- t.offset + 2; 57 | fun v -> 58 | if (t.apply) then Bytes.set_int16_be t.buf offset v 59 | 60 | let long = write (fun t pos v -> Bytes.set_int32_be t pos (Int32.of_int v)) 4 61 | let longlong = write (fun t pos v -> Bytes.set_int64_be t pos (Int64.of_int v)) 8 62 | let float = write (fun t pos v -> Bytes.set_int32_be t pos (Int32.bits_of_float v)) 4 63 | let double = write (fun t pos v -> Bytes.set_int64_be t pos (Int64.bits_of_float v)) 8 64 | let size_ref t = 65 | let offset = t.offset in 66 | t.offset <- offset + 4; 67 | fun () -> 68 | if t.apply then Bytes.set_int32_be t.buf offset (Int32.of_int (t.offset - (offset + 4))) 69 | 70 | let size t = t.offset 71 | end 72 | -------------------------------------------------------------------------------- /lib/mlist.ml: -------------------------------------------------------------------------------- 1 | (**/**) 2 | type 'a elem = { content: 'a; mutable next: 'a cell } 3 | and 'a cell = Nil 4 | | Cons of 'a elem 5 | 6 | type 'a t = { mutable first: 'a elem; 7 | mutable last: 'a elem } 8 | 9 | (** create an empty list *) 10 | let create () = 11 | let sentinal = { content = Obj.magic (); next = Nil } in 12 | { first = sentinal; 13 | last = sentinal; } 14 | 15 | (** Returns the first element that satisfies [pred] and removes it from the list. O(n) *) 16 | let take ~pred t = 17 | let rec inner = function 18 | | Nil -> None 19 | | Cons ({ content = _; next = Cons { content; next} } as cell) when pred content -> 20 | cell.next <- next; 21 | begin match next with Nil -> t.last <- cell | _ -> () end; 22 | Some content; 23 | | Cons { content = _; next } -> 24 | inner next 25 | in 26 | inner (Cons t.first) 27 | 28 | (** Peek at the first element without removing it from the list. O(1) *) 29 | let peek t = 30 | match t.first.next with 31 | | Nil -> None 32 | | Cons { content; _ } -> Some content 33 | 34 | (** Pop the first element from the list. O(1) *) 35 | let pop t = 36 | match t.first.next with 37 | | Nil -> None 38 | | Cons { content; next } -> 39 | t.first.next <- next; 40 | if (next = Nil) then t.last <- t.first else (); 41 | Some content 42 | 43 | (** Removes and returns elements while statisfying [pred]. O(m), where m is number of elements returned *) 44 | let take_while ~pred t = 45 | let rec inner = function 46 | | Nil -> [] 47 | | Cons ({content = _; next = Cons { content; next } } as cell) when pred content -> 48 | cell.next <- next; 49 | if (next = Nil) then t.last <- cell else (); 50 | content :: inner (Cons cell); 51 | | Cons _ -> [] 52 | in 53 | inner (Cons t.first) 54 | 55 | (** Prepends an element to the list *) 56 | let prepend t v = 57 | let e = { content=v; next = t.first.next } in 58 | t.first.next <- Cons e; 59 | if (e.next = Nil) then t.last <- e else () 60 | 61 | (** Appends a element to the list *) 62 | let append t v = 63 | let e = { content=v; next = t.last.next } in 64 | t.last.next <- Cons e; 65 | t.last <- e 66 | 67 | (**/**) 68 | -------------------------------------------------------------------------------- /lib/ocaml_lib.ml: -------------------------------------------------------------------------------- 1 | (** Alias Global module Queue to local module Queue 2 | to make is accessable though __MODULE__.Queue *) 3 | module Queue = Queue 4 | -------------------------------------------------------------------------------- /lib/option.ml: -------------------------------------------------------------------------------- 1 | (**/**) 2 | type 'a t = 'a option 3 | 4 | let get ~default = function 5 | | None -> default 6 | | Some v -> v 7 | 8 | let get_exn ?(exn=Invalid_argument "None") = function 9 | | None -> raise exn 10 | | Some v -> v 11 | 12 | let map_default ~default ~f = function 13 | | None -> default 14 | | Some v -> f v 15 | 16 | let map ~f = function 17 | | None -> None 18 | | Some v -> Some (f v) 19 | 20 | let iter ~f = function 21 | | None -> () 22 | | Some v -> f v 23 | (**/**) 24 | -------------------------------------------------------------------------------- /lib/protocol.ml: -------------------------------------------------------------------------------- 1 | (** Internal *) 2 | open Types 3 | open Io 4 | 5 | type _ elem = 6 | | Bit: bool elem 7 | | Octet: int elem 8 | | Short: int elem 9 | | Long: int elem 10 | | Longlong: int elem 11 | | Shortstr: string elem 12 | | Longstr: string elem 13 | | Float: float elem 14 | | Double: float elem 15 | | Decimal: decimal elem 16 | | Table: table elem 17 | | Timestamp: timestamp elem 18 | | Array: array elem 19 | | Unit: unit elem 20 | 21 | let tap a b = a b; b 22 | 23 | let reserved_value: type a. a elem -> a = function 24 | | Bit -> false 25 | | Octet -> 0 26 | | Short -> 0 27 | | Long -> 0 28 | | Longlong -> 0 29 | | Shortstr -> "" 30 | | Longstr -> "" 31 | | Float -> 0.0 32 | | Double -> 0.0 33 | | Decimal -> { digits = 0; value = 0 } 34 | | Table -> [] 35 | | Timestamp -> 0 36 | | Array -> [] 37 | | Unit -> () 38 | 39 | let rec decode: type a. a elem -> Input.t -> a = fun elem t -> 40 | match elem with 41 | | Bit -> Input.octet t = 1 42 | | Octet -> Input.octet t 43 | | Short -> Input.short t 44 | | Long -> Input.long t 45 | | Longlong -> Input.longlong t 46 | | Shortstr -> 47 | let len = decode Octet t in 48 | Input.string t len 49 | | Longstr -> 50 | let len = decode Long t in 51 | Input.string t len 52 | | Table -> 53 | let size = decode Long t in 54 | let offset = Input.offset t in 55 | let rec read_table_value t = 56 | match Input.offset t < (offset + size) with 57 | | true -> 58 | let key = decode Shortstr t in 59 | let value = decode_field t in 60 | (key, value) :: read_table_value t 61 | | false -> [] 62 | in 63 | read_table_value t 64 | | Timestamp -> decode Longlong t 65 | | Float -> Input.float t 66 | | Double -> Input.double t 67 | | Decimal -> 68 | let digits = decode Octet t in 69 | let value = decode Long t in 70 | { digits; value } 71 | | Array -> 72 | let size = decode Long t in 73 | let offset = Input.offset t in 74 | let rec read_array t = 75 | match Input.offset t < (offset + size) with 76 | | true -> 77 | let v = decode_field t in 78 | v :: read_array t 79 | | false -> [] 80 | in 81 | read_array t 82 | | Unit -> () 83 | and decode_field t = 84 | match Input.octet t |> Char.chr with 85 | | 't' -> VBoolean (decode Bit t) 86 | | 'b' | 'B' -> VShortshort (decode Octet t) 87 | | 'u' | 'U' -> VShort (decode Short t) 88 | | 'i' | 'I' -> VLong (decode Long t) 89 | | 'l' | 'L' -> VLonglong (decode Longlong t) 90 | | 'f' -> VFloat (decode Float t) 91 | | 'd' -> VDouble (decode Double t) 92 | | 'D' -> VDecimal (decode Decimal t) 93 | | 's' -> VShortstr (decode Shortstr t) 94 | | 'S' -> VLongstr (decode Longstr t) 95 | | 'A' -> VArray (decode Array t) 96 | | 'T' -> VTimestamp (decode Timestamp t) 97 | | 'F' -> VTable (decode Table t) 98 | | 'V' -> VUnit (decode Unit t) 99 | | _ -> failwith "Uknown table value" 100 | 101 | 102 | let rec encode: type a. a elem -> Output.t -> a -> unit = function 103 | | Bit -> fun t x -> Output.octet t (if x then 1 else 0) 104 | | Octet -> Output.octet 105 | | Short -> Output.short 106 | | Long -> Output.long 107 | | Longlong -> Output.longlong 108 | | Shortstr -> 109 | let enc = encode Octet in 110 | fun t x -> 111 | enc t (String.length x); 112 | Output.string t x 113 | | Longstr -> 114 | let enc = encode Long in 115 | fun t x -> 116 | enc t (String.length x); 117 | Output.string t x 118 | | Table -> fun t x -> 119 | let size_ref = Output.size_ref t in 120 | List.iter (fun (k, v) -> 121 | encode Shortstr t k; 122 | encode_field t v 123 | ) x; 124 | size_ref () 125 | | Timestamp -> 126 | encode Longlong 127 | | Float -> Output.float 128 | | Double -> Output.double 129 | | Decimal -> 130 | let denc = encode Octet in 131 | let venc = encode Long in 132 | fun t { digits; value } -> 133 | denc t digits; 134 | venc t value; 135 | | Array -> fun t x -> 136 | let size_ref = Output.size_ref t in 137 | List.iter (encode_field t) x; 138 | size_ref () 139 | | Unit -> fun _ _ -> () 140 | and encode_field t = function 141 | | VBoolean b -> 142 | encode Octet t (Char.code 't'); 143 | encode Bit t b 144 | | VShortshort i -> 145 | encode Octet t (Char.code 'b'); 146 | encode Octet t i 147 | | VShort i -> 148 | encode Octet t (Char.code 'u'); 149 | encode Short t i 150 | | VLong i -> 151 | encode Octet t (Char.code 'i'); 152 | encode Long t i 153 | | VLonglong i -> 154 | encode Octet t (Char.code 'l'); 155 | encode Longlong t i 156 | | VShortstr s -> 157 | encode Octet t (Char.code 's'); 158 | encode Shortstr t s 159 | | VLongstr v -> 160 | encode Octet t (Char.code 'S'); 161 | encode Longstr t v 162 | | VFloat v -> 163 | encode Octet t (Char.code 'f'); 164 | encode Float t v 165 | | VDouble v -> 166 | encode Octet t (Char.code 'd'); 167 | encode Double t v 168 | | VDecimal v -> 169 | encode Octet t (Char.code 'D'); 170 | encode Decimal t v 171 | | VTable v -> 172 | encode Octet t (Char.code 'F'); 173 | encode Table t v 174 | | VArray a -> 175 | encode Octet t (Char.code 'A'); 176 | encode Array t a 177 | | VTimestamp v -> 178 | encode Octet t (Char.code 'T'); 179 | encode Timestamp t v 180 | | VUnit () -> 181 | encode Octet t (Char.code 'V'); 182 | encode Unit t () 183 | 184 | let elem_to_string: type a. a elem -> string = function 185 | | Bit -> "Bit" 186 | | Octet -> "Octet" 187 | | Short -> "Short" 188 | | Long -> "Long" 189 | | Longlong -> "Longlong" 190 | | Shortstr -> "Shortstr" 191 | | Longstr -> "Longstr" 192 | | Table -> "Table" 193 | | Timestamp -> "Timestamp" 194 | | _ -> "Unknown" 195 | 196 | module Spec = struct 197 | type (_, _) spec = 198 | | [] : ('a, 'a) spec 199 | | (::) : 'a elem * ('b, 'c) spec -> (('a -> 'b), 'c) spec 200 | 201 | let rec read: type b c. (b, c) spec -> b -> Input.t -> c = function 202 | | (Bit :: _) as spec -> 203 | let reader = read_bits 8 spec 204 | and decoder = decode Octet in 205 | fun b t -> reader b (decoder t) t 206 | | head :: tail -> 207 | let reader = read tail 208 | and decoder = decode head in 209 | fun b t -> reader (b (decoder t)) t 210 | | [] -> 211 | fun b _t -> b 212 | and read_bits: type b c. int -> (b, c) spec -> b -> int -> Input.t -> c = fun c -> function 213 | | Bit :: tail when c > 0 -> 214 | let reader = read_bits (c - 1) tail in 215 | fun b v t -> reader (b (v mod 2 = 1)) (v/2) t 216 | | spec -> 217 | let reader = read spec in 218 | fun b _v t -> reader b t 219 | 220 | let rec write: type b. (b, Output.t) spec -> Output.t -> b = function 221 | | (Bit :: _) as spec -> 222 | write_bits 8 spec 0 223 | | spec :: tail -> 224 | let encoder = encode spec 225 | and writer = write tail in 226 | fun t x -> encoder t x; writer t 227 | | [] -> fun a -> a 228 | and write_bits: type b. int -> (b, Output.t) spec -> int -> Output.t -> b = fun c -> function 229 | | Bit :: tail when c > 0 -> 230 | let writer = write_bits (c-1) tail in 231 | fun v t x -> 232 | let v = match x with 233 | | false -> v 234 | | true -> v lor (1 lsl (8-c)) 235 | in 236 | writer v t 237 | | spec -> 238 | let encoder = encode Octet 239 | and writer = write spec in 240 | fun v t -> encoder t v; writer t 241 | 242 | let rec to_string: type a b. (a, b) spec -> string = function 243 | | x :: xs -> elem_to_string x ^ " :: " ^ to_string xs 244 | | [] -> "[]" 245 | end 246 | 247 | module Content = struct 248 | type (_, _) spec = 249 | | [] : ('a, 'a) spec 250 | | (::) : 'a elem * ('b, 'c) spec -> (('a option -> 'b), 'c) spec 251 | 252 | let rec length: type a b. (a, b) spec -> int = function 253 | | _ :: tail -> 1 + length tail 254 | | [] -> 0 255 | 256 | let rec read: type b c. (b, c) spec -> b -> int -> Input.t -> c = function 257 | | Bit :: tail -> 258 | let reader = read tail in 259 | fun b flags t -> 260 | let value = if (flags land 1 = 1) then Some true else None in 261 | reader (b value) (flags lsr 1) t 262 | | head :: tail -> 263 | let reader = read tail 264 | and decoder = decode head in 265 | fun b flags t -> 266 | let value = 267 | if flags land 1 = 1 then 268 | Some (decoder t) 269 | else 270 | None 271 | in 272 | reader (b value) (flags lsr 1) t 273 | | [] -> 274 | fun b _flags _t -> b 275 | 276 | let rec write: type b. (b, Output.t) spec -> int ref -> Output.t -> b = function 277 | | Bit :: tail -> 278 | let writer = write tail in 279 | fun flags t x -> 280 | flags := !flags * 2; 281 | if x = Some true then incr flags; 282 | writer flags t 283 | | spec :: tail -> 284 | let encoder = encode spec 285 | and writer = write tail in 286 | fun flags t x -> 287 | flags := !flags * 2; 288 | begin 289 | match x with 290 | | Some x -> 291 | encoder t x; 292 | incr flags 293 | | None -> () 294 | end; 295 | writer flags t 296 | | [] -> fun _flags _x -> _x 297 | end 298 | -------------------------------------------------------------------------------- /lib/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name mlist_test) 3 | (modules mlist_test) 4 | (libraries amqp-client.lib) 5 | ) 6 | 7 | (rule 8 | (alias runtest) 9 | (deps mlist_test.exe) 10 | (action (run ./mlist_test.exe)) 11 | ) 12 | -------------------------------------------------------------------------------- /lib/test/mlist_test.ml: -------------------------------------------------------------------------------- 1 | open Amqp_client_lib 2 | let test_empty = 3 | let t = Mlist.create () in 4 | assert ((Mlist.take ~pred:(fun _ -> true) t) = None); 5 | () 6 | 7 | let test_take = 8 | let t = Mlist.create () in 9 | Mlist.append t 1; 10 | assert ((Mlist.take ~pred:(fun _ -> true) t) = (Some 1)); 11 | Mlist.append t 1; 12 | Mlist.append t 2; 13 | Mlist.append t 3; 14 | Mlist.append t 4; 15 | assert ((Mlist.take ~pred:(fun _ -> true) t) = (Some 1)); 16 | assert ((Mlist.take ~pred:(fun _ -> true) t) = (Some 2)); 17 | assert ((Mlist.take ~pred:(fun _ -> true) t) = (Some 3)); 18 | assert ((Mlist.take ~pred:(fun _ -> true) t) = (Some 4)); 19 | assert ((Mlist.take ~pred:(fun _ -> true) t) = None); 20 | () 21 | 22 | let test_while = 23 | let t = Mlist.create () in 24 | Mlist.append t 1; 25 | Mlist.append t 2; 26 | Mlist.append t 3; 27 | Mlist.append t 4; 28 | 29 | assert (Mlist.take_while ~pred:(fun n -> n < 4) t = [1;2;3]); 30 | () 31 | -------------------------------------------------------------------------------- /lib/thread.ml: -------------------------------------------------------------------------------- 1 | module type T = sig 2 | module Deferred : sig 3 | type 'a t 4 | 5 | val all_unit : unit t list -> unit t 6 | val try_with : (unit -> 'a t) -> [> `Error of exn | `Ok of 'a ] t 7 | module List : sig 8 | val init : ?how:[`Sequential | `Parallel] -> f:(int -> 'a t) -> int -> 'a list t 9 | val iter : ?how:[`Sequential | `Parallel] -> f:('a -> unit t) -> 'a list -> unit t 10 | end 11 | end 12 | val ( >>= ) : 'a Deferred.t -> ('a -> 'b Deferred.t) -> 'b Deferred.t 13 | val ( >>| ) : 'a Deferred.t -> ('a -> 'b) -> 'b Deferred.t 14 | val return : 'a -> 'a Deferred.t 15 | val after : float -> unit Deferred.t 16 | val spawn : ?exn_handler:(exn -> unit Deferred.t) -> unit Deferred.t -> unit 17 | val with_timeout : int -> 'a Deferred.t -> [ `Result of 'a | `Timeout ] Deferred.t 18 | 19 | module Ivar : sig 20 | type 'a t 21 | val create : unit -> 'a t 22 | val create_full : 'a -> 'a t 23 | val fill : 'a t -> 'a -> unit 24 | val read : 'a t -> 'a Deferred.t 25 | val is_full : 'a t -> bool 26 | val fill_if_empty : 'a t -> 'a -> unit 27 | end 28 | 29 | module Reader : sig 30 | type t 31 | val close : t -> unit Deferred.t 32 | val read : t -> bytes -> [ `Eof of int | `Ok ] Deferred.t 33 | end 34 | module Writer : sig 35 | type t 36 | val write : t -> string -> unit 37 | val close : t -> unit Deferred.t 38 | val flush : t -> unit Deferred.t 39 | end 40 | 41 | module Tcp : sig 42 | val connect : exn_handler:(exn -> unit Deferred.t) -> ?nodelay:unit -> string -> int -> 43 | (Reader.t * Writer.t) Deferred.t 44 | end 45 | 46 | module Log : sig 47 | val debug : ('a, unit, string, unit) format4 -> 'a 48 | val info : ('a, unit, string, unit) format4 -> 'a 49 | val error : ('a, unit, string, unit) format4 -> 'a 50 | end 51 | module Pipe : sig 52 | module Writer : sig type 'a t end 53 | module Reader : sig type 'a t end 54 | 55 | val create : unit -> 'a Reader.t * 'a Writer.t 56 | val set_size_budget : 'a Writer.t -> int -> unit 57 | val flush : 'a Writer.t -> unit Deferred.t 58 | val interleave_pipe : 'a Reader.t Reader.t -> 'a Reader.t 59 | val write : 'a Writer.t -> 'a -> unit Deferred.t 60 | val write_without_pushback : 'a Writer.t -> 'a -> unit 61 | val transfer_in : from:'a Queue.t -> 'a Writer.t -> unit Deferred.t 62 | val close : 'a Writer.t -> unit Deferred.t 63 | val read : 'a Reader.t -> [ `Eof | `Ok of 'a ] Deferred.t 64 | val iter : 'a Reader.t -> f:('a -> unit Deferred.t) -> unit Deferred.t 65 | val iter_without_pushback : 'a Reader.t -> f:('a -> unit) -> unit Deferred.t 66 | val close_without_pushback : 'a Writer.t -> unit 67 | end 68 | 69 | module Scheduler : sig 70 | val go : unit -> unit 71 | val shutdown : int -> unit 72 | end 73 | end 74 | -------------------------------------------------------------------------------- /lib/types.ml: -------------------------------------------------------------------------------- 1 | (** Basic Amqp types *) 2 | exception Connection_closed 3 | exception Channel_closed of int 4 | exception Channel_not_found of int 5 | exception Unknown_frame_type of int 6 | exception No_handler_found 7 | exception Consumer_cancelled of string 8 | exception Busy 9 | 10 | type class_id = int 11 | type method_id = int 12 | type message_id = class_id * method_id 13 | 14 | type bit = bool 15 | and octet = int 16 | and short = int 17 | and long = int 18 | and longlong = int 19 | and shortstr = string 20 | and longstr = string 21 | and timestamp = int 22 | and decimal = { digits : int; value: int } 23 | and table = (string * value) list 24 | and array = value list 25 | and value = 26 | | VBoolean of bool 27 | | VShortshort of int 28 | | VShort of int 29 | | VLong of int 30 | | VLonglong of int 31 | | VShortstr of string (* Not accepted by rabbitmq *) 32 | | VLongstr of string 33 | | VFloat of float 34 | | VDouble of float 35 | | VDecimal of decimal 36 | | VTable of table 37 | | VArray of value list 38 | | VTimestamp of int 39 | | VUnit of unit 40 | 41 | type header = string * value 42 | 43 | let rec print_type indent t = 44 | let open Printf in 45 | match t with 46 | | VTable t -> 47 | let indent' = indent ^ " " in 48 | printf "[\n"; 49 | List.iter (fun (k, v) -> printf "%s%s: " indent' k; print_type (indent') v; printf "\n") t; 50 | printf "%s]" indent; 51 | | VBoolean v -> printf "%b" v 52 | | VShortshort v 53 | | VShort v 54 | | VLong v 55 | | VTimestamp v 56 | | VLonglong v -> printf "%d" v 57 | | VShortstr v 58 | | VLongstr v -> printf "%s" v 59 | | VFloat v 60 | | VDouble v-> printf "%f" v 61 | | VDecimal v -> printf "%f" (float v.value /. float v.digits) 62 | | VArray a -> 63 | let indent' = indent ^ " " in 64 | printf "[\n"; 65 | List.iter (fun v -> printf "%s" indent'; print_type (indent') v; printf "\n") a; 66 | printf "%s]" indent; 67 | | VUnit _ -> printf "\n" 68 | -------------------------------------------------------------------------------- /license.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Anders Fugmann 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the developer nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /link/async_link.ml: -------------------------------------------------------------------------------- 1 | open Async 2 | open Amqp_client_async 3 | 4 | let host = "localhost" 5 | 6 | let run () = 7 | Amqp.Connection.connect ~id:"MyConnection" host >>= fun connection -> 8 | Amqp.Connection.open_channel ~id:"MyChannel" Amqp.Channel.no_confirm connection >>= fun channel -> 9 | Amqp.Queue.declare channel "MyQueue" >>= fun queue -> 10 | Amqp.Queue.publish channel queue (Amqp.Message.make "My Message Payload") >>= function `Ok -> 11 | Amqp.Channel.close channel >>= fun () -> 12 | Amqp.Connection.close connection >>= fun () -> 13 | Shutdown.shutdown 0; return () 14 | 15 | let _ = 16 | don't_wait_for (run ()); 17 | Scheduler.go () 18 | -------------------------------------------------------------------------------- /link/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name async_link) 3 | (modules Async_link) 4 | (libraries amqp-client-async) 5 | ) 6 | 7 | (executable 8 | (name lwt_link) 9 | (modules Lwt_link) 10 | (libraries amqp-client-lwt) 11 | ) 12 | 13 | (alias 14 | (name runtest) 15 | (deps async_link.exe) 16 | (package amqp-client-async) 17 | ) 18 | 19 | (alias 20 | (name runtest) 21 | (deps lwt_link.exe) 22 | (package amqp-client-lwt) 23 | ) 24 | -------------------------------------------------------------------------------- /link/lwt_link.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Amqp_client_lwt 3 | 4 | let host = "localhost" 5 | 6 | let run () = 7 | Amqp.Connection.connect ~id:"MyConnection" host >>= fun connection -> 8 | Amqp.Connection.open_channel ~id:"MyChannel" Amqp.Channel.no_confirm connection >>= fun channel -> 9 | Amqp.Queue.declare channel "MyQueue" >>= fun queue -> 10 | Amqp.Queue.publish channel queue (Amqp.Message.make "My Message Payload") >>= function `Ok -> 11 | Amqp.Channel.close channel >>= fun () -> 12 | Amqp.Connection.close connection >>= fun () -> 13 | return () 14 | 15 | let _ = 16 | Lwt_main.run (run ()) 17 | -------------------------------------------------------------------------------- /lwt/src/dune: -------------------------------------------------------------------------------- 1 | ; Copy autogenerated files 2 | (rule (copy ../../spec/spec.ml spec.ml)) 3 | (rule (copy ../../spec/constants.ml constants.ml)) 4 | 5 | ; Copy sources from async 6 | (rule (copy# ../../async/src/amqp.ml amqp.ml)) 7 | (rule (copy# ../../async/src/channel.ml channel.ml)) 8 | (rule (copy# ../../async/src/connection.ml connection.ml)) 9 | (rule (copy# ../../async/src/exchange.ml exchange.ml)) 10 | (rule (copy# ../../async/src/framing.ml framing.ml)) 11 | (rule (copy# ../../async/src/message.ml message.ml)) 12 | (rule (copy# ../../async/src/protocol_helpers.ml protocol_helpers.ml)) 13 | (rule (copy# ../../async/src/queue.ml queue.ml)) 14 | (rule (copy# ../../async/src/rpc.ml rpc.ml)) 15 | 16 | (rule (copy# ../../async/src/channel.mli channel.mli)) 17 | (rule (copy# ../../async/src/connection.mli connection.mli)) 18 | (rule (copy# ../../async/src/exchange.mli exchange.mli)) 19 | (rule (copy# ../../async/src/framing.mli framing.mli)) 20 | (rule (copy# ../../async/src/message.mli message.mli)) 21 | (rule (copy# ../../async/src/queue.mli queue.mli)) 22 | (rule (copy# ../../async/src/rpc.mli rpc.mli)) 23 | 24 | (library 25 | (name amqp_client_lwt) 26 | (public_name amqp-client-lwt) 27 | (synopsis "Amqp client using lwt for concurrency") 28 | (libraries lwt lwt_log lwt.unix amqp-client.lib uri) 29 | ) 30 | -------------------------------------------------------------------------------- /lwt/src/thread.ml: -------------------------------------------------------------------------------- 1 | open Amqp_client_lib 2 | let (>>=) = Lwt.(>>=) 3 | let (>>|) = Lwt.(>|=) 4 | let return = Lwt.return 5 | let after ms = Lwt_unix.sleep (ms /. 1000.0) 6 | let spawn ?exn_handler t = Lwt.async (fun () -> 7 | match exn_handler with 8 | | Some handler -> Lwt.catch (fun () -> t) handler 9 | | None -> t 10 | ) 11 | 12 | let with_timeout milliseconds deferred = 13 | Lwt.pick [ 14 | Lwt_unix.sleep (float_of_int milliseconds /. 1000.) >>| (fun () -> `Timeout); 15 | deferred >>| (fun success -> `Result success) 16 | ] 17 | 18 | (* Replace with simpler Lwt.wait *) 19 | module Ivar = struct 20 | type 'a t = { t: 'a Lwt.t; 21 | u: 'a Lwt.u; 22 | } 23 | let create () = 24 | let (t,u) = Lwt.wait () in 25 | { t; u } 26 | 27 | let create_full v = 28 | let t = create () in 29 | Lwt.wakeup_later t.u v; 30 | t 31 | 32 | let is_full t = 33 | Lwt.is_sleeping t.t |> not 34 | 35 | let fill t v = 36 | match is_full t with 37 | | false -> 38 | Lwt.wakeup_later t.u v; 39 | | true -> failwith "Var already filled" 40 | 41 | let read t = t.t 42 | 43 | let fill_if_empty t v = 44 | match is_full t with 45 | | false -> fill t v 46 | | true -> () 47 | end 48 | 49 | module Deferred = struct 50 | type 'a t = 'a Lwt.t 51 | let all_unit = Lwt.join 52 | let try_with f = 53 | let open Lwt in 54 | let var = Ivar.create () in 55 | let hook = !async_exception_hook in 56 | async_exception_hook := (Ivar.fill var); 57 | catch (fun () -> (f () >>= fun r -> return (`Ok r)) 58 | (Ivar.read var >>= fun e -> return (`Error e))) 59 | (fun exn -> return (`Error exn)) >>= fun x -> 60 | async_exception_hook := hook; 61 | return x 62 | 63 | module List = struct 64 | let init ?(how:[>`Sequential | `Parallel] = `Parallel) ~f n = 65 | let rec inner = function 66 | | i when i = n -> [] 67 | | i -> i :: inner (i + 1) 68 | in 69 | match how with 70 | | `Sequential -> inner 0 |> Lwt_list.map_s f 71 | | `Parallel -> inner 0 |> Lwt_list.map_p f 72 | 73 | let iter ?(how:[>`Sequential | `Parallel] = `Parallel) ~f l = 74 | match how with 75 | | `Sequential -> Lwt_list.iter_s f l 76 | | `Parallel -> Lwt_list.iter_p f l 77 | end 78 | end 79 | 80 | module Log = struct 81 | let section = Lwt_log.Section.make "amqp-client" 82 | 83 | let debug fmt = Lwt_log.ign_debug_f ~section fmt 84 | let info fmt = Lwt_log.ign_info_f ~section fmt 85 | let error fmt = Lwt_log.ign_error_f ~section fmt 86 | end 87 | 88 | (* Pipes. Bounds are not implemented yet. *) 89 | module Pipe = struct 90 | type 'a elem = Data of 'a 91 | | Flush of unit Lwt_condition.t 92 | 93 | type 'a t = { cond: unit Lwt_condition.t; 94 | queue: 'a elem Ocaml_lib.Queue.t; 95 | mutable closed: bool; 96 | } 97 | 98 | module Reader = struct 99 | type nonrec 'a t = 'a t 100 | end 101 | 102 | module Writer = struct 103 | type nonrec 'a t = 'a t 104 | end 105 | 106 | let create () = 107 | let t = { cond = Lwt_condition.create (); 108 | queue = Ocaml_lib.Queue.create (); 109 | closed = false; 110 | } in 111 | (t, t) 112 | 113 | (** Not supported yet *) 114 | let set_size_budget _t _budget = () 115 | 116 | (* Can be readers and writers. *) 117 | let flush t = 118 | match Ocaml_lib.Queue.is_empty t.queue with 119 | | true -> return () 120 | | false -> 121 | let cond = Lwt_condition.create () in 122 | Ocaml_lib.Queue.push (Flush cond) t.queue; 123 | Lwt_condition.wait cond 124 | 125 | let rec read_raw t = 126 | match Ocaml_lib.Queue.is_empty t.queue with 127 | | true -> 128 | begin match t.closed with 129 | | true -> return `Eof 130 | | false -> 131 | Lwt_condition.wait t.cond >>= fun () -> 132 | read_raw t 133 | end 134 | | false -> 135 | return (`Ok (Ocaml_lib.Queue.pop t.queue)) 136 | 137 | let rec read t = 138 | read_raw t >>= function 139 | | `Eof -> return `Eof 140 | | `Ok (Data d) -> return @@ `Ok d 141 | | `Ok (Flush cond) -> 142 | Lwt_condition.signal cond (); 143 | read t 144 | 145 | let write_raw t data = 146 | Ocaml_lib.Queue.push data t.queue; 147 | Lwt_condition.broadcast t.cond () 148 | 149 | let write_without_pushback t data = 150 | write_raw t (Data data) 151 | 152 | let write t data = 153 | write_without_pushback t data; 154 | return () 155 | 156 | let rec iter t ~f = 157 | read t >>= function 158 | | `Eof -> return () 159 | | `Ok d -> f d >>= fun () -> iter t ~f 160 | 161 | let rec iter_without_pushback t ~f = 162 | read t >>= function 163 | | `Eof -> return () 164 | | `Ok d -> f d; iter_without_pushback t ~f 165 | 166 | (* Pipe of pipes. Must spawn more *) 167 | let interleave_pipe t = 168 | let (reader, writer) = create () in 169 | let rec copy t = 170 | read_raw t >>= function 171 | | `Eof -> return () 172 | | `Ok data -> 173 | write_raw writer data; 174 | copy t 175 | in 176 | spawn (iter_without_pushback t ~f:(fun p -> spawn (copy p))); 177 | reader 178 | 179 | let transfer_in ~from:queue t = 180 | Ocaml_lib.Queue.iter (write_without_pushback t) queue; 181 | return () 182 | 183 | let close t = 184 | t.closed <- true; 185 | begin match Ocaml_lib.Queue.is_empty t.queue with 186 | | true -> return () 187 | | false -> flush t 188 | end >>= fun () -> 189 | return () 190 | 191 | let close_without_pushback t = 192 | t.closed <- true; 193 | Lwt_condition.broadcast t.cond () 194 | 195 | end 196 | 197 | module Reader = struct 198 | type t = Lwt_io.input_channel 199 | let close t = Lwt_io.close t 200 | 201 | let read input buf : [ `Eof of int | `Ok ] Deferred.t = 202 | let len = Bytes.length buf in 203 | let rec inner = function 204 | | n when n = len -> 205 | return `Ok 206 | | n -> begin 207 | Lwt.catch 208 | (fun () -> Lwt_io.read_into input buf n (len - n)) 209 | (fun _exn -> return 0) >>= function 210 | | 0 -> return (`Eof n) 211 | | read -> inner (n + read) 212 | end 213 | in 214 | inner 0 215 | end 216 | 217 | module Writer = struct 218 | type t = string Pipe.Writer.t 219 | let close t = Pipe.close t 220 | let flush t = Pipe.flush t 221 | let write t data = Pipe.write_without_pushback t data 222 | end 223 | 224 | module Tcp = struct 225 | 226 | let connect ~exn_handler ?nodelay host port = 227 | let fd = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in 228 | Lwt_unix.gethostbyname host >>= fun entry -> 229 | let sock_addr = (Lwt_unix.ADDR_INET (entry.Lwt_unix.h_addr_list.(0), port)) in 230 | Lwt_io.open_connection ~fd sock_addr >>= fun (ic, oc) -> 231 | (* Start a process that writes *) 232 | let (reader, writer) = Pipe.create () in 233 | spawn ~exn_handler (Pipe.iter ~f:(fun str -> 234 | Lwt_io.write oc str) reader); 235 | 236 | (match nodelay with 237 | | Some () -> Lwt_unix.(setsockopt fd TCP_NODELAY true) 238 | | None -> ()); 239 | return (ic, writer) 240 | 241 | end 242 | 243 | module Scheduler = struct 244 | let cond = Lwt_condition.create () 245 | let go () = Lwt_main.run (Lwt_condition.wait cond) |> ignore 246 | let shutdown (n : int) = Lwt_condition.signal cond n 247 | end 248 | -------------------------------------------------------------------------------- /lwt/src/thread.mli: -------------------------------------------------------------------------------- 1 | include Amqp_client_lib.Thread.T with type 'a Deferred.t = 'a Lwt.t 2 | -------------------------------------------------------------------------------- /lwt/test/amqp.ml: -------------------------------------------------------------------------------- 1 | include Amqp_client_lwt 2 | 3 | let () = 4 | Lwt_log.default := 5 | Lwt_log.channel 6 | ~close_mode:`Keep 7 | ~channel:Lwt_io.stdout 8 | (); 9 | Lwt_log_core.append_rule "*" Lwt_log_core.Debug; 10 | -------------------------------------------------------------------------------- /lwt/test/dune: -------------------------------------------------------------------------------- 1 | (rule (copy# ../../async/test/channel_test.ml channel_test.ml)) 2 | (rule (copy# ../../async/test/close_test.ml close_test.ml)) 3 | (rule (copy# ../../async/test/connection_test.ml connection_test.ml)) 4 | (rule (copy# ../../async/test/connection_fail_test.ml connection_fail_test.ml)) 5 | (rule (copy# ../../async/test/connect_uri_test.ml connect_uri_test.ml)) 6 | (rule (copy# ../../async/test/exchange_test.ml exchange_test.ml)) 7 | (rule (copy# ../../async/test/mandatory_test.ml mandatory_test.ml)) 8 | (rule (copy# ../../async/test/queue_test.ml queue_test.ml)) 9 | (rule (copy# ../../async/test/queue_declare_test.ml queue_declare_test.ml)) 10 | (rule (copy# ../../async/test/repeat.ml repeat.ml)) 11 | (rule (copy# ../../async/test/rpc_async_test.ml rpc_async_test.ml)) 12 | (rule (copy# ../../async/test/rpc_test.ml rpc_test.ml)) 13 | (rule (copy# ../../async/test/vhost_test.ml vhost_test.ml)) 14 | (rule (copy# ../../async/test/with_confirm_test.ml with_confirm_test.ml)) 15 | (rule (copy# ../../async/test/queue_cancel_test.ml queue_cancel_test.ml)) 16 | 17 | (executables 18 | (names channel_test 19 | close_test 20 | connection_test 21 | connection_fail_test 22 | connect_uri_test 23 | exchange_test 24 | mandatory_test 25 | queue_test 26 | queue_declare_test 27 | repeat 28 | rpc_async_test 29 | rpc_test 30 | vhost_test 31 | with_confirm_test 32 | queue_cancel_test) 33 | (libraries amqp-client-lwt) 34 | ) 35 | 36 | (rule 37 | (alias integration) 38 | (action (run ./channel_test.exe)) 39 | (package amqp-client-lwt) 40 | ) 41 | 42 | (rule 43 | (alias integration) 44 | (action (run ./connection_test.exe)) 45 | (package amqp-client-lwt) 46 | ) 47 | 48 | (rule 49 | (alias integration) 50 | (action (run ./connection_fail_test.exe)) 51 | (package amqp-client-lwt) 52 | ) 53 | 54 | (rule 55 | (alias integration) 56 | (action (run ./connect_uri_test.exe)) 57 | (package amqp-client-lwt) 58 | ) 59 | 60 | (rule 61 | (alias integration) 62 | (action (run ./exchange_test.exe)) 63 | (package amqp-client-lwt) 64 | ) 65 | 66 | (rule 67 | (alias integration) 68 | (action (run ./mandatory_test.exe)) 69 | (package amqp-client-lwt) 70 | ) 71 | 72 | (rule 73 | (alias integration) 74 | (action (run ./queue_test.exe)) 75 | (package amqp-client-lwt) 76 | ) 77 | 78 | (rule 79 | (alias integration) 80 | (action (run ./queue_declare_test.exe)) 81 | (package amqp-client-lwt) 82 | ) 83 | 84 | ;(rule 85 | ; (alias integration) 86 | ; (action (run ./repeat.exe)) 87 | ; (package amqp-client-lwt) 88 | ;) 89 | 90 | (rule 91 | (alias integration) 92 | (action (run ./rpc_async_test.exe)) 93 | (package amqp-client-lwt) 94 | ) 95 | 96 | (rule 97 | (alias integration) 98 | (action (run ./rpc_test.exe)) 99 | (package amqp-client-lwt) 100 | ) 101 | 102 | (rule 103 | (alias integration) 104 | (action (run ./vhost_test.exe)) 105 | (package amqp-client-lwt) 106 | ) 107 | 108 | (rule 109 | (alias integration) 110 | (action (run ./with_confirm_test.exe)) 111 | (package amqp-client-lwt) 112 | ) 113 | 114 | (rule 115 | (alias integration) 116 | (action (run ./queue_cancel_test.exe)) 117 | (package amqp-client-lwt) 118 | ) 119 | -------------------------------------------------------------------------------- /other/.gitignore: -------------------------------------------------------------------------------- 1 | rabbitmq-c 2 | netamqp_test 3 | -------------------------------------------------------------------------------- /other/Makefile: -------------------------------------------------------------------------------- 1 | rabbitmq-c: rabbitmq-c.c 2 | gcc -o $@ $< -lrabbitmq 3 | 4 | netamqp_test: netamqp_test.ml 5 | ocamlfind ocamlopt -package netamqp $< -o $@ 6 | -------------------------------------------------------------------------------- /other/amqp.py: -------------------------------------------------------------------------------- 1 | import pika 2 | 3 | connection = pika.BlockingConnection() 4 | channel = connection.channel() 5 | 6 | # Get ten messages and break out 7 | i = 1 8 | while True: 9 | channel.basic_publish("", "anders", "message: " + str(i)) 10 | meth, _, data = channel.basic_get("anders") 11 | channel.basic_ack(meth.delivery_tag) 12 | print "Received: " + data 13 | i = i + 1 14 | -------------------------------------------------------------------------------- /other/netamqp_test.ml: -------------------------------------------------------------------------------- 1 | (* This is the sender for receiver_t. Please read the comments there first! 2 | 3 | Also, when trying this example, make sure the receiver is started first 4 | because the receiver declares the queue. 5 | *) 6 | 7 | open Netamqp_types 8 | open Printf 9 | (* 10 | let () = 11 | Netamqp_endpoint.Debug.enable := true; 12 | Netamqp_transport.Debug.enable := true 13 | *) 14 | 15 | let esys = Unixqueue.create_unix_event_system() 16 | let p = `TCP(`Inet("localhost", Netamqp_endpoint.default_port)) 17 | let ep = Netamqp_endpoint.create p (`AMQP_0_9 `One) esys 18 | let c = Netamqp_connection.create ep 19 | let auth = Netamqp_connection.plain_auth "guest" "guest" 20 | 21 | let qname = "test_xy" 22 | 23 | 24 | let sender c = 25 | let ch = Netamqp_channel.open_next_s c in 26 | let channel = Netamqp_channel.number ch in 27 | eprintf "*** Channel could be opened!\n%!"; 28 | 29 | let header = 30 | `AMQP_0_9 31 | (`P_basic 32 | ( None, 33 | None, 34 | None, 35 | Some 1, (* non-persistent *) 36 | None, (* priority *) 37 | None, 38 | None, 39 | None, 40 | None, 41 | None, 42 | None, 43 | None, 44 | None, 45 | None 46 | ) 47 | ) in 48 | 49 | for n = 100000 downto 0 do 50 | (* d is the queued message. Note that the body is actually a list of 51 | mstring (see t_receiver.ml for explanations). 52 | *) 53 | let d = 54 | (header, 55 | [Netamqp_rtypes.mk_mstring (sprintf "%d" n)] 56 | ) in 57 | 58 | Netamqp_endpoint.async_c2s 59 | ep 60 | (`AMQP_0_9(`Basic_publish(0, "", qname, 61 | false, false))) 62 | (Some d) 63 | channel; 64 | 65 | (* eprintf "*** Message published!\n%!"; *) 66 | done; 67 | eprintf "Send done\n%!" 68 | 69 | let receiver c = 70 | (* Now open the data channel. Channels are multiplexed over connections *) 71 | let ch = Netamqp_channel.open_next_s c in 72 | let channel = Netamqp_channel.number ch in 73 | eprintf "*** Channel could be opened!\n%!"; 74 | 75 | eprintf "*** Queue declared!\n%!"; 76 | 77 | Netamqp_endpoint.register_async_s2c 78 | ep 79 | (`AMQP_0_9 `Basic_deliver) 80 | channel 81 | (fun _ -> function 82 | | Some(_header,body) -> 83 | begin 84 | match int_of_string (Netxdr_mstring.concat_mstrings body) with 85 | | 0 -> (* Shut it down *) 86 | exit 0 87 | | n when n mod 1000 = 0 -> 88 | eprintf "%d\n%!" n 89 | | _ -> () 90 | end 91 | | None -> failwith "No data" 92 | ); 93 | 94 | let _ = Netamqp_endpoint.sync_c2s_s 95 | ep 96 | (`AMQP_0_9 (`Basic_consume(0, qname, "", false, false, false, 97 | false, [] ))) 98 | None 99 | channel 100 | (-1.0) 101 | in 102 | () 103 | 104 | let _main = 105 | Netamqp_connection.open_s c [ auth ] (`Pref "en_US") "/"; 106 | eprintf "*** Connection could be opened, and the proto handshake is done!\n%!"; 107 | 108 | let ch = Netamqp_channel.open_next_s c in 109 | let channel = Netamqp_channel.number ch in 110 | 111 | let _ = 112 | Netamqp_endpoint.sync_c2s_s 113 | ep 114 | (`AMQP_0_9 (`Queue_declare(0, qname, false, false, false, 115 | (* auto-delete: *) true, false, 116 | []))) 117 | None (* This value would allow to send content data along with the 118 | method. Only certain methods permit this, though. 119 | *) 120 | channel 121 | (-1.0) (* timeout *) 122 | in 123 | 124 | receiver c; 125 | sender c; 126 | 127 | 128 | Unixqueue.run esys; 129 | 130 | 131 | Netamqp_channel.close_s ch; 132 | eprintf "*** Channel could be closed!\n%!"; 133 | 134 | Netamqp_connection.close_s c; 135 | eprintf "*** Connection could be closed!\n%!" 136 | -------------------------------------------------------------------------------- /other/pika_async.py: -------------------------------------------------------------------------------- 1 | # -*- coding: utf-8 -*- 2 | 3 | import logging 4 | import pika 5 | 6 | LOG_FORMAT = ('%(levelname) -10s %(asctime)s %(name) -30s %(funcName) ' 7 | '-35s %(lineno) -5d: %(message)s') 8 | LOGGER = logging.getLogger(__name__) 9 | 10 | 11 | class ExampleConsumer(object): 12 | QUEUE = 'pika.test' 13 | 14 | def __init__(self, amqp_url): 15 | self._connection = None 16 | self._channel = None 17 | self._closing = False 18 | self._consumer_tag = None 19 | self._url = amqp_url 20 | 21 | def connect(self): 22 | LOGGER.info('Connecting to %s', self._url) 23 | return pika.SelectConnection(pika.URLParameters(self._url), 24 | self.on_connection_open, 25 | stop_ioloop_on_close=False) 26 | 27 | def on_connection_open(self, unused_connection): 28 | LOGGER.info('Connection opened') 29 | self.open_channel() 30 | 31 | def open_channel(self): 32 | LOGGER.info('Creating a new channel') 33 | self._connection.channel(on_open_callback=self.on_channel_open) 34 | 35 | def on_channel_open(self, channel): 36 | LOGGER.info('Channel opened') 37 | self._channel = channel 38 | self.setup_queue(self.QUEUE) 39 | 40 | def setup_queue(self, queue_name): 41 | self._channel.queue_declare(self.on_queue_declareok, queue_name, auto_delete = True) 42 | 43 | def on_queue_declareok(self, method_frame): 44 | self.start_consuming() 45 | 46 | def start_consuming(self): 47 | LOGGER.info('Issuing consumer related RPC commands') 48 | self._consumer_tag = self._channel.basic_consume(self.on_message, 49 | self.QUEUE, 50 | no_ack = True) 51 | self.produce(100000) 52 | 53 | def produce(self, n): 54 | 55 | properties = pika.BasicProperties() 56 | 57 | self._channel.basic_publish("", self.QUEUE, 58 | str(n), 59 | properties) 60 | if n > 0: 61 | self._connection.add_timeout(-1, lambda: self.produce(n-1)) 62 | else: 63 | print "Done producing" 64 | 65 | def on_message(self, unused_channel, basic_deliver, properties, body): 66 | n = int(body) 67 | if (n % 1000) == 0: 68 | print n 69 | if n == 0: 70 | self._connection.ioloop.stop() 71 | 72 | def run(self): 73 | self._connection = self.connect() 74 | self._connection.ioloop.start() 75 | 76 | def stop(self): 77 | LOGGER.info('Stopping') 78 | self._closing = True 79 | self.stop_consuming() 80 | self._connection.ioloop.start() 81 | LOGGER.info('Stopped') 82 | 83 | def close_connection(self): 84 | LOGGER.info('Closing connection') 85 | self._connection.close() 86 | 87 | 88 | def main(): 89 | logging.basicConfig(level=logging.INFO, format=LOG_FORMAT) 90 | example = ExampleConsumer('amqp://guest:guest@localhost:5672/%2F') 91 | try: 92 | example.run() 93 | except KeyboardInterrupt: 94 | example.stop() 95 | 96 | 97 | if __name__ == '__main__': 98 | main() 99 | -------------------------------------------------------------------------------- /other/rabbitmq-c.c: -------------------------------------------------------------------------------- 1 | /* vim:set ft=c ts=2 sw=2 sts=2 et cindent: */ 2 | /* 3 | * ***** BEGIN LICENSE BLOCK ***** 4 | * Version: MIT 5 | * 6 | * Portions created by Alan Antonuk are Copyright (c) 2012-2013 7 | * Alan Antonuk. All Rights Reserved. 8 | * 9 | * Portions created by VMware are Copyright (c) 2007-2012 VMware, Inc. 10 | * All Rights Reserved. 11 | * 12 | * Portions created by Tony Garnock-Jones are Copyright (c) 2009-2010 13 | * VMware, Inc. and Tony Garnock-Jones. All Rights Reserved. 14 | * 15 | * Permission is hereby granted, free of charge, to any person 16 | * obtaining a copy of this software and associated documentation 17 | * files (the "Software"), to deal in the Software without 18 | * restriction, including without limitation the rights to use, copy, 19 | * modify, merge, publish, distribute, sublicense, and/or sell copies 20 | * of the Software, and to permit persons to whom the Software is 21 | * furnished to do so, subject to the following conditions: 22 | * 23 | * The above copyright notice and this permission notice shall be 24 | * included in all copies or substantial portions of the Software. 25 | * 26 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 27 | * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 28 | * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 29 | * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 30 | * BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 31 | * ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 32 | * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 33 | * SOFTWARE. 34 | * ***** END LICENSE BLOCK ***** 35 | */ 36 | 37 | #include 38 | #include 39 | #include 40 | 41 | #include 42 | #include 43 | #include 44 | #include 45 | 46 | static void send_batch(amqp_connection_state_t conn, 47 | char const *queue_name, 48 | int message_count) 49 | { 50 | int i; 51 | 52 | char message[256]; 53 | amqp_bytes_t message_bytes; 54 | 55 | for (i = 0; i < (int)sizeof(message); i++) { 56 | message[i] = i & 0xff; 57 | } 58 | 59 | message_bytes.len = sizeof(message); 60 | message_bytes.bytes = message; 61 | 62 | for (i = 0; i < message_count; i++) { 63 | 64 | amqp_basic_publish(conn, 65 | 1, 66 | amqp_cstring_bytes(""), 67 | amqp_cstring_bytes(queue_name), 68 | 0, 69 | 0, 70 | NULL, 71 | message_bytes); 72 | if (i % 1000 == 0) { 73 | printf("Sent 1000\n"); 74 | } 75 | } 76 | } 77 | 78 | static void recv_batch(amqp_connection_state_t conn, 79 | char const *queue_name, 80 | int message_count) 81 | { 82 | for (int i = 0; i < message_count; i++) { 83 | amqp_basic_get(conn, 84 | 1, 85 | amqp_cstring_bytes(queue_name), 86 | 1); 87 | if (i % 1000 == 0) { 88 | printf("Receive 1000\n"); 89 | } 90 | } 91 | } 92 | 93 | 94 | int main(int argc, char const *const *argv) 95 | { 96 | char const *hostname; 97 | int port, status; 98 | int message_count; 99 | amqp_socket_t *socket = NULL; 100 | amqp_connection_state_t conn; 101 | 102 | if (argc < 4) { 103 | fprintf(stderr, "Usage: amqp_producer host port message_count\n"); 104 | return 1; 105 | } 106 | 107 | hostname = argv[1]; 108 | port = atoi(argv[2]); 109 | message_count = atoi(argv[3]); 110 | 111 | conn = amqp_new_connection(); 112 | 113 | socket = amqp_tcp_socket_new(conn); 114 | status = amqp_socket_open(socket, hostname, port); 115 | amqp_login(conn, "/", 0, 131072, 0, AMQP_SASL_METHOD_PLAIN, "guest", "guest"); 116 | amqp_channel_open(conn, 1); 117 | amqp_get_rpc_reply(conn); 118 | 119 | send_batch(conn, "test_queue", message_count); 120 | recv_batch(conn, "test_queue", message_count); 121 | 122 | amqp_channel_close(conn, 1, AMQP_REPLY_SUCCESS); 123 | amqp_connection_close(conn, AMQP_REPLY_SUCCESS); 124 | amqp_destroy_connection(conn); 125 | return 0; 126 | } 127 | -------------------------------------------------------------------------------- /spec/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen_spec) 3 | (modules Gen_spec) 4 | (libraries ezxmlm str) 5 | ) 6 | 7 | (rule 8 | (targets spec.ml) 9 | (deps amqp0-9-1.extended.xml) 10 | (action (with-stdout-to %{targets} (run ./gen_spec.exe -type specification %{deps}))) 11 | ) 12 | 13 | (rule 14 | (targets constants.ml) 15 | (deps amqp0-9-1.extended.xml) 16 | (action (with-stdout-to %{targets} (run ./gen_spec.exe -type constants %{deps}))) 17 | ) 18 | -------------------------------------------------------------------------------- /spec/gen_spec.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | module List = ListLabels 3 | let indent = ref 0 4 | let emit_location = ref true 5 | 6 | let option_map ~f = function 7 | | Some v -> f v 8 | | None -> None 9 | 10 | let option_iter ~f = function 11 | | Some v -> f v 12 | | None -> () 13 | 14 | let emit_loc loc = 15 | match !emit_location with 16 | | true -> 17 | let indent = String.make (!indent * 2) ' ' in 18 | printf "%s(* %s:%d *)\n" indent __FILE__ loc 19 | | false -> 20 | printf "# %d \"%s\"\n" loc __FILE__ 21 | 22 | let emit ?loc fmt = 23 | option_iter ~f:emit_loc loc; 24 | assert (!indent >= 0); 25 | let indent = String.make (!indent * 2) ' ' in 26 | (* Get last location *) 27 | printf ("%s" ^^ fmt ^^ "\n") indent 28 | 29 | let emit_doc = function 30 | | Some doc -> 31 | emit ""; 32 | emit "(** %s *)" doc 33 | | None -> () 34 | 35 | 36 | module Field = struct 37 | type t = { name: string; tpe: string; reserved: bool; doc: string option } 38 | end 39 | module Constant = struct 40 | type t = { name: string; value: int; doc: string option } 41 | end 42 | module Domain = struct 43 | type t = { name: string; amqp_type: string; doc: string option } 44 | end 45 | module Method = struct 46 | type t = { name: string; arguments: Field.t list; 47 | response: string list; content: bool; 48 | index: int; synchronous: bool; server: bool; client: bool; 49 | doc: string option 50 | } 51 | end 52 | module Class = struct 53 | type t = { name: string; content: Field.t list; index: int; 54 | methods: Method.t list; doc: string option } 55 | end 56 | 57 | type elem = 58 | | Constant of Constant.t 59 | | Domain of Domain.t 60 | | Class of Class.t 61 | 62 | let blanks = Str.regexp "[ \t\n]+" 63 | let doc xml = 64 | try 65 | Ezxmlm.member "doc" xml 66 | |> Ezxmlm.data_to_string 67 | |> (fun x -> Some x) 68 | with 69 | | Ezxmlm.Tag_not_found _ -> None 70 | 71 | let parse_field (attrs, nodes) = 72 | (* Only look at the attributes *) 73 | ignore nodes; 74 | let name = 75 | match Ezxmlm.get_attr "name" attrs with 76 | | "type" -> "amqp_type" 77 | | name -> name 78 | in 79 | let tpe = 80 | match Ezxmlm.get_attr "domain" attrs with 81 | | d -> d 82 | | exception Not_found -> Ezxmlm.get_attr "type" attrs 83 | in 84 | 85 | let reserved = Ezxmlm.mem_attr "reserved" "1" attrs in 86 | { Field.name; tpe; reserved; doc = doc nodes } 87 | 88 | let parse_constant (attrs, nodes) = 89 | let name = Ezxmlm.get_attr "name" attrs in 90 | let value = Ezxmlm.get_attr "value" attrs |> int_of_string in 91 | Constant { Constant.name; value; doc = doc nodes } 92 | 93 | let parse_domain (attrs, nodes) = 94 | ignore nodes; 95 | let name = Ezxmlm.get_attr "name" attrs in 96 | let amqp_type = Ezxmlm.get_attr "type" attrs in 97 | Domain { Domain.name; amqp_type; doc = doc nodes} 98 | 99 | let parse_method (attrs, nodes) = 100 | let name = Ezxmlm.get_attr "name" attrs in 101 | incr indent; 102 | let index = Ezxmlm.get_attr "index" attrs |> int_of_string in 103 | let response = 104 | Ezxmlm.members_with_attr "response" nodes 105 | |> List.map ~f:(fun (attrs, _) -> Ezxmlm.get_attr "name" attrs) 106 | in 107 | 108 | let synchronous = 109 | match Ezxmlm.get_attr "synchronous" attrs with 110 | | "1" -> true 111 | | _ -> false 112 | | exception Not_found -> false 113 | in 114 | let content = 115 | match Ezxmlm.get_attr "content" attrs with 116 | | "1" -> true 117 | | _ -> false 118 | | exception Not_found -> false 119 | in 120 | let arguments = Ezxmlm.members_with_attr "field" nodes |> List.map ~f:parse_field in 121 | 122 | let chassis = 123 | Ezxmlm.members_with_attr "chassis" nodes 124 | |> List.map ~f:(fun (attrs, _) -> Ezxmlm.get_attr "name" attrs) 125 | in 126 | let client = List.mem "client" ~set:chassis in 127 | let server = List.mem "server" ~set:chassis in 128 | decr indent; 129 | { Method.name; arguments; response; content; index; synchronous; 130 | client; server; doc = doc nodes } 131 | 132 | let parse_class (attrs, nodes) = 133 | (* All field nodes goes into content *) 134 | let name = Ezxmlm.get_attr "name" attrs in 135 | incr indent; 136 | let index = Ezxmlm.get_attr "index" attrs |> int_of_string in 137 | let fields = Ezxmlm.members_with_attr "field" nodes |> List.map ~f:parse_field in 138 | let methods = Ezxmlm.members_with_attr "method" nodes |> List.map ~f:parse_method in 139 | decr indent; 140 | Class { Class.name; index; content=fields; methods; doc = doc nodes } 141 | 142 | let parse = function 143 | | `Data _ -> None 144 | | `El (((_, "constant"), attrs), nodes) -> Some (parse_constant (attrs, nodes)) 145 | | `El (((_, "domain"), attrs), nodes) -> Some (parse_domain (attrs, nodes)) 146 | | `El (((_, "class"), attrs), nodes) -> Some (parse_class (attrs, nodes)) 147 | | `El (((_, name), _), _) -> failwith ("Unknown type: " ^ name) 148 | 149 | let parse_amqp xml = 150 | Ezxmlm.member "amqp" xml 151 | |> List.map ~f:parse 152 | |> List.fold_left ~f:(fun acc -> function None -> acc | Some v -> v :: acc) ~init:[] 153 | |> List.rev 154 | 155 | let bind_name str = 156 | String.map (function '-' -> '_' | c -> Char.lowercase_ascii c) str 157 | 158 | let variant_name str = 159 | bind_name str 160 | |> String.capitalize_ascii 161 | 162 | let pvariant_name str = 163 | "`" ^ (variant_name str) 164 | 165 | (* Remove domains *) 166 | let emit_domains tree = 167 | let domains = Hashtbl.create 0 in 168 | List.iter ~f:(function 169 | | Domain {Domain.name; amqp_type; doc} when name <> amqp_type -> 170 | Hashtbl.add domains name (amqp_type, doc) 171 | | _ -> () 172 | ) tree; 173 | 174 | emit "(* Domains *)"; 175 | Hashtbl.iter (fun d (t, doc) -> 176 | emit_doc doc; 177 | emit ~loc:__LINE__ "type %s = %s" (bind_name d) (bind_name t); 178 | ) domains; 179 | 180 | emit ""; 181 | emit "(**/**)"; 182 | emit ~loc:__LINE__ "module Internal_alias = struct"; 183 | incr indent; 184 | 185 | Hashtbl.iter (fun d (t, _) -> 186 | emit "let %s = %s" (bind_name d) (variant_name t); 187 | ) domains; 188 | decr indent; 189 | emit "end"; 190 | emit "(**/**)"; 191 | emit ""; 192 | 193 | (* Alter the tree *) 194 | let replace lst = 195 | let open Field in 196 | List.map ~f:(fun t -> 197 | let tpe = match Hashtbl.mem domains t.tpe with 198 | | true -> bind_name t.tpe 199 | | false -> variant_name t.tpe 200 | in 201 | { t with tpe } 202 | ) lst 203 | in 204 | let map = function 205 | | Domain _ -> None 206 | | Constant c -> Some (Constant c) 207 | | Class ({ Class.content; methods; _ } as c) -> 208 | let methods = 209 | List.map ~f:(function {Method.arguments; _ } as m -> 210 | { m with Method.arguments = replace arguments } 211 | ) methods 212 | in 213 | Some (Class { c with Class.methods; content = replace content }) 214 | in 215 | List.fold_left ~f:(fun acc e -> match map e with Some x -> x :: acc | None -> acc) ~init:[] tree 216 | 217 | let emit_constants tree = 218 | emit "(* Constants *)"; 219 | List.iter ~f:(function Constant { Constant.name; value; doc } -> 220 | emit_doc doc; 221 | emit ~loc:__LINE__ "let %s = %d" (bind_name name) value | _ -> () 222 | ) tree 223 | 224 | let emit_class_index tree = 225 | emit "(* Class index *)"; 226 | let idx = ref 0 in 227 | emit ~loc:__LINE__ "let index_of_class = function"; 228 | incr indent; 229 | List.iter ~f:(function Class { Class.index; _ } -> emit "| %d -> %d" index !idx; incr idx | _ -> ()) tree; 230 | emit "| _ -> failwith \"Unknown class\""; 231 | decr indent; 232 | emit ~loc:__LINE__ "let classes = %d" !idx 233 | 234 | let emit_method_index tree = 235 | emit "(* Class - Method index *)"; 236 | let idx = ref 0 in 237 | emit ~loc:__LINE__ "let index_of_class_method = function"; 238 | incr indent; 239 | List.iter ~f:(function 240 | | Class { Class.index; methods; _ } -> 241 | emit "| %d -> begin function" index; 242 | incr indent; 243 | List.iter ~f:(fun { Method.index; _ } -> 244 | emit "| %d -> %d" index !idx; 245 | incr idx 246 | ) methods; 247 | emit "| _ -> failwith \"Unknown method\""; 248 | emit "end"; 249 | decr indent; 250 | | _ -> () 251 | ) tree; 252 | emit "| _ -> failwith \"Unknown class\""; 253 | decr indent; 254 | emit ~loc:__LINE__ "let methods = %d" !idx 255 | 256 | 257 | let spec_str arguments = 258 | arguments 259 | |> List.map ~f:(fun t -> t.Field.tpe) 260 | |> fun a -> List.append a ["[]"] 261 | |> String.concat " :: " 262 | 263 | let emit_method ?(is_content=false) class_index 264 | { Method.name; 265 | arguments; 266 | response; 267 | content; 268 | index; 269 | synchronous; 270 | client; 271 | server; 272 | doc; 273 | } = 274 | 275 | emit_doc doc; 276 | emit ~loc:__LINE__ "module %s = struct" (variant_name name); 277 | incr indent; 278 | let t_args = 279 | arguments 280 | |> List.filter ~f:(fun t -> not t.Field.reserved) 281 | in 282 | let option = if is_content then " option" else "" in 283 | let doc_str = function 284 | | None -> "" 285 | | Some doc -> "(** " ^ doc ^ " *)" 286 | in 287 | let types = List.map ~f:(fun t -> (bind_name t.Field.name), (bind_name t.Field.tpe) ^ option, doc_str t.Field.doc) t_args in 288 | 289 | let t_args = match types with 290 | | [] -> "()" 291 | | t -> List.map ~f:(fun (a, _, _) -> a) t |> String.concat "; " |> sprintf "{ %s }" 292 | in 293 | let names = 294 | arguments 295 | |> List.map ~f:(function t when t.Field.reserved -> "_" | t -> bind_name t.Field.name) 296 | in 297 | let values = 298 | arguments 299 | |> List.map ~f:(function 300 | | t when t.Field.reserved -> 301 | "(reserved_value " ^ t.Field.tpe ^ ")" 302 | | t -> bind_name t.Field.name 303 | ) 304 | |> String.concat " " 305 | in 306 | 307 | (match types with 308 | | [] -> emit ~loc:__LINE__ "type t = unit" 309 | | t -> 310 | emit ~loc:__LINE__ "type t = {"; 311 | incr indent; 312 | List.iter ~f:(fun (a, b, doc) -> emit "%s: %s; %s" a b doc) t; 313 | decr indent; 314 | emit "}"); 315 | emit ""; 316 | emit "(**/**)"; 317 | emit ~loc:__LINE__ "module Internal = struct"; 318 | incr indent; 319 | emit "open Internal_alias [@@warning \"-33\"]"; 320 | 321 | if is_content then 322 | emit "open Protocol.Content" 323 | else 324 | emit "open Protocol.Spec"; 325 | 326 | 327 | emit_loc __LINE__; 328 | emit "let spec = %s" (spec_str arguments); 329 | emit "let make %s = %s" (String.concat " " names) t_args; 330 | emit "let apply f %s = f %s" t_args values; 331 | emit "let def = ((%d, %d), spec, make, apply)" class_index index; 332 | 333 | begin match is_content, content with 334 | | false, false -> 335 | emit ~loc:__LINE__ "let write = write_method def"; 336 | emit ~loc:__LINE__ "let read = read_method def" 337 | | false, true -> 338 | emit ~loc:__LINE__ "let write = write_method_content def Content.Internal.def"; 339 | emit ~loc:__LINE__ "let read = read_method_content def Content.Internal.def" 340 | | true, _ -> 341 | () 342 | end; 343 | 344 | decr indent; 345 | emit "end"; 346 | emit "(**/**)"; 347 | emit ""; 348 | 349 | let inames = List.filter ~f:((<>) "_") names in 350 | begin match is_content with 351 | | true -> 352 | emit ~loc:__LINE__ "let init %s () = Internal.make %s" (List.map ~f:(fun n -> "?" ^ n) inames |> String.concat " ") (String.concat " " inames) 353 | | false -> 354 | emit ~loc:__LINE__ "let init %s () = Internal.make %s" (List.map ~f:(fun n -> "~" ^ n) inames |> String.concat " ") (String.concat " " inames) 355 | end; 356 | 357 | 358 | 359 | let response = List.map ~f:variant_name response in 360 | if List.length response >= 0 && ((synchronous && response != []) || not synchronous) then begin 361 | let id r = 362 | if List.length response > 1 then 363 | "(fun m -> `" ^ r ^ " m)" 364 | else 365 | "" 366 | in 367 | if client then 368 | emit ~loc:__LINE__ "let reply = reply%d Internal.read %s" 369 | (List.length response) 370 | (response |> List.map ~f:(fun s -> Printf.sprintf "%s.Internal.write %s" s (id s)) |> String.concat " "); 371 | if server then 372 | emit ~loc:__LINE__ "let request = request%d Internal.write %s" 373 | (List.length response) 374 | (response |> List.map ~f:(fun s -> Printf.sprintf "%s.Internal.read %s" s (id s)) |> String.concat " "); 375 | end; 376 | decr indent; 377 | emit "end"; 378 | () 379 | 380 | 381 | let emit_class { Class.name; content; index; methods; doc } = 382 | (* Reorder modules based on dependencies *) 383 | let rec reorder methods = 384 | let rec move_down = function 385 | | { Method.response; _} as m :: x :: xs when 386 | List.exists ~f:(fun r -> List.exists ~f:(fun {Method.name; _} -> name = r) (x :: xs)) response -> x :: move_down (m :: xs) 387 | | x :: xs -> x :: move_down xs 388 | | [] -> [] 389 | in 390 | let ms = move_down methods in 391 | if ms = methods then ms 392 | else reorder ms 393 | in 394 | let methods = reorder methods in 395 | emit_doc doc; 396 | emit ~loc:__LINE__ "module %s = struct" (variant_name name); 397 | incr indent; 398 | 399 | if (content != []) then 400 | emit_method ~is_content:true 401 | index { Method.name = "content"; 402 | arguments = content; 403 | response = []; 404 | content = false; 405 | index = 0; (* must be zero *) 406 | synchronous = false; 407 | server=false; 408 | client=false; 409 | doc = None; 410 | }; 411 | 412 | List.iter ~f:(emit_method index) methods; 413 | 414 | decr indent; 415 | emit "end"; 416 | () 417 | 418 | let emit_printer tree = 419 | emit_loc __LINE__; 420 | emit "module Printer = struct"; 421 | incr indent; 422 | emit "let id_to_string (cid, mid) ="; 423 | incr indent; 424 | emit "match cid with"; 425 | incr indent; 426 | List.iter ~f:(function 427 | | Class {Class.name; index; _} -> 428 | emit "| %d -> \"%s\" ^ \", \" ^(%s.method_to_string mid)" index name (variant_name name) 429 | | _ -> () 430 | ) tree; 431 | emit "| _ -> Printf.sprintf \"<%%d>, <%%d>\" mid cid"; 432 | decr indent; 433 | decr indent; 434 | decr indent; 435 | emit "end"; 436 | () 437 | 438 | let emit_specification tree = 439 | emit_loc __LINE__; 440 | emit "open Amqp_client_lib"; 441 | emit "open Types"; 442 | emit "open Protocol"; 443 | emit "open Protocol_helpers"; 444 | emit_domains tree 445 | |> List.iter ~f:(function Class x -> emit_class x | _ -> ()); 446 | (* emit_printer tree; *) 447 | () 448 | 449 | type output = Constants | Specification 450 | 451 | let () = 452 | (* Argument parsing *) 453 | let output_type = ref Specification in 454 | let filename = ref "" in 455 | 456 | Arg.parse 457 | ["-type", Arg.Symbol (["constants"; "specification"], 458 | fun t -> output_type := match t with 459 | | "constants" -> Constants 460 | | "specification" -> Specification 461 | | _ -> failwith "Illegal argument" 462 | ), "Type of output"; 463 | "-noloc", Arg.Clear emit_location, "Inhibit emission of location pointers" 464 | ] 465 | (fun f -> filename := f) 466 | "Generate protocol code"; 467 | 468 | let xml = 469 | let in_ch = open_in !filename in 470 | let (_, xml) = Ezxmlm.from_channel in_ch in 471 | close_in in_ch; 472 | xml 473 | in 474 | let tree = xml |> parse_amqp in 475 | emit "(** Internal - Low level protocol description *)"; 476 | emit "(***********************************)"; 477 | emit "(* AUTOGENERATED FILE: DO NOT EDIT *)"; 478 | emit "(* %s %s %s %s *)" Sys.argv.(0) Sys.argv.(1) Sys.argv.(2) Sys.argv.(3); 479 | emit "(***********************************)"; 480 | emit ""; 481 | emit ""; 482 | 483 | begin 484 | match !output_type with 485 | | Constants -> 486 | emit_constants tree; 487 | () 488 | | Specification -> emit_specification tree 489 | end; 490 | assert (!indent = 0); 491 | () 492 | --------------------------------------------------------------------------------