├── .gitignore ├── .merlin ├── LICENSE ├── Makefile ├── README ├── _oasis ├── _tags ├── configure ├── example └── example.ml ├── lib ├── META ├── mqtt.ml ├── mqtt.mldylib ├── mqtt.mllib └── subscriptions.ml ├── myocamlbuild.ml ├── setup.ml └── test └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.byte 2 | .* 3 | _build 4 | setup.data 5 | setup.log 6 | !.gitignore 7 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S lib test example 2 | PKG lwt lwt.unix oUnit ocplib-endian 3 | EXT lwt 4 | B _build/lib _build/test _build/example 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Josh Allmann 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 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Message parser for MQTT written in OCaml. 2 | 3 | This library is really only useful for message parsing. 4 | While there is a simple client and server example, the 5 | semantics of the MQTT protocol are not implemented. 6 | 7 | MQTT version 3.1 messages are supported, but not the 8 | 3.1.1 'update', which is incompatible in several ways. 9 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: mqtt 3 | Version: 0.0.1 4 | Synopsis: MQTT message parser in OCaml 5 | Authors: Josh Allmann 6 | License: BSD-3-clause 7 | Plugins: META (0.4), DevFiles (0.4) 8 | 9 | Library mqtt 10 | Path: lib 11 | BuildTools: ocamlbuild 12 | Modules: Mqtt 13 | BuildDepends: lwt (>= 2.7.0), lwt.unix, oUnit, ocplib-endian 14 | Pack: false 15 | FindlibName: mqtt 16 | ByteOpt: -bin-annot -ppopt -lwt-debug 17 | NativeOpt: -bin-annot -ppopt -lwt-debug 18 | 19 | Test "TestMqtt" 20 | Command: test/mqtt_test 21 | 22 | Executable mqtt_example 23 | Path: example 24 | BuildTools: ocamlbuild 25 | MainIs: example.ml 26 | BuildDepends: mqtt,lwt 27 | Install: false 28 | 29 | Executable mqtt_test 30 | Path: test 31 | BuildTools: ocamlbuild 32 | MainIs: test.ml 33 | BuildDepends: mqtt, oUnit 34 | Install: false 35 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 4f1834372dd461688a1253648edafcab) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | true: annot, bin_annot 7 | <**/.svn>: -traverse 8 | <**/.svn>: not_hygienic 9 | ".bzr": -traverse 10 | ".bzr": not_hygienic 11 | ".hg": -traverse 12 | ".hg": not_hygienic 13 | ".git": -traverse 14 | ".git": not_hygienic 15 | "_darcs": -traverse 16 | "_darcs": not_hygienic 17 | # Library mqtt 18 | "lib/mqtt.cmxs": use_mqtt 19 | : oasis_library_mqtt_byte 20 | : oasis_library_mqtt_byte 21 | : oasis_library_mqtt_native 22 | : oasis_library_mqtt_native 23 | : pkg_lwt 24 | : pkg_lwt.unix 25 | : pkg_oUnit 26 | : pkg_ocplib-endian 27 | # Executable mqtt_example 28 | "example/example.byte": pkg_lwt 29 | "example/example.byte": pkg_lwt.unix 30 | "example/example.byte": pkg_oUnit 31 | "example/example.byte": pkg_ocplib-endian 32 | "example/example.byte": use_mqtt 33 | : pkg_lwt 34 | : pkg_lwt.unix 35 | : pkg_oUnit 36 | : pkg_ocplib-endian 37 | : use_mqtt 38 | # Executable mqtt_test 39 | "test/test.byte": pkg_lwt 40 | "test/test.byte": pkg_lwt.unix 41 | "test/test.byte": pkg_oUnit 42 | "test/test.byte": pkg_ocplib-endian 43 | "test/test.byte": use_mqtt 44 | : pkg_lwt 45 | : pkg_lwt.unix 46 | : pkg_oUnit 47 | : pkg_ocplib-endian 48 | : use_mqtt 49 | # OASIS_STOP 50 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /example/example.ml: -------------------------------------------------------------------------------- 1 | let (>>=) = Lwt.bind 2 | 3 | let sub_example () = 4 | let open Mqtt.Mqtt.MqttClient in 5 | let read_subs stream = 6 | let rec loop unit = 7 | unit >>= fun () -> Lwt_stream.get stream >>= function 8 | | None -> Lwt_io.printl "STREAM FINISHED" 9 | | Some (t, p) -> Lwt_io.printlf "%s: %s" t p |> loop in 10 | loop Lwt.return_unit in 11 | connect "localhost" >>= fun client -> 12 | subscribe client [("foospace", Mqtt.Mqtt.Atmost_once)] >>= fun () -> 13 | sub_stream client |> read_subs 14 | 15 | let pub_example () = 16 | let open Mqtt.Mqtt.MqttClient in 17 | connect "localhost" >>= fun cxn -> 18 | publish cxn "foospace" "isn't this awesome?" 19 | 20 | let () = Lwt_main.run (sub_example ()) 21 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 78b08b07ae328d16b4b541a16257c576) 3 | version = "0.0.1" 4 | description = "MQTT message parser in OCaml" 5 | requires = "lwt lwt.unix oUnit ocplib-endian" 6 | archive(byte) = "mqtt.cma" 7 | archive(byte, plugin) = "mqtt.cma" 8 | archive(native) = "mqtt.cmxa" 9 | archive(native, plugin) = "mqtt.cmxs" 10 | exists_if = "mqtt.cma" 11 | # OASIS_STOP 12 | 13 | -------------------------------------------------------------------------------- /lib/mqtt.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open Lwt 3 | 4 | module Mqtt : sig 5 | 6 | type t 7 | type 'a monad = 'a Lwt.t 8 | type qos = Atmost_once | Atleast_once | Exactly_once 9 | type cxn_flags = Will_retain | Will_qos of qos | Clean_session 10 | type cxn_userpass = Username of string | UserPass of (string * string) 11 | type cxn_data = { 12 | clientid: string; 13 | userpass: cxn_userpass option; 14 | will: (string * string) option; 15 | flags: cxn_flags list; 16 | timer: int; 17 | } 18 | type cxnack_flags = Cxnack_accepted | Cxnack_protocol | Cxnack_id | 19 | Cxnack_unavail | Cxnack_userpass | Cxnack_auth 20 | type msg_data = Connect of cxn_data | Connack of cxnack_flags | 21 | Subscribe of (int * (string * qos) list) | 22 | Suback of (int * qos list) | 23 | Unsubscribe of (int * string list) | 24 | Unsuback of int | 25 | Publish of (int option * string * string) | 26 | Puback of int | Pubrec of int | Pubrel of int | 27 | Pubcomp of int | Pingreq | Pingresp | Disconnect | 28 | Asdf 29 | type pkt_opt = bool * qos * bool 30 | 31 | val connect : ?userpass:cxn_userpass -> ?will:(string * string) -> 32 | ?flags:cxn_flags list -> ?timer:int -> ?opt:pkt_opt -> 33 | string -> string 34 | 35 | val connack : ?opt:pkt_opt -> cxnack_flags -> string 36 | 37 | val publish : ?opt:pkt_opt -> ?id:int -> string -> string -> string 38 | 39 | val puback : int -> string 40 | 41 | val pubrec : int -> string 42 | 43 | val pubrel : ?opt:pkt_opt -> int -> string 44 | 45 | val pubcomp : int -> string 46 | 47 | val subscribe : ?opt:pkt_opt -> ?id:int -> (string * qos) list -> string 48 | 49 | val suback : ?opt:pkt_opt -> int -> qos list -> string 50 | 51 | val unsubscribe: ?opt:pkt_opt -> ?id:int -> string list -> string 52 | 53 | val unsuback : int -> string 54 | 55 | val pingreq : unit -> string 56 | 57 | val pingresp : unit -> string 58 | 59 | val disconnect : unit -> string 60 | 61 | val read_packet : t -> (pkt_opt * msg_data) monad 62 | 63 | val tests : OUnit.test list 64 | 65 | module MqttClient : sig 66 | type client 67 | 68 | val connect_options : ?clientid:string -> ?userpass:cxn_userpass -> ?will:(string * string) -> ?flags:cxn_flags list -> ?timer:int -> unit -> cxn_data 69 | 70 | val connect : ?opt:cxn_data -> ?error_fn:(client -> exn -> unit monad) -> ?port:int -> string -> client monad 71 | val publish : ?opt:pkt_opt -> ?id:int -> client -> string -> string -> unit monad 72 | 73 | val subscribe : ?opt:pkt_opt -> ?id:int -> client -> (string * qos) list -> unit monad 74 | 75 | val disconnect : client -> unit monad 76 | 77 | val sub_stream : client -> (string * string) Lwt_stream.t 78 | 79 | end 80 | 81 | module MqttServer : sig 82 | type t 83 | 84 | val listen : ?host:string -> ?port:int -> unit -> t monad 85 | 86 | end 87 | 88 | end = struct 89 | 90 | module BE = EndianBytes.BigEndian 91 | 92 | module ReadBuffer : sig 93 | 94 | type t 95 | val create : unit -> t 96 | val make : string -> t 97 | val add_string : t -> string -> unit 98 | val len : t -> int 99 | val read: t -> int -> string 100 | val read_string : t -> string 101 | val read_uint8 : t -> int 102 | val read_uint16 : t -> int 103 | val read_all : t -> (t -> 'a) -> 'a list 104 | val tests : OUnit.test list 105 | 106 | end = struct 107 | 108 | type t = { 109 | mutable pos: int; 110 | mutable buf: bytes; 111 | } 112 | 113 | let create () = {pos=0; buf=""} 114 | 115 | let add_string rb str = 116 | let curlen = (Bytes.length rb.buf) - rb.pos in 117 | let strlen = Bytes.length str in 118 | let newlen = strlen + curlen in 119 | let newbuf = Bytes.create newlen in 120 | Bytes.blit_string rb.buf rb.pos newbuf 0 curlen; 121 | Bytes.blit_string str 0 newbuf curlen strlen; 122 | rb.pos <- 0; 123 | rb.buf <- newbuf 124 | 125 | let make str = 126 | let rb = create () in 127 | add_string rb str; 128 | rb 129 | 130 | let len rb = (Bytes.length rb.buf) - rb.pos 131 | 132 | let read rb count = 133 | let len = (Bytes.length rb.buf) - rb.pos in 134 | if count < 0 || len < count then 135 | raise (Invalid_argument "buffer underflow"); 136 | let ret = Bytes.sub rb.buf rb.pos count in 137 | rb.pos <- rb.pos + count; 138 | ret 139 | 140 | let read_uint8 rb = 141 | let str = rb.buf in 142 | let slen = (Bytes.length str) - rb.pos in 143 | if slen < 1 then raise (Invalid_argument "string too short"); 144 | let res = BE.get_uint8 str rb.pos in 145 | rb.pos <- rb.pos + 1; 146 | res 147 | 148 | let read_uint16 rb = 149 | let str = rb.buf in 150 | let slen = (Bytes.length str) - rb.pos in 151 | if slen < 2 then raise (Invalid_argument "string too short"); 152 | let res = BE.get_uint16 str rb.pos in 153 | rb.pos <- rb.pos + 2; 154 | res 155 | 156 | let read_string rb = read_uint16 rb |> read rb 157 | 158 | let read_all rb f = 159 | let rec loop res = 160 | if (len rb) <= 0 then res 161 | else loop (f rb :: res) in 162 | loop [] 163 | 164 | module ReadBufferTests : sig 165 | val tests : OUnit.test list 166 | end = struct 167 | 168 | let test_create _ = 169 | let rb = create () in 170 | assert_equal 0 rb.pos; 171 | assert_equal "" rb.buf 172 | 173 | let test_add _ = 174 | let rb = create () in 175 | add_string rb "asdf"; 176 | assert_equal "asdf" rb.buf; 177 | add_string rb "qwerty"; 178 | assert_equal "asdfqwerty" rb.buf; 179 | (* test appends via manually resetting pos *) 180 | rb.pos <- 4; 181 | add_string rb "poiuy"; 182 | assert_equal "qwertypoiuy" rb.buf; 183 | assert_equal 0 rb.pos 184 | 185 | let test_make _ = 186 | let rb = make "asdf" in 187 | assert_equal 0 rb.pos; 188 | assert_equal "asdf" rb.buf 189 | 190 | let test_len _ = 191 | let rb = create () in 192 | assert_equal 0 (len rb); 193 | add_string rb "asdf"; 194 | assert_equal 4 (len rb); 195 | let _ = read rb 2 in 196 | assert_equal 2 (len rb); 197 | let _ = read rb 2 in 198 | assert_equal 0 (len rb) 199 | 200 | let test_read _ = 201 | let rb = create () in 202 | let exn = Invalid_argument "buffer underflow" in 203 | assert_raises exn (fun () -> read rb 1); 204 | let rb = make "asdf" in 205 | assert_raises exn (fun () -> read rb (-1)); 206 | assert_equal "" (read rb 0); 207 | assert_equal "as" (read rb 2); 208 | assert_raises exn (fun () -> read rb 3); 209 | assert_equal 2 rb.pos; 210 | assert_equal "df" (read rb 2); 211 | assert_raises exn (fun () -> read rb 1); 212 | assert_equal 4 rb.pos 213 | 214 | let test_uint8 _ = 215 | let printer = string_of_int in 216 | let rb = create () in 217 | let exn = Invalid_argument "string too short" in 218 | assert_raises exn (fun () -> read_uint8 rb); 219 | let rb = make "\001\002\255" in 220 | assert_equal 1 (read_uint8 rb); 221 | assert_equal 1 rb.pos; 222 | assert_equal 2 (read_uint8 rb); 223 | assert_equal 2 rb.pos; 224 | assert_equal ~printer 255 (read_uint8 rb) 225 | 226 | let test_int16 _ = 227 | let printer = string_of_int in 228 | let rb = create () in 229 | let exn = Invalid_argument "string too short" in 230 | assert_raises exn (fun () -> read_uint16 rb); 231 | let rb = make "\001" in 232 | assert_raises exn (fun () -> read_uint16 rb); 233 | let rb = make "\001\002" in 234 | assert_equal 258 (read_uint16 rb); 235 | let rb = make "\255\255\128" in 236 | assert_equal ~printer 65535 (read_uint16 rb) 237 | 238 | let test_readstr _ = 239 | let rb = create () in 240 | let exn1 = Invalid_argument "string too short" in 241 | let exn2 = Invalid_argument "buffer underflow" in 242 | assert_raises exn1 (fun () -> read_string rb); 243 | let rb = make "\000" in 244 | assert_raises exn1 (fun () -> read_string rb); 245 | let rb = make "\000\001" in 246 | assert_raises exn2 (fun () -> read_string rb); 247 | let rb = make "\000\004asdf\000\006qwerty" in 248 | assert_equal "asdf" (read_string rb); 249 | assert_equal 6 rb.pos; 250 | assert_equal "qwerty" (read_string rb); 251 | assert_equal 14 rb.pos 252 | 253 | let test_readall _ = 254 | let rb = make "\001\002\003\004\005" in 255 | let res = read_all rb read_uint8 in 256 | assert_equal res [5;4;3;2;1]; 257 | assert_equal 0 (len rb) 258 | 259 | let tests = [ 260 | "create">::test_create; 261 | "add">::test_add; 262 | "make">::test_make; 263 | "rb_len">::test_len; 264 | "read">::test_read; 265 | "read_uint8">::test_uint8; 266 | "read_int16">::test_int16; 267 | "read_string">::test_readstr; 268 | "read_all">::test_readall; 269 | ] 270 | 271 | end 272 | 273 | let tests = ReadBufferTests.tests 274 | 275 | end 276 | 277 | let encode_length len = 278 | let rec loop ll digits = 279 | if ll <= 0 then digits 280 | else 281 | let incr = Int32.logor (Int32.of_int 0x80) in 282 | let shft = Int32.logor (Int32.shift_left digits 8) in 283 | let getdig x dig = if x > 0 then incr dig else dig in 284 | let quotient = ll / 128 in 285 | let digit = getdig quotient (Int32.of_int (ll mod 128)) in 286 | let digits = shft digit in 287 | loop quotient digits in 288 | loop len 0l 289 | 290 | let decode_length inch = 291 | let rec loop value mult = 292 | Lwt_io.read_char inch >>= fun ch -> 293 | let ch = Char.code ch in 294 | let digit = ch land 127 in 295 | let value = value + digit * mult in 296 | let mult = mult * 128 in 297 | if ch land 128 = 0 then Lwt.return value 298 | else loop value mult in 299 | loop 0 1 300 | 301 | type t = (Lwt_io.input_channel * Lwt_io.output_channel) 302 | type 'a monad = 'a Lwt.t 303 | type messages = Connect_pkt | Connack_pkt | 304 | Publish_pkt | Puback_pkt | Pubrec_pkt | Pubrel_pkt | 305 | Pubcomp_pkt | Subscribe_pkt | Suback_pkt | 306 | Unsubscribe_pkt | Unsuback_pkt | Pingreq_pkt | 307 | Pingresp_pkt | Disconnect_pkt 308 | type qos = Atmost_once | Atleast_once | Exactly_once 309 | type cxn_flags = Will_retain | Will_qos of qos | Clean_session 310 | type cxn_userpass = Username of string | UserPass of (string * string) 311 | type cxn_data = { 312 | clientid: string; 313 | userpass: cxn_userpass option; 314 | will: (string * string) option; 315 | flags: cxn_flags list; 316 | timer: int; 317 | } 318 | type cxnack_flags = Cxnack_accepted | Cxnack_protocol | Cxnack_id | 319 | Cxnack_unavail | Cxnack_userpass | Cxnack_auth 320 | type msg_data = Connect of cxn_data | Connack of cxnack_flags | 321 | Subscribe of (int * (string * qos) list) | 322 | Suback of (int * qos list) | 323 | Unsubscribe of (int * string list) | 324 | Unsuback of int | 325 | Publish of (int option * string * string) | 326 | Puback of int | Pubrec of int | Pubrel of int | 327 | Pubcomp of int | Pingreq | Pingresp | Disconnect | 328 | Asdf 329 | type pkt_opt = bool * qos * bool 330 | 331 | let msgid = ref 0 332 | let gen_id () = 333 | let () = incr msgid in 334 | if !msgid >= 0xFFFF then msgid := 1; 335 | !msgid 336 | 337 | let int16be n = 338 | let s = Bytes.create 2 in 339 | BE.set_int16 s 0 n; 340 | s 341 | 342 | let int8be n = 343 | let s = Bytes.create 1 in 344 | BE.set_int8 s 0 n; 345 | s 346 | 347 | let trunc str = 348 | (* truncate leading zeroes *) 349 | let len = String.length str in 350 | let rec loop count = 351 | if count >= len || str.[count] <> '\000' then count 352 | else loop (count + 1) in 353 | let leading = loop 0 in 354 | if leading = len then "\000" 355 | else String.sub str leading (len - leading) 356 | 357 | let addlen s = 358 | let len = String.length s in 359 | if len > 0xFFFF then raise (Invalid_argument "string too long"); 360 | (int16be len) ^ s 361 | 362 | let opt_with s n = function 363 | | Some a -> s a 364 | | None -> n 365 | 366 | let bits_of_message = function 367 | | Connect_pkt -> 1 368 | | Connack_pkt -> 2 369 | | Publish_pkt -> 3 370 | | Puback_pkt -> 4 371 | | Pubrec_pkt -> 5 372 | | Pubrel_pkt -> 6 373 | | Pubcomp_pkt -> 7 374 | | Subscribe_pkt -> 8 375 | | Suback_pkt -> 9 376 | | Unsubscribe_pkt -> 10 377 | | Unsuback_pkt -> 11 378 | | Pingreq_pkt -> 12 379 | | Pingresp_pkt -> 13 380 | | Disconnect_pkt -> 14 381 | 382 | let message_of_bits = function 383 | | 1 -> Connect_pkt 384 | | 2 -> Connack_pkt 385 | | 3 -> Publish_pkt 386 | | 4 -> Puback_pkt 387 | | 5 -> Pubrec_pkt 388 | | 6 -> Pubrel_pkt 389 | | 7 -> Pubcomp_pkt 390 | | 8 -> Subscribe_pkt 391 | | 9 -> Suback_pkt 392 | | 10 -> Unsubscribe_pkt 393 | | 11 -> Unsuback_pkt 394 | | 12 -> Pingreq_pkt 395 | | 13 -> Pingresp_pkt 396 | | 14 -> Disconnect_pkt 397 | | _ -> raise (Invalid_argument "invalid bits in message") 398 | 399 | let bits_of_qos = function 400 | | Atmost_once -> 0 401 | | Atleast_once -> 1 402 | | Exactly_once -> 2 403 | 404 | let qos_of_bits = function 405 | | 0 -> Atmost_once 406 | | 1 -> Atleast_once 407 | | 2 -> Exactly_once 408 | | _ -> raise (Invalid_argument "invalid qos number") 409 | 410 | let bit_of_bool = function 411 | | true -> 1 412 | | false -> 0 413 | 414 | let bool_of_bit = function 415 | | 1 -> true 416 | | 0 -> false 417 | | _ -> raise (Invalid_argument "bit not zero or one") 418 | 419 | let connack_of_bits = function 420 | | 0 -> Cxnack_accepted 421 | | 1 -> Cxnack_protocol 422 | | 2 -> Cxnack_id 423 | | 3 -> Cxnack_unavail 424 | | 4 -> Cxnack_userpass 425 | | 5 -> Cxnack_auth 426 | | _ -> raise (Invalid_argument "connack flag unrecognized") 427 | 428 | let bits_of_connack = function 429 | | Cxnack_accepted -> 0 430 | | Cxnack_protocol -> 1 431 | | Cxnack_id -> 2 432 | | Cxnack_unavail -> 3 433 | | Cxnack_userpass -> 4 434 | | Cxnack_auth -> 5 435 | 436 | let fixed_header typ (parms:pkt_opt) body_len = 437 | let (dup, qos, retain) = parms in 438 | let msgid = (bits_of_message typ) lsl 4 in 439 | let dup = (bit_of_bool dup) lsl 3 in 440 | let qos = (bits_of_qos qos) lsl 1 in 441 | let retain = bit_of_bool retain in 442 | let hdr = Bytes.create 1 in 443 | let len = Bytes.create 4 in 444 | BE.set_int8 hdr 0 (msgid + dup + qos + retain); 445 | BE.set_int32 len 0 (encode_length body_len); 446 | let len = trunc len in 447 | hdr ^ len 448 | 449 | let connect_payload ?userpass ?will ?(flags = []) ?(timer = 10) id = 450 | let name = addlen "MQIsdp" in 451 | let version = "\003" in 452 | if timer > 0xFFFF then raise (Invalid_argument "timer too large"); 453 | let addhdr2 flag term (flags, hdr) = match term with 454 | | None -> flags, hdr 455 | | Some (a, b) -> (flags lor flag), 456 | (hdr ^ (addlen a) ^ (addlen b)) in 457 | let adduserpass term (flags, hdr) = match term with 458 | | None -> flags, hdr 459 | | Some (Username s) -> (flags lor 0x80), (hdr ^ addlen s) 460 | | Some (UserPass up) -> 461 | addhdr2 0xC0 (Some up) (flags, hdr) in 462 | let flag_nbr = function 463 | | Clean_session -> 0x02 464 | | Will_qos qos -> (bits_of_qos qos) lsl 3 465 | | Will_retain -> 0x20 in 466 | let accum a acc = acc lor (flag_nbr a) in 467 | let flags, pay = 468 | ((List.fold_right accum flags 0), (addlen id)) 469 | |> addhdr2 0x04 will |> adduserpass userpass in 470 | let tbuf = int16be timer in 471 | let fbuf = Bytes.create 1 in 472 | BE.set_int8 fbuf 0 flags; 473 | let accum acc a = acc + (Bytes.length a) in 474 | let fields = [name; version; fbuf; tbuf; pay] in 475 | let lens = List.fold_left accum 0 fields in 476 | let buf = Buffer.create lens in 477 | List.iter (Buffer.add_string buf) fields; 478 | Buffer.contents buf 479 | 480 | let connect ?userpass ?will ?flags ?timer ?(opt = (false, Atmost_once, false)) id = 481 | let cxn_pay = connect_payload ?userpass ?will ?flags ?timer id in 482 | let hdr = fixed_header Connect_pkt opt (String.length cxn_pay) in 483 | hdr ^ cxn_pay 484 | 485 | let connect_data d = 486 | let clientid = d.clientid in 487 | let userpass = d.userpass in 488 | let will = d.will in 489 | let flags = d.flags in 490 | let timer = d.timer in 491 | connect_payload ?userpass ?will ~flags ~timer clientid 492 | 493 | let connack ?(opt = (false, Atmost_once, false)) flag = 494 | let hdr = fixed_header Connack_pkt opt 2 in 495 | let varhdr = bits_of_connack flag |> int16be in 496 | hdr ^ varhdr 497 | 498 | let publish ?(opt = (false, Atmost_once, false)) ?(id = -1) topic payload = 499 | let (_, qos, _) = opt in 500 | let msgid = 501 | if qos = Atleast_once || qos = Exactly_once then 502 | let mid = if id = -1 then gen_id () 503 | else id in int16be mid 504 | else "" in 505 | let topic = addlen topic in 506 | let sl = String.length in 507 | let tl = sl topic + sl payload + sl msgid in 508 | let buf = Buffer.create (tl + 5) in 509 | let hdr = fixed_header Publish_pkt opt tl in 510 | Buffer.add_string buf hdr; 511 | Buffer.add_string buf topic; 512 | Buffer.add_string buf msgid; 513 | Buffer.add_string buf payload; 514 | Buffer.contents buf 515 | 516 | let pubpkt ?(opt = (false, Atmost_once, false)) typ id = 517 | let hdr = fixed_header typ opt 2 in 518 | let msgid = int16be id in 519 | let buf = Buffer.create 4 in 520 | Buffer.add_string buf hdr; 521 | Buffer.add_string buf msgid; 522 | Buffer.contents buf 523 | 524 | let puback = pubpkt Puback_pkt 525 | 526 | let pubrec = pubpkt Pubrec_pkt 527 | 528 | let pubrel ?opt = pubpkt ?opt Pubrel_pkt 529 | 530 | let pubcomp = pubpkt Pubcomp_pkt 531 | 532 | let subscribe ?(opt = (false, Atleast_once, false)) ?(id = gen_id ()) topics = 533 | let accum acc (i, _) = acc + 3 + String.length i in 534 | let tl = List.fold_left accum 0 topics in 535 | let tl = tl + 2 in (* add msgid to total len *) 536 | let buf = Buffer.create (tl + 5) in (* ~5 for fixed header *) 537 | let addtopic (t, q) = 538 | Buffer.add_string buf (addlen t); 539 | Buffer.add_string buf (int8be (bits_of_qos q)) in 540 | let msgid = int16be id in 541 | let hdr = fixed_header Subscribe_pkt opt tl in 542 | Buffer.add_string buf hdr; 543 | Buffer.add_string buf msgid; 544 | List.iter addtopic topics; 545 | Buffer.contents buf 546 | 547 | let suback ?(opt = (false, Atmost_once, false)) id qoses = 548 | let paylen = (List.length qoses) + 2 in 549 | let buf = Buffer.create (paylen + 5) in 550 | let msgid = int16be id in 551 | let q2i q = bits_of_qos q |> int8be in 552 | let blit q = q2i q |> Buffer.add_string buf in 553 | let hdr = fixed_header Suback_pkt opt paylen in 554 | Buffer.add_string buf hdr; 555 | Buffer.add_string buf msgid; 556 | List.iter blit qoses; 557 | Buffer.contents buf 558 | 559 | let unsubscribe ?(opt = (false, Atleast_once, false)) ?(id = gen_id ()) topics = 560 | let accum acc i = acc + 2 + String.length i in 561 | let tl = List.fold_left accum 2 topics in (* +2 for msgid *) 562 | let buf = Buffer.create (tl + 5) in (* ~5 for fixed header *) 563 | let addtopic t = addlen t |> Buffer.add_string buf in 564 | let msgid = int16be id in 565 | let hdr = fixed_header Unsubscribe_pkt opt tl in 566 | Buffer.add_string buf hdr; 567 | Buffer.add_string buf msgid; 568 | List.iter addtopic topics; 569 | Buffer.contents buf 570 | 571 | let unsuback id = 572 | let msgid = int16be id in 573 | let opt = (false, Atmost_once, false) in 574 | let hdr = fixed_header Unsuback_pkt opt 2 in 575 | hdr ^ msgid 576 | 577 | let simple_pkt typ = fixed_header typ (false, Atmost_once, false) 0 578 | 579 | let pingreq () = simple_pkt Pingreq_pkt 580 | 581 | let pingresp () = simple_pkt Pingresp_pkt 582 | 583 | let disconnect () = simple_pkt Disconnect_pkt 584 | 585 | let decode_connect rb = 586 | let lead = ReadBuffer.read rb 9 in 587 | if "\000\006MQIsdp\003" <> lead then 588 | raise (Invalid_argument "invalid MQIsdp or version"); 589 | let hdr = ReadBuffer.read_uint8 rb in 590 | let timer = ReadBuffer.read_uint16 rb in 591 | let has_username = 0 <> (hdr land 0x80) in 592 | let has_password = 0 <> (hdr land 0xC0) in 593 | let will_flag = bool_of_bit ((hdr land 0x04) lsr 2) in 594 | let will_retain = will_flag && 0 <> (hdr land 0x20) in 595 | let will_qos = if will_flag then 596 | Some (qos_of_bits ((hdr land 0x18) lsr 3)) else None in 597 | let clean_session = bool_of_bit ((hdr land 0x02) lsr 1) in 598 | let rs = ReadBuffer.read_string in 599 | let clientid = rs rb in 600 | let will = if will_flag then 601 | let t = rs rb in 602 | let m = rs rb in 603 | Some (t, m) 604 | else None in 605 | let userpass = if has_password then 606 | let u = rs rb in 607 | let p = rs rb in 608 | Some (UserPass (u, p)) 609 | else if has_username then Some (Username (rs rb)) 610 | else None in 611 | let flags = if clean_session then [ Clean_session ] else [] in 612 | let flags = opt_with (fun qos -> (Will_qos qos) :: flags ) flags will_qos in 613 | let flags = if will_retain then Will_retain :: flags else flags in 614 | Connect {clientid; userpass; will; flags; timer;} 615 | 616 | let decode_connack rb = 617 | let res = ReadBuffer.read_uint16 rb |> connack_of_bits in 618 | Connack res 619 | 620 | let decode_publish (_, qos, _) rb = 621 | let topic = ReadBuffer.read_string rb in 622 | let msgid = if qos = Atleast_once || qos = Exactly_once then 623 | Some (ReadBuffer.read_uint16 rb) 624 | else None in 625 | let payload = ReadBuffer.len rb |> ReadBuffer.read rb in 626 | Publish (msgid, topic, payload) 627 | 628 | let decode_puback rb = Puback (ReadBuffer.read_uint16 rb) 629 | 630 | let decode_pubrec rb = Pubrec (ReadBuffer.read_uint16 rb) 631 | 632 | let decode_pubrel rb = Pubrel (ReadBuffer.read_uint16 rb) 633 | 634 | let decode_pubcomp rb = Pubcomp (ReadBuffer.read_uint16 rb) 635 | 636 | let decode_subscribe rb = 637 | let id = ReadBuffer.read_uint16 rb in 638 | let get_topic rb = 639 | let topic = ReadBuffer.read_string rb in 640 | let qos = ReadBuffer.read_uint8 rb |> qos_of_bits in 641 | (topic, qos) in 642 | let topics = ReadBuffer.read_all rb get_topic in 643 | Subscribe (id, topics) 644 | 645 | let decode_suback rb = 646 | let id = ReadBuffer.read_uint16 rb in 647 | let get_qos rb = ReadBuffer.read_uint8 rb |> qos_of_bits in 648 | let qoses = ReadBuffer.read_all rb get_qos in 649 | Suback (id, List.rev qoses) 650 | 651 | let decode_unsub rb = 652 | let id = ReadBuffer.read_uint16 rb in 653 | let topics = ReadBuffer.read_all rb ReadBuffer.read_string in 654 | Unsubscribe (id, topics) 655 | 656 | let decode_unsuback rb = Unsuback (ReadBuffer.read_uint16 rb) 657 | 658 | let decode_pingreq rb = Pingreq 659 | 660 | let decode_pingresp rb = Pingresp 661 | 662 | let decode_disconnect rb = Disconnect 663 | 664 | let decode_packet opts = function 665 | | Connect_pkt -> decode_connect 666 | | Connack_pkt -> decode_connack 667 | | Publish_pkt -> decode_publish opts 668 | | Puback_pkt -> decode_puback 669 | | Pubrec_pkt -> decode_pubrec 670 | | Pubrel_pkt -> decode_pubrel 671 | | Pubcomp_pkt -> decode_pubcomp 672 | | Subscribe_pkt -> decode_subscribe 673 | | Suback_pkt -> decode_suback 674 | | Unsubscribe_pkt -> decode_unsub 675 | | Unsuback_pkt -> decode_unsuback 676 | | Pingreq_pkt -> decode_pingreq 677 | | Pingresp_pkt -> decode_pingresp 678 | | Disconnect_pkt -> decode_disconnect 679 | 680 | let decode_fixed_header byte : messages * pkt_opt = 681 | let typ = (byte land 0xF0) lsr 4 in 682 | let dup = (byte land 0x08) lsr 3 in 683 | let qos = (byte land 0x04) lsr 2 in 684 | let retain = byte land 0x01 in 685 | let typ = message_of_bits typ in 686 | let dup = bool_of_bit dup in 687 | let qos = qos_of_bits qos in 688 | let retain = bool_of_bit retain in 689 | (typ, (dup, qos, retain)) 690 | 691 | let read_packet ctx = 692 | let (inch, _) = ctx in 693 | Lwt_io.read_char inch >>= fun ch -> 694 | let (msgid, opts) = Char.code ch |> decode_fixed_header in 695 | decode_length inch >>= fun count -> 696 | let data = Bytes.create count in 697 | let rd = try Lwt_io.read_into_exactly inch data 0 count 698 | with End_of_file -> Lwt.fail (Failure "could not read bytes") in 699 | rd >>= fun () -> 700 | let pkt = ReadBuffer.make data |> decode_packet opts msgid in 701 | Lwt.return (opts, pkt) 702 | 703 | module MqttTests : sig 704 | 705 | val tests : OUnit.test list 706 | 707 | end = struct 708 | 709 | let test_encode _ = 710 | assert_equal 0l (encode_length 0); 711 | assert_equal 0x7Fl (encode_length 127); 712 | assert_equal 0x8001l (encode_length 128); 713 | assert_equal 0xFF7Fl (encode_length 16383); 714 | assert_equal 0x808001l (encode_length 16384); 715 | assert_equal 0xFFFF7Fl (encode_length 2097151); 716 | assert_equal 0x80808001l (encode_length 2097152); 717 | assert_equal 0xFFFFFF7Fl (encode_length 268435455) 718 | 719 | let test_decode_in = 720 | let equals inp = 721 | let printer = string_of_int in 722 | let buf = Bytes.create 4 in 723 | BE.set_int32 buf 0 (encode_length inp); 724 | let buf = Lwt_bytes.of_bytes (trunc buf) in 725 | let inch = Lwt_io.of_bytes Lwt_io.input buf in 726 | decode_length inch >>= fun len -> 727 | assert_equal ~printer inp len; 728 | Lwt.return_unit in 729 | let tests = [0; 127; 128; 16383; 16384; 2097151; 2097152; 268435455] in 730 | Lwt_list.iter_p equals tests 731 | 732 | let test_decode _ = Lwt_main.run test_decode_in 733 | 734 | let test_header _ = 735 | let hdr = fixed_header Disconnect_pkt (true, Exactly_once, true) 99 in 736 | assert_equal "\237\099" hdr; 737 | let hdr = fixed_header Connect_pkt (false, Atmost_once, false) 255 in 738 | assert_equal "\016\255\001" hdr 739 | 740 | let test_connect _ = 741 | let pkt = connect_payload "1" in 742 | assert_equal "\000\006MQIsdp\003\000\000\n\000\0011" pkt; 743 | let pkt = connect_payload ~timer:11 "11" in 744 | assert_equal "\000\006MQIsdp\003\000\000\011\000\00211" pkt; 745 | let pkt () = connect_payload ~timer:0x10000 "111" in 746 | assert_raises (Invalid_argument "timer too large") pkt; 747 | let pkt = connect_payload ~userpass:(Username "bob") "2" in 748 | assert_equal "\000\006MQIsdp\003\128\000\n\000\0012\000\003bob" pkt; 749 | let lstr = Bytes.create 0x10000 in (* long string *) 750 | let pkt () = connect_payload ~userpass:(Username lstr) "22" in 751 | assert_raises (Invalid_argument "string too long") pkt; 752 | let pkt = connect_payload ~userpass:(UserPass ("", "alice")) "3" in 753 | assert_equal "\000\006MQIsdp\003\192\000\n\000\0013\000\000\000\005alice" pkt; 754 | let pkt () = connect_payload ~userpass:(UserPass ("", lstr)) "33" in 755 | assert_raises (Invalid_argument "string too long") pkt; 756 | let pkt = connect_payload ~will:("a","b") "4" in 757 | assert_equal "\000\006MQIsdp\003\004\000\n\000\0014\000\001a\000\001b" pkt; 758 | let pkt () = connect_payload ~will:(lstr,"") "44" in 759 | assert_raises (Invalid_argument "string too long") pkt; 760 | let pkt () = connect_payload ~will:("",lstr) "444" in 761 | assert_raises (Invalid_argument "string too long") pkt; 762 | let pkt = connect_payload ~will:("", "") ~userpass:(UserPass ("", "")) ~flags:[Will_retain; Will_qos Exactly_once; Clean_session] "5" in 763 | assert_equal "\000\006MQIsdp\003\246\000\n\000\0015\000\000\000\000\000\000\000\000" pkt 764 | 765 | let test_fixed_dec _ = 766 | let printer p = bits_of_message p |> string_of_int in 767 | let msg, opt = decode_fixed_header 0x10 in 768 | let (dup, qos, retain) = opt in 769 | assert_equal ~printer Connect_pkt msg; 770 | assert_equal false dup; 771 | assert_equal Atmost_once qos; 772 | assert_equal false retain; 773 | let (msg, opt) = decode_fixed_header 0xED in 774 | let (dup, qos, retain) = opt in 775 | assert_equal ~printer Disconnect_pkt msg; 776 | assert_equal true dup; 777 | assert_equal Atleast_once qos; 778 | assert_equal true retain; 779 | () 780 | 781 | let print_cxn_data = function Connect cd -> 782 | let clientid = cd.clientid in 783 | let userpass = opt_with (function Username u -> u | UserPass (u, p) -> u^"_"^p) "none" cd.userpass in 784 | let will = opt_with (fun (t, m) -> t^"_"^m) "will:none" cd.will in 785 | let timer = cd.timer in 786 | let f2s = function 787 | | Will_retain -> "retain" 788 | | Clean_session -> "session" 789 | | Will_qos qos -> string_of_int (bits_of_qos qos) in 790 | let flags = String.concat "," (List.map f2s cd.flags) in 791 | Printf.sprintf "%s %s %s %s %d" clientid userpass will flags timer 792 | |_ -> "" 793 | 794 | let test_cxn_dec _ = 795 | let printer = print_cxn_data in 796 | let clientid = "asdf" in 797 | let userpass = None in 798 | let will = None in 799 | let flags = [] in 800 | let timer = 2000 in 801 | let d = {clientid; userpass; will; flags; timer} in 802 | let res = connect_data d |> ReadBuffer.make |> decode_connect in 803 | assert_equal (Connect d) res; 804 | let userpass = Some (UserPass ("qwerty", "supersecret")) in 805 | let will = Some ("topic", "go in peace") in 806 | let flags = [ Will_retain ; (Will_qos Atleast_once) ; Clean_session] in 807 | let d = {clientid; userpass; will; flags; timer} in 808 | let res = connect_data d |> ReadBuffer.make |> decode_connect in 809 | assert_equal ~printer (Connect d) res 810 | 811 | let test_connack _ = 812 | let s = [ Cxnack_accepted; Cxnack_protocol; Cxnack_id; Cxnack_unavail; Cxnack_userpass; Cxnack_auth ] in 813 | let i2rb i = " \002" ^ (int16be i) in 814 | List.iteri (fun i a -> connack a |> assert_equal (i2rb i)) s 815 | 816 | let test_cxnack_dec _ = 817 | let s = [ Cxnack_accepted; Cxnack_protocol; Cxnack_id; Cxnack_unavail; Cxnack_userpass; Cxnack_auth ] in 818 | let i2rb i = int16be i |> ReadBuffer.make |> decode_connack in 819 | List.iteri (fun i a -> i2rb i |> assert_equal (Connack a)) s; 820 | assert_raises (Invalid_argument "connack flag unrecognized") (fun () -> i2rb 7) 821 | 822 | let test_pub _ = 823 | let res = publish "a" "b" in 824 | let m = "0\004\000\001ab" in 825 | assert_equal m res; 826 | let res = publish ~id:7 "a" "b" in 827 | assert_equal m res; 828 | let res = publish ~opt:(false, Atleast_once, false) ~id:7 "a" "b" in 829 | let m = "2\006\000\001a\000\007b" in 830 | assert_equal m res; 831 | let res = publish ~opt:(false, Exactly_once, false) ~id:7 "a" "b" in 832 | let m = "4\006\000\001a\000\007b" in 833 | assert_equal m res 834 | 835 | let test_pub_dec _ = 836 | let m = "\000\001abcdef" in 837 | let opt = (false, Atmost_once, false) in 838 | let res = ReadBuffer.make m |> decode_publish opt in 839 | let expected = Publish (None, "a", "bcdef") in 840 | assert_equal expected res; 841 | let m = "\000\001a\000\007bcdef" in 842 | let res = ReadBuffer.make m |> decode_publish opt in 843 | let expected = Publish (None, "a", "\000\007bcdef") in 844 | assert_equal expected res; 845 | let opt = (false, Atleast_once, false) in 846 | let res = ReadBuffer.make m |> decode_publish opt in 847 | let expected = Publish (Some 7, "a", "bcdef") in 848 | assert_equal expected res; 849 | let opt = (false, Exactly_once, false) in 850 | let res = ReadBuffer.make m |> decode_publish opt in 851 | assert_equal expected res 852 | 853 | let test_puback _ = 854 | let m = "@\002\000\007" in 855 | let res = puback 7 in 856 | assert_equal m res 857 | 858 | let test_puback_dec _ = 859 | let m = "\000\007" in 860 | let res = ReadBuffer.make m |> decode_puback in 861 | let expected = Puback 7 in 862 | assert_equal expected res 863 | 864 | let test_pubrec _ = 865 | let m = "P\002\000\007" in 866 | let res = pubrec 7 in 867 | assert_equal m res 868 | 869 | let test_pubrec_dec _ = 870 | let m = "\000\007" in 871 | let res = ReadBuffer.make m |> decode_pubrec in 872 | let expected = Pubrec 7 in 873 | assert_equal expected res 874 | 875 | let test_pubrel _ = 876 | let m = "`\002\000\007" in 877 | let res = pubrel 7 in 878 | assert_equal m res; 879 | let m = "h\002\000\007" in 880 | let res = pubrel ~opt:(true, Atmost_once, false) 7 in 881 | assert_equal m res 882 | 883 | let test_pubrel_dec _ = 884 | let m = "\000\007" in 885 | let res = ReadBuffer.make m |> decode_pubrel in 886 | let expected = Pubrel 7 in 887 | assert_equal expected res 888 | 889 | let test_pubcomp _ = 890 | let m = "p\002\000\007" in 891 | let res = pubcomp 7 in 892 | assert_equal m res 893 | 894 | let test_pubcomp_dec _ = 895 | let m = "\000\007" in 896 | let res = ReadBuffer.make m |> decode_pubcomp in 897 | let expected = Pubcomp 7 in 898 | assert_equal expected res 899 | 900 | let test_subscribe _ = 901 | let q = ["asdf"; "qwerty"; "poiuy"; "mnbvc"; "zxcvb"] in 902 | let foo = List.map (fun z -> (z, Atmost_once)) q in 903 | let res = subscribe ~id:7 foo in 904 | assert_equal "\130*\000\007\000\004asdf\000\000\006qwerty\000\000\005poiuy\000\000\005mnbvc\000\000\005zxcvb\000" res 905 | 906 | let test_sub_dec _ = 907 | let topics = [("c", Atmost_once); ("b", Atmost_once); ("a", Atmost_once)] in 908 | let m = "\000\007\000\001a\000\000\001b\000\000\001c\000" in 909 | let res = ReadBuffer.make m |> decode_subscribe in 910 | let expected = Subscribe (7, topics) in 911 | assert_equal expected res 912 | 913 | let test_suback _ = 914 | let s = suback 7 [Atmost_once; Exactly_once; Atleast_once] in 915 | let m = "\144\005\000\007\000\002\001" in 916 | assert_equal m s; 917 | let s = suback 7 [] in 918 | let m = "\144\002\000\007" in 919 | assert_equal m s 920 | 921 | let test_suback_dec _ = 922 | let m = "\000\007\000\001\002" in 923 | let res = ReadBuffer.make m |> decode_suback in 924 | let expected = Suback (7, [Atmost_once; Atleast_once; Exactly_once]) in 925 | assert_equal expected res 926 | 927 | let test_unsub _ = 928 | let m = "\162\b\000\007\000\001a\000\001b" in 929 | let res = unsubscribe ~id:7 ["a";"b"] in 930 | assert_equal m res 931 | 932 | let test_unsub_dec _ = 933 | let m = "\000\007\000\001a\000\001b" in 934 | let res = ReadBuffer.make m |> decode_unsub in 935 | let expected = Unsubscribe (7, ["b";"a"]) in 936 | assert_equal expected res 937 | 938 | let test_unsuback _ = 939 | let m = "\176\002\000\007" in 940 | let res = unsuback 7 in 941 | assert_equal m res 942 | 943 | let test_unsuback_dec _ = 944 | let m = "\000\007" in 945 | let res = ReadBuffer.make m |> decode_unsuback in 946 | let expected = Unsuback 7 in 947 | assert_equal expected res 948 | 949 | let test_pingreq _ = assert_equal "\192\000" (pingreq ()) 950 | 951 | let test_pingreq_dec _ = 952 | assert_equal Pingreq (ReadBuffer.make "" |> decode_pingreq) 953 | 954 | let test_pingresp _ = assert_equal "\208\000" (pingresp ()) 955 | 956 | let test_pingresp_dec _ = 957 | assert_equal Pingresp (ReadBuffer.make "" |> decode_pingresp) 958 | 959 | let test_disconnect _ = assert_equal "\224\000" (disconnect ()) 960 | 961 | let test_disconnect_dec _ = 962 | assert_equal Disconnect (ReadBuffer.make "" |> decode_disconnect) 963 | 964 | let tests = [ 965 | "encode">::test_encode; 966 | "decode">::test_decode; 967 | "hdr">::test_header; 968 | "connect">::test_connect; 969 | "decode fixed">::test_fixed_dec; 970 | "decode_cxn">::test_cxn_dec; 971 | "connack">::test_connack; 972 | "decode_cxnack">::test_cxnack_dec; 973 | "publish">::test_pub; 974 | "decode_pub">::test_pub_dec; 975 | "puback">::test_puback; 976 | "decode_puback">::test_puback_dec; 977 | "pubrec">::test_pubrec; 978 | "decode_pubrec">::test_pubrec_dec; 979 | "pubrel">::test_pubrel; 980 | "decode_pubrel">::test_pubrel_dec; 981 | "pubcomp">::test_pubcomp; 982 | "decode_pubcomp">::test_pubcomp_dec; 983 | "subscribe">::test_subscribe; 984 | "decode_sub">::test_sub_dec; 985 | "suback">::test_suback; 986 | "decode_suback">::test_suback_dec; 987 | "unsub">::test_unsub; 988 | "decode_unsub">::test_unsub_dec; 989 | "unsuback">::test_unsuback; 990 | "decode_unsuback">::test_unsuback_dec; 991 | "pingreq">::test_pingreq; 992 | "decode_pingreq">::test_pingreq_dec; 993 | "pingresp">::test_pingresp; 994 | "decode_pingresp">::test_pingresp_dec; 995 | "disconnect">::test_disconnect; 996 | "decode_disc">::test_disconnect_dec; 997 | ] 998 | 999 | end 1000 | 1001 | let tests = ReadBuffer.tests @ MqttTests.tests 1002 | 1003 | module MqttClient = struct 1004 | 1005 | let string_of_cxnack_flag = function 1006 | | Cxnack_accepted -> "accepted" 1007 | | Cxnack_protocol -> "invalid protocol" 1008 | | Cxnack_id -> "invalid id" 1009 | | Cxnack_unavail -> "service unavailable" 1010 | | Cxnack_userpass -> "invalid userpass" 1011 | | Cxnack_auth -> "invalid auth" 1012 | 1013 | type client = { 1014 | cxn : t; 1015 | stream: (string * string) Lwt_stream.t; 1016 | push : ((string * string) option -> unit); 1017 | inflight : (int, (int Lwt_condition.t * msg_data)) Hashtbl.t; 1018 | mutable reader : unit Lwt.t; 1019 | mutable pinger : unit Lwt.t; 1020 | error_fn : (client -> exn -> unit Lwt.t); 1021 | } 1022 | 1023 | let default_error_fn client exn = 1024 | Printexc.to_string exn |> Lwt_io.printlf "mqtt error: %s" 1025 | 1026 | let connect_options ?(clientid = "OCamlMQTT") ?userpass ?will ?(flags= [Clean_session]) ?(timer = 10) () = 1027 | { clientid; userpass; will; flags; timer} 1028 | 1029 | let read_packets client () = 1030 | let cxn = client.cxn in 1031 | let ack_inflight id pkt_data = 1032 | try let (cond, data) = Hashtbl.find client.inflight id in 1033 | if pkt_data = data then begin 1034 | Hashtbl.remove client.inflight id; 1035 | Lwt_condition.signal cond id; 1036 | Lwt.return_unit 1037 | end else Lwt.fail (Failure "unexpected packet in ack") 1038 | with exn -> Lwt.fail (Failure "ack not found") in 1039 | let push topic pay = Some (topic, pay) |> client.push |> Lwt.return in 1040 | let push_id id pkt_data topic pay = 1041 | ack_inflight id pkt_data >>= fun () -> push topic pay in 1042 | let rec loop g = 1043 | read_packet cxn >>= fun (_, pkt) -> 1044 | (match pkt with 1045 | | Publish (None, topic, payload) -> push topic payload 1046 | | Publish (Some id, topic, payload) -> push_id id pkt topic payload 1047 | | Suback (id, _) | Unsuback id | Puback id | Pubrec id | 1048 | Pubrel id | Pubcomp id -> ack_inflight id pkt 1049 | | Pingresp -> Lwt.return_unit 1050 | | _ -> Lwt.fail (Failure "Unknown packet from server")) >>= fun _ -> 1051 | loop g in 1052 | loop () 1053 | 1054 | let wrap_catch client f = client.error_fn client |> Lwt.catch f 1055 | 1056 | let pinger cxn timeout () = 1057 | let (_, oc) = cxn in 1058 | let tmo = 0.9 *. (float_of_int timeout) in (* 10% leeway *) 1059 | let rec loop g = 1060 | Lwt_unix.sleep tmo >>= fun () -> 1061 | pingreq () |> Lwt_io.write oc >>= fun () -> 1062 | loop g in 1063 | loop () 1064 | 1065 | let connect ?(opt = connect_options ()) ?(error_fn = default_error_fn) ?(port = 1883) host = 1066 | Lwt_unix.gethostbyname host >>= fun hostent -> 1067 | let haddr = hostent.Lwt_unix.h_addr_list.(0) in 1068 | let addr = Lwt_unix.ADDR_INET(haddr, port) in 1069 | let s = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 1070 | Lwt_unix.connect s addr >>= fun () -> 1071 | let ic = Lwt_io.of_fd ~mode:Lwt_io.input s in 1072 | let oc = Lwt_io.of_fd ~mode:Lwt_io.output s in 1073 | let cxn = (ic, oc) in 1074 | let cd = connect ?userpass:opt.userpass ?will:opt.will ~flags:opt.flags ~timer:opt.timer opt.clientid in 1075 | Lwt_io.write oc cd >>= fun () -> 1076 | let stream, push = Lwt_stream.create () in 1077 | let inflight = Hashtbl.create 100 in 1078 | read_packet cxn >>= function 1079 | | (_, Connack Cxnack_accepted) -> 1080 | let ping = Lwt.return_unit in 1081 | let reader = Lwt.return_unit in 1082 | let client = { cxn; stream; push; inflight; reader; pinger=ping; error_fn; } in 1083 | let pinger = wrap_catch client (pinger cxn opt.timer) in 1084 | let reader = wrap_catch client (read_packets client) in 1085 | client.pinger <- pinger; 1086 | client.reader <- reader; 1087 | Lwt.return client 1088 | | (_, Connack s) -> Failure (string_of_cxnack_flag s) |> Lwt.fail 1089 | | _ -> Failure ("Unknown packet type received after conn") |> Lwt.fail 1090 | 1091 | let publish ?opt ?id client topic payload = 1092 | let (_, oc) = client.cxn in 1093 | let pd = publish ?opt ?id topic payload in 1094 | Lwt_io.write oc pd 1095 | 1096 | let subscribe ?opt ?id client topics = 1097 | let (_, oc) = client.cxn in 1098 | let sd = subscribe ?opt ?id topics in 1099 | let qoses = List.map (fun (_, q) -> q) topics in 1100 | let mid = !msgid in 1101 | let cond = Lwt_condition.create () in 1102 | Hashtbl.add client.inflight mid (cond, (Suback (mid, qoses))); 1103 | wrap_catch client (fun () -> 1104 | Lwt_io.write oc sd >>= fun () -> 1105 | Lwt_condition.wait cond >>= fun _ -> 1106 | Lwt.return_unit) 1107 | 1108 | let disconnect client = 1109 | let (ic, oc) = client.cxn in 1110 | disconnect () |> Lwt_io.write oc >>= fun () -> 1111 | (* push None to client; stop reader and pinger ?? *) 1112 | let catch f = Lwt.catch (fun () -> f) (function _ -> Lwt.return_unit) in 1113 | Lwt_io.close ic |> catch >>= fun () -> 1114 | Lwt_io.close oc |> catch 1115 | 1116 | let sub_stream client = client.stream 1117 | 1118 | end 1119 | 1120 | module MqttServer = struct 1121 | 1122 | type t = Lwt_io.server 1123 | 1124 | let () = 1125 | let open Sys in 1126 | set_signal sigpipe Signal_ignore 1127 | 1128 | let cxns = ref [] 1129 | 1130 | let handle_sub outch s = 1131 | cxns := outch :: !cxns; 1132 | let (msgid, list) = s in 1133 | let qoses = List.map (fun (_, q) -> q) list in 1134 | suback msgid qoses |> Lwt_io.write outch 1135 | 1136 | let handle_pub p = 1137 | let (_, topic, payload) = p in 1138 | let s = publish topic payload in 1139 | let write ch = Lwt_io.write ch s in 1140 | Lwt_list.iter_p write !cxns 1141 | 1142 | let srv_cxn cxn = 1143 | let (inch, outch) = cxn in 1144 | Lwt.catch (fun () -> 1145 | read_packet cxn >>= (function 1146 | | (_, Connect _) -> connack Cxnack_accepted |> Lwt_io.write outch 1147 | | _ -> Lwt.fail (Failure "Mqtt Server: Expected connect")) >>= fun () -> 1148 | let rec loop g = 1149 | read_packet cxn >>= (function 1150 | | (_, Publish s) -> handle_pub s 1151 | | (_, Subscribe s) -> handle_sub outch s 1152 | | (_, Pingreq) -> pingresp () |> Lwt_io.write outch 1153 | | (_, Disconnect) -> Lwt_io.printl "Disconnected client" 1154 | | _ -> Lwt.fail (Failure "Mqtt Server: Unknown paqet")) >>= fun () -> 1155 | loop g in 1156 | loop ()) 1157 | (function Unix.Unix_error (Unix.EPIPE, _, _) 1158 | | Unix.Unix_error (Unix.ECONNRESET, _, _) 1159 | | Unix.Unix_error (Unix.ENOTCONN, _, _) 1160 | | End_of_file -> 1161 | Printf.printf "Cleaning up client\n%!"; 1162 | cxns := List.filter (fun ch -> ch != outch) !cxns; 1163 | Lwt_io.close inch <&> Lwt_io.close outch >>= fun () -> 1164 | Lwt.return_unit 1165 | | exn -> Lwt_io.printlf "SRVERR: %s" (Printexc.to_string exn)) 1166 | 1167 | let addr host port = 1168 | Lwt_unix.gethostbyname host >>= fun hostent -> 1169 | let inet_addr = hostent.Unix.h_addr_list.(0) in 1170 | Unix.ADDR_INET (inet_addr, port) |> Lwt.return 1171 | 1172 | let listen ?(host = "localhost") ?(port = 1883) () = 1173 | addr host port >>= fun a -> 1174 | Lwt_io.Versioned.establish_server_2 ~backlog:1000 a srv_cxn 1175 | 1176 | end 1177 | 1178 | end 1179 | -------------------------------------------------------------------------------- /lib/mqtt.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 37b3d49826f78b168f83935347d3b49b) 3 | Mqtt 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/mqtt.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 37b3d49826f78b168f83935347d3b49b) 3 | Mqtt 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/subscriptions.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | module Subscriptions : sig 4 | 5 | type 'a t 6 | 7 | val empty: 'a t 8 | 9 | val add_node : string -> 'a -> 'a t -> 'a t 10 | 11 | val remove_node : string ->'a -> 'a t -> 'a t 12 | 13 | val query : string -> 'a t -> 'a list 14 | 15 | val length : 'a t -> int 16 | 17 | val tests : OUnit.test list 18 | 19 | end = struct 20 | 21 | type 'a t = 22 | | E (* empty *) 23 | | NV of string * (string, 'a t) Hashtbl.t (* no value *) 24 | | V of string * (string, 'a t) Hashtbl.t * 'a list (* value *) 25 | | Pound of 'a list (* wildcard # *) 26 | 27 | let split str = 28 | let strs = ref [] in 29 | let prev = ref 0 in 30 | let split_segment i c = 31 | if c = '/' then 32 | let newstr = String.sub str !prev (i - !prev) in 33 | prev := (i + 1); (* skip slash *) 34 | strs := newstr :: !strs in 35 | String.iteri split_segment str; 36 | (* fixup the last element *) 37 | strs := String.sub str !prev ((String.length str) - !prev) :: !strs; 38 | List.rev !strs 39 | 40 | let empty = E 41 | 42 | let tbl_keys tbl = Hashtbl.fold (fun k _ acc -> k :: acc) tbl [] 43 | let tbl_vals tbl = Hashtbl.fold (fun _ v acc -> v :: acc) tbl [] 44 | 45 | let rec length = function 46 | | E -> 0 47 | | Pound _ -> 1 48 | | NV (_, t) | V (_, t, _) -> 49 | let children = tbl_vals t in 50 | 1 + List.fold_left (fun acc x -> acc + (length x)) 0 children 51 | 52 | let get_vals = function 53 | | E | NV _ -> [] 54 | | V (_, _, v) | Pound v -> v 55 | 56 | let find_branches tbl k : 'a t list = 57 | let f x = try [Hashtbl.find tbl x] with Not_found -> [] in 58 | List.map f [k; "+"; "#"] |> List.concat 59 | 60 | let pound_lookahead t v = 61 | try match (Hashtbl.find t "#") with 62 | | Pound z -> v @ z 63 | | _ -> failwith "should never happen" 64 | with Not_found -> v 65 | 66 | let query key tree = 67 | let k_parts = split key in 68 | let rec inner tree v p : 'a list = 69 | match p with 70 | | [] -> (match tree with 71 | | Pound z -> v @ z 72 | | V (_, t, z) -> pound_lookahead t (v @ z) 73 | | NV (_, t) -> pound_lookahead t v 74 | | E -> v) 75 | | h :: m -> (match tree with 76 | | E -> v 77 | | Pound z -> v @ z 78 | | NV (_, t) | V (_, t, _) -> 79 | let branches = find_branches t h in 80 | let r = List.map (fun x -> inner x v m) branches in 81 | v @ List.concat r) in 82 | inner tree [] k_parts 83 | 84 | let add_node keys v t = 85 | let new_node k v i n = 86 | let h = Hashtbl.create 10 in 87 | let j = k.(i) in 88 | if j = "#" then Pound [] 89 | else if n <> 0 then NV (j, h) 90 | else V (j, h, [v]) in 91 | 92 | let rec add k v i n = function 93 | | E -> new_node [|"*root*"|] v i n |> add k v i n 94 | | NV (key, h) as e -> 95 | if n = 0 then V (key, h, [v]) 96 | else 97 | let child = try Hashtbl.find h k.(i) 98 | with Not_found -> new_node k v i n in 99 | let child = add k v (i + 1) (n - 1) child in 100 | Hashtbl.replace h k.(i) child; 101 | e 102 | | V (key, h, v1) as e -> 103 | if n = 0 then V (key, h, v :: v1) 104 | else 105 | let child = try Hashtbl.find h k.(i) 106 | with Not_found -> new_node k v i n in 107 | let child = add k v (i + 1) (n - 1) child in 108 | Hashtbl.replace h k.(i) child; 109 | e 110 | | Pound v1 -> Pound (v :: v1) in 111 | 112 | let k = split keys |> Array.of_list in 113 | add k v 0 (Array.length k) t 114 | 115 | let get_branches = function 116 | | E | Pound _ -> [] 117 | | V (_, t, _) | NV (_, t) -> tbl_vals t 118 | 119 | let rec get_value = function 120 | | E -> [] 121 | | NV (_, t) -> List.concat (List.map get_value (tbl_vals t)) 122 | | Pound v -> v 123 | | V (_, t, v) -> v @ List.concat (List.map get_value (tbl_vals t)) 124 | 125 | let find_branch k = function 126 | | E | Pound _ -> None 127 | | V (_, t, _) | NV (_, t) -> 128 | try Some (Hashtbl.find t k) with Not_found -> None 129 | 130 | let remove_branch k = function 131 | | E as e | (Pound _ as e) -> e 132 | | (NV (_, t) as e) | (V (_, t, _) as e) -> 133 | Hashtbl.remove t k; 134 | if 0 = Hashtbl.length t then E else e 135 | 136 | let replace_branch k g = function 137 | | E as e | (Pound _ as e) -> e 138 | | (NV (_, t) as e) | (V (_, t, _) as e) -> 139 | Hashtbl.replace t k g; 140 | e 141 | 142 | let remove_node key value tree = 143 | let parts = split key in 144 | let remove values v = List.filter (fun x -> x <> v) values in 145 | let rec inner tree = function 146 | | h :: [] -> 147 | (match find_branch h tree with 148 | | None -> tree 149 | | Some b -> (match b with 150 | | E | NV _ -> tree 151 | | Pound v -> 152 | if "#" = h then begin 153 | let v = remove v value in 154 | if 0 = List.length v then remove_branch h tree 155 | else replace_branch h (Pound v) tree 156 | end else failwith "not pound; should never happen" 157 | | V (k, t, v) -> 158 | let v = remove v value in 159 | if 0 = List.length v then begin 160 | if 0 = Hashtbl.length t then remove_branch k tree 161 | else replace_branch k (NV (k, t)) tree 162 | end else replace_branch k (V (k, t, v)) tree)) 163 | | h :: t -> 164 | (match find_branch h tree with 165 | | Some b -> 166 | let e = inner b t in 167 | if E = e then remove_branch h tree 168 | else replace_branch h e tree 169 | | None -> tree) 170 | | [] -> tree in 171 | inner tree parts 172 | 173 | let rec tree_of_string tree level = 174 | let vals = match tree with 175 | | E | NV _ -> [] 176 | | V (_, _, v) | Pound v -> v in 177 | let key = match tree with 178 | | E -> "*empty*" 179 | | Pound _ -> "#" 180 | | NV (k, _) -> "nv: " ^ k 181 | | V (k, _, _) -> "v: " ^ k in 182 | let branches = match tree with 183 | | E | Pound _ -> [] 184 | | NV (_, t) | V (_, t, _) -> tbl_vals t in 185 | let vals = String.concat "," vals in 186 | let vals = if "" <> vals then ": " ^ vals else "" in 187 | let _ = Printf.printf "%*d %s %s\n" level level key vals in 188 | let func x = tree_of_string x (level + 4) in 189 | List.iter func branches 190 | 191 | let split_test _ = 192 | let printer = String.concat "," in 193 | let ae = assert_equal ~printer in 194 | let res = split "a/b/c/d" in 195 | ae ["a";"b";"c";"d"] res; 196 | let res = split "/abc//def/ghi/" in 197 | ae [""; "abc"; ""; "def";"ghi"; ""] res 198 | 199 | let plus_test _ = 200 | let tree = add_node "helo/happy/world!" "helosadworld" empty 201 | |> add_node "helo/pretty/wurld" "helothere" 202 | |> add_node "omg/wtf" "omgwtf" 203 | |> add_node "omg/wtf/bbq" "omgwtfbbq" 204 | |> add_node "omg/srsly" "omgsrsly" 205 | |> add_node "omg/+/bbqz" "omgwildbbq" 206 | |> add_node "omg/+" "omgwildcard" 207 | |> add_node "a/+/c/+/e/+" "abcdef" 208 | |> add_node "asdfies" "QWERTIES" 209 | in let r = [ 210 | "helo/pretty/wurld"; 211 | "helo/heh/qwert/blah"; 212 | "omg/lol/bbqz"; 213 | "helo/pretty"; 214 | "omg/wtf"; 215 | "omg/wtf!"; 216 | "a/lol/c/def/e/orly"; 217 | "alol/c/def/e"; 218 | ] in 219 | let expected = [ 220 | ["helothere"]; 221 | []; 222 | ["omgwildbbq"]; 223 | []; 224 | ["omgwildcard"; "omgwtf"]; 225 | ["omgwildcard"]; 226 | ["abcdef"]; 227 | []; 228 | ] in 229 | let printer = String.concat "," in 230 | let cmp a b = 231 | let s = List.sort (fun x y -> String.compare x y) in 232 | (s a) = (s b) in 233 | let ae = assert_equal ~printer ~cmp in 234 | let res = List.map (fun x -> query x tree) r in 235 | List.iter2 (fun x y -> ae x y) expected res 236 | 237 | let pound_test _ = 238 | let root = add_node "a/#" "a" empty 239 | |> add_node "a/b/#" "ab" 240 | |> add_node "a/b" "plainab" 241 | |> add_node "a/b/c/#" "abc" 242 | |> add_node "a/b/c/d/#" "abcd" 243 | |> add_node "a/b/c/d/e/#" "abcde" 244 | in let r = [ 245 | "a"; 246 | "a/b"; 247 | "a/b/c"; 248 | "a/c"; 249 | "d/e"; 250 | ] in 251 | let expected = [ 252 | ["a"]; 253 | ["plainab"; "ab"; "a"]; 254 | ["abc"; "ab"; "a"]; 255 | ["a"]; 256 | []; 257 | ] in 258 | let printer = String.concat "," in 259 | let res = List.map (fun x -> query x root) r in 260 | List.iter2 (fun x y -> assert_equal ~printer x y) expected res 261 | 262 | let remove_test _ = 263 | let root = add_node "a" "a" empty 264 | |> add_node "a/+" "a+" 265 | |> add_node "a/#" "a#" 266 | |> add_node "a/#" "tst" 267 | |> add_node "a" "tst" (* to double check wilds *) 268 | |> add_node "a/b" "ab" 269 | |> add_node "a/b/#" "ab#" 270 | |> add_node "a/b" "ab2" 271 | |> add_node "a/+/c" "a+c" 272 | |> add_node "a/b/c" "abc" 273 | |> add_node "a/+/c/#" "a+c#" 274 | |> add_node "a/b/c/d" "abcd" 275 | |> add_node "a/b/c/d" "abcd2" 276 | in let printer = String.concat ", " in 277 | let cmp a b = 278 | let s = List.sort (fun x y -> String.compare x y) in 279 | (s a) = (s b) in 280 | let ae = assert_equal ~printer ~cmp in 281 | 282 | (* really should modify to return the fully qualified key 283 | of the empty node 284 | *) 285 | let rec has_empty_leaves tree = 286 | let check acc x = 287 | if acc then acc 288 | else has_empty_leaves x in 289 | if 0 = List.length (get_branches tree) && 290 | 0 = List.length (get_value tree) then true 291 | else List.fold_left check false (get_branches tree) in 292 | 293 | (* sanity check the first element *) 294 | let res = query "a" root in 295 | ae ["tst"; "a"; "tst"; "a#";] res; 296 | let root = remove_node "a/#" "tst" root in 297 | let res = query "a" root in 298 | ae ["tst"; "a"; "a#";] res; 299 | let root = remove_node "a" "tst" root in 300 | let res = query "a" root in 301 | ae ["a"; "a#";] res; 302 | 303 | (* check that there are no empty leaves *) 304 | let res = query "a/b" root in 305 | ae ["ab"; "ab#"; "ab2"; "a#"; "a+";] res; 306 | (* should produce an empty leaf; the "#" dangles *) 307 | let root = remove_node "a/b/#" "ab#" root in 308 | let res = query "a/b" root in 309 | ae ["ab"; "ab2"; "a#"; "a+"] res; 310 | assert_equal ~msg: "empty leaves a/b/#" false (has_empty_leaves root); 311 | 312 | (* misc things, such as removing all values from a parent *) 313 | let res = query "a/b/c" root in 314 | ae ["a+c"; "abc"; "a+c#"; "a#"] res; 315 | let root = remove_node "a/b/c" "abc" root in 316 | let res = query "a/b/c" root in 317 | ae ["a+c"; "a+c#"; "a#"] res; 318 | let root = remove_node "a/+/c" "a+c" root in 319 | let res = query "a/b/c" root in 320 | ae ["a+c#"; "a#";] res; 321 | let root = remove_node "a/+/c/#" "a+c#" root in 322 | let res = query "a/b/c" root in 323 | ae ["a#"] res; 324 | assert_equal ~msg:"empty leaves; none" false (has_empty_leaves root); 325 | 326 | (* remove a sibling value from same key *) 327 | let res = query "a/b/c/d" root in 328 | ae ["a#"; "abcd"; "abcd2"] res; 329 | let root = remove_node "a/b/c/d" "abcd" root in 330 | let res = query "a/b/c/d" root in 331 | ae ["a#"; "abcd2"] res; 332 | 333 | (* remove nonexistent value from valid key *) 334 | let root = remove_node "a/b/c/d" "nothere" root in 335 | let res = query "a/b/c/d" root in 336 | ae ["a#"; "abcd2"] res; 337 | 338 | (* remove nonexistent value from invalid key *) 339 | let root = remove_node "a/c/d/" "rlynothere" root in 340 | let res = query "a/c/d" root in 341 | ae ["a#"] res; 342 | assert_equal ~msg: "empty leaves; final" false (has_empty_leaves root); 343 | () 344 | 345 | let tests = [ 346 | "split_test" >:: split_test; 347 | "plus test" >:: plus_test; 348 | "pound_test" >:: pound_test; 349 | "remove_test" >:: remove_test; 350 | ] 351 | 352 | end 353 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: c3b53294856582db433e07a033639577) *) 3 | module OASISGettext = struct 4 | (* # 22 "src/oasis/OASISGettext.ml" *) 5 | 6 | 7 | let ns_ str = str 8 | let s_ str = str 9 | let f_ (str: ('a, 'b, 'c, 'd) format4) = str 10 | 11 | 12 | let fn_ fmt1 fmt2 n = 13 | if n = 1 then 14 | fmt1^^"" 15 | else 16 | fmt2^^"" 17 | 18 | 19 | let init = [] 20 | end 21 | 22 | module OASISString = struct 23 | (* # 22 "src/oasis/OASISString.ml" *) 24 | 25 | 26 | (** Various string utilities. 27 | 28 | Mostly inspired by extlib and batteries ExtString and BatString libraries. 29 | 30 | @author Sylvain Le Gall 31 | *) 32 | 33 | 34 | let nsplitf str f = 35 | if str = "" then 36 | [] 37 | else 38 | let buf = Buffer.create 13 in 39 | let lst = ref [] in 40 | let push () = 41 | lst := Buffer.contents buf :: !lst; 42 | Buffer.clear buf 43 | in 44 | let str_len = String.length str in 45 | for i = 0 to str_len - 1 do 46 | if f str.[i] then 47 | push () 48 | else 49 | Buffer.add_char buf str.[i] 50 | done; 51 | push (); 52 | List.rev !lst 53 | 54 | 55 | (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the 56 | separator. 57 | *) 58 | let nsplit str c = 59 | nsplitf str ((=) c) 60 | 61 | 62 | let find ~what ?(offset=0) str = 63 | let what_idx = ref 0 in 64 | let str_idx = ref offset in 65 | while !str_idx < String.length str && 66 | !what_idx < String.length what do 67 | if str.[!str_idx] = what.[!what_idx] then 68 | incr what_idx 69 | else 70 | what_idx := 0; 71 | incr str_idx 72 | done; 73 | if !what_idx <> String.length what then 74 | raise Not_found 75 | else 76 | !str_idx - !what_idx 77 | 78 | 79 | let sub_start str len = 80 | let str_len = String.length str in 81 | if len >= str_len then 82 | "" 83 | else 84 | String.sub str len (str_len - len) 85 | 86 | 87 | let sub_end ?(offset=0) str len = 88 | let str_len = String.length str in 89 | if len >= str_len then 90 | "" 91 | else 92 | String.sub str 0 (str_len - len) 93 | 94 | 95 | let starts_with ~what ?(offset=0) str = 96 | let what_idx = ref 0 in 97 | let str_idx = ref offset in 98 | let ok = ref true in 99 | while !ok && 100 | !str_idx < String.length str && 101 | !what_idx < String.length what do 102 | if str.[!str_idx] = what.[!what_idx] then 103 | incr what_idx 104 | else 105 | ok := false; 106 | incr str_idx 107 | done; 108 | if !what_idx = String.length what then 109 | true 110 | else 111 | false 112 | 113 | 114 | let strip_starts_with ~what str = 115 | if starts_with ~what str then 116 | sub_start str (String.length what) 117 | else 118 | raise Not_found 119 | 120 | 121 | let ends_with ~what ?(offset=0) str = 122 | let what_idx = ref ((String.length what) - 1) in 123 | let str_idx = ref ((String.length str) - 1) in 124 | let ok = ref true in 125 | while !ok && 126 | offset <= !str_idx && 127 | 0 <= !what_idx do 128 | if str.[!str_idx] = what.[!what_idx] then 129 | decr what_idx 130 | else 131 | ok := false; 132 | decr str_idx 133 | done; 134 | if !what_idx = -1 then 135 | true 136 | else 137 | false 138 | 139 | 140 | let strip_ends_with ~what str = 141 | if ends_with ~what str then 142 | sub_end str (String.length what) 143 | else 144 | raise Not_found 145 | 146 | 147 | let replace_chars f s = 148 | let buf = Buffer.create (String.length s) in 149 | String.iter (fun c -> Buffer.add_char buf (f c)) s; 150 | Buffer.contents buf 151 | 152 | let lowercase_ascii = 153 | replace_chars 154 | (fun c -> 155 | if (c >= 'A' && c <= 'Z') then 156 | Char.chr (Char.code c + 32) 157 | else 158 | c) 159 | 160 | let uncapitalize_ascii s = 161 | if s <> "" then 162 | (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 163 | else 164 | s 165 | 166 | let uppercase_ascii = 167 | replace_chars 168 | (fun c -> 169 | if (c >= 'a' && c <= 'z') then 170 | Char.chr (Char.code c - 32) 171 | else 172 | c) 173 | 174 | let capitalize_ascii s = 175 | if s <> "" then 176 | (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 177 | else 178 | s 179 | 180 | end 181 | 182 | module OASISUtils = struct 183 | (* # 22 "src/oasis/OASISUtils.ml" *) 184 | 185 | 186 | open OASISGettext 187 | 188 | 189 | module MapExt = 190 | struct 191 | module type S = 192 | sig 193 | include Map.S 194 | val add_list: 'a t -> (key * 'a) list -> 'a t 195 | val of_list: (key * 'a) list -> 'a t 196 | val to_list: 'a t -> (key * 'a) list 197 | end 198 | 199 | module Make (Ord: Map.OrderedType) = 200 | struct 201 | include Map.Make(Ord) 202 | 203 | let rec add_list t = 204 | function 205 | | (k, v) :: tl -> add_list (add k v t) tl 206 | | [] -> t 207 | 208 | let of_list lst = add_list empty lst 209 | 210 | let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] 211 | end 212 | end 213 | 214 | 215 | module MapString = MapExt.Make(String) 216 | 217 | 218 | module SetExt = 219 | struct 220 | module type S = 221 | sig 222 | include Set.S 223 | val add_list: t -> elt list -> t 224 | val of_list: elt list -> t 225 | val to_list: t -> elt list 226 | end 227 | 228 | module Make (Ord: Set.OrderedType) = 229 | struct 230 | include Set.Make(Ord) 231 | 232 | let rec add_list t = 233 | function 234 | | e :: tl -> add_list (add e t) tl 235 | | [] -> t 236 | 237 | let of_list lst = add_list empty lst 238 | 239 | let to_list = elements 240 | end 241 | end 242 | 243 | 244 | module SetString = SetExt.Make(String) 245 | 246 | 247 | let compare_csl s1 s2 = 248 | String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) 249 | 250 | 251 | module HashStringCsl = 252 | Hashtbl.Make 253 | (struct 254 | type t = string 255 | let equal s1 s2 = (compare_csl s1 s2) = 0 256 | let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) 257 | end) 258 | 259 | module SetStringCsl = 260 | SetExt.Make 261 | (struct 262 | type t = string 263 | let compare = compare_csl 264 | end) 265 | 266 | 267 | let varname_of_string ?(hyphen='_') s = 268 | if String.length s = 0 then 269 | begin 270 | invalid_arg "varname_of_string" 271 | end 272 | else 273 | begin 274 | let buf = 275 | OASISString.replace_chars 276 | (fun c -> 277 | if ('a' <= c && c <= 'z') 278 | || 279 | ('A' <= c && c <= 'Z') 280 | || 281 | ('0' <= c && c <= '9') then 282 | c 283 | else 284 | hyphen) 285 | s; 286 | in 287 | let buf = 288 | (* Start with a _ if digit *) 289 | if '0' <= s.[0] && s.[0] <= '9' then 290 | "_"^buf 291 | else 292 | buf 293 | in 294 | OASISString.lowercase_ascii buf 295 | end 296 | 297 | 298 | let varname_concat ?(hyphen='_') p s = 299 | let what = String.make 1 hyphen in 300 | let p = 301 | try 302 | OASISString.strip_ends_with ~what p 303 | with Not_found -> 304 | p 305 | in 306 | let s = 307 | try 308 | OASISString.strip_starts_with ~what s 309 | with Not_found -> 310 | s 311 | in 312 | p^what^s 313 | 314 | 315 | let is_varname str = 316 | str = varname_of_string str 317 | 318 | 319 | let failwithf fmt = Printf.ksprintf failwith fmt 320 | 321 | 322 | let rec file_location ?pos1 ?pos2 ?lexbuf () = 323 | match pos1, pos2, lexbuf with 324 | | Some p, None, _ | None, Some p, _ -> 325 | file_location ~pos1:p ~pos2:p ?lexbuf () 326 | | Some p1, Some p2, _ -> 327 | let open Lexing in 328 | let fn, lineno = p1.pos_fname, p1.pos_lnum in 329 | let c1 = p1.pos_cnum - p1.pos_bol in 330 | let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in 331 | Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 332 | | _, _, Some lexbuf -> 333 | file_location 334 | ~pos1:(Lexing.lexeme_start_p lexbuf) 335 | ~pos2:(Lexing.lexeme_end_p lexbuf) 336 | () 337 | | None, None, None -> 338 | s_ "" 339 | 340 | 341 | let failwithpf ?pos1 ?pos2 ?lexbuf fmt = 342 | let loc = file_location ?pos1 ?pos2 ?lexbuf () in 343 | Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt 344 | 345 | 346 | end 347 | 348 | module OASISExpr = struct 349 | (* # 22 "src/oasis/OASISExpr.ml" *) 350 | 351 | 352 | open OASISGettext 353 | open OASISUtils 354 | 355 | 356 | type test = string 357 | type flag = string 358 | 359 | 360 | type t = 361 | | EBool of bool 362 | | ENot of t 363 | | EAnd of t * t 364 | | EOr of t * t 365 | | EFlag of flag 366 | | ETest of test * string 367 | 368 | 369 | type 'a choices = (t * 'a) list 370 | 371 | 372 | let eval var_get t = 373 | let rec eval' = 374 | function 375 | | EBool b -> 376 | b 377 | 378 | | ENot e -> 379 | not (eval' e) 380 | 381 | | EAnd (e1, e2) -> 382 | (eval' e1) && (eval' e2) 383 | 384 | | EOr (e1, e2) -> 385 | (eval' e1) || (eval' e2) 386 | 387 | | EFlag nm -> 388 | let v = 389 | var_get nm 390 | in 391 | assert(v = "true" || v = "false"); 392 | (v = "true") 393 | 394 | | ETest (nm, vl) -> 395 | let v = 396 | var_get nm 397 | in 398 | (v = vl) 399 | in 400 | eval' t 401 | 402 | 403 | let choose ?printer ?name var_get lst = 404 | let rec choose_aux = 405 | function 406 | | (cond, vl) :: tl -> 407 | if eval var_get cond then 408 | vl 409 | else 410 | choose_aux tl 411 | | [] -> 412 | let str_lst = 413 | if lst = [] then 414 | s_ "" 415 | else 416 | String.concat 417 | (s_ ", ") 418 | (List.map 419 | (fun (cond, vl) -> 420 | match printer with 421 | | Some p -> p vl 422 | | None -> s_ "") 423 | lst) 424 | in 425 | match name with 426 | | Some nm -> 427 | failwith 428 | (Printf.sprintf 429 | (f_ "No result for the choice list '%s': %s") 430 | nm str_lst) 431 | | None -> 432 | failwith 433 | (Printf.sprintf 434 | (f_ "No result for a choice list: %s") 435 | str_lst) 436 | in 437 | choose_aux (List.rev lst) 438 | 439 | 440 | end 441 | 442 | 443 | # 443 "myocamlbuild.ml" 444 | module BaseEnvLight = struct 445 | (* # 22 "src/base/BaseEnvLight.ml" *) 446 | 447 | 448 | module MapString = Map.Make(String) 449 | 450 | 451 | type t = string MapString.t 452 | 453 | 454 | let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" 455 | 456 | 457 | let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = 458 | let line = ref 1 in 459 | let lexer st = 460 | let st_line = 461 | Stream.from 462 | (fun _ -> 463 | try 464 | match Stream.next st with 465 | | '\n' -> incr line; Some '\n' 466 | | c -> Some c 467 | with Stream.Failure -> None) 468 | in 469 | Genlex.make_lexer ["="] st_line 470 | in 471 | let rec read_file lxr mp = 472 | match Stream.npeek 3 lxr with 473 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 474 | Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; 475 | read_file lxr (MapString.add nm value mp) 476 | | [] -> mp 477 | | _ -> 478 | failwith 479 | (Printf.sprintf "Malformed data file '%s' line %d" filename !line) 480 | in 481 | match stream with 482 | | Some st -> read_file (lexer st) MapString.empty 483 | | None -> 484 | if Sys.file_exists filename then begin 485 | let chn = open_in_bin filename in 486 | let st = Stream.of_channel chn in 487 | try 488 | let mp = read_file (lexer st) MapString.empty in 489 | close_in chn; mp 490 | with e -> 491 | close_in chn; raise e 492 | end else if allow_empty then begin 493 | MapString.empty 494 | end else begin 495 | failwith 496 | (Printf.sprintf 497 | "Unable to load environment, the file '%s' doesn't exist." 498 | filename) 499 | end 500 | 501 | let rec var_expand str env = 502 | let buff = Buffer.create ((String.length str) * 2) in 503 | Buffer.add_substitute 504 | buff 505 | (fun var -> 506 | try 507 | var_expand (MapString.find var env) env 508 | with Not_found -> 509 | failwith 510 | (Printf.sprintf 511 | "No variable %s defined when trying to expand %S." 512 | var 513 | str)) 514 | str; 515 | Buffer.contents buff 516 | 517 | 518 | let var_get name env = var_expand (MapString.find name env) env 519 | let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst 520 | end 521 | 522 | 523 | # 523 "myocamlbuild.ml" 524 | module MyOCamlbuildFindlib = struct 525 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 526 | 527 | 528 | (** OCamlbuild extension, copied from 529 | * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html 530 | * by N. Pouillard and others 531 | * 532 | * Updated on 2016-06-02 533 | * 534 | * Modified by Sylvain Le Gall 535 | *) 536 | open Ocamlbuild_plugin 537 | 538 | 539 | type conf = {no_automatic_syntax: bool} 540 | 541 | 542 | let run_and_read = Ocamlbuild_pack.My_unix.run_and_read 543 | 544 | 545 | let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings 546 | 547 | 548 | let exec_from_conf exec = 549 | let exec = 550 | let env = BaseEnvLight.load ~allow_empty:true () in 551 | try 552 | BaseEnvLight.var_get exec env 553 | with Not_found -> 554 | Printf.eprintf "W: Cannot get variable %s\n" exec; 555 | exec 556 | in 557 | let fix_win32 str = 558 | if Sys.os_type = "Win32" then begin 559 | let buff = Buffer.create (String.length str) in 560 | (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. 561 | *) 562 | String.iter 563 | (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) 564 | str; 565 | Buffer.contents buff 566 | end else begin 567 | str 568 | end 569 | in 570 | fix_win32 exec 571 | 572 | 573 | let split s ch = 574 | let buf = Buffer.create 13 in 575 | let x = ref [] in 576 | let flush () = 577 | x := (Buffer.contents buf) :: !x; 578 | Buffer.clear buf 579 | in 580 | String.iter 581 | (fun c -> 582 | if c = ch then 583 | flush () 584 | else 585 | Buffer.add_char buf c) 586 | s; 587 | flush (); 588 | List.rev !x 589 | 590 | 591 | let split_nl s = split s '\n' 592 | 593 | 594 | let before_space s = 595 | try 596 | String.before s (String.index s ' ') 597 | with Not_found -> s 598 | 599 | (* ocamlfind command *) 600 | let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] 601 | 602 | (* This lists all supported packages. *) 603 | let find_packages () = 604 | List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) 605 | 606 | 607 | (* Mock to list available syntaxes. *) 608 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 609 | 610 | 611 | let well_known_syntax = [ 612 | "camlp4.quotations.o"; 613 | "camlp4.quotations.r"; 614 | "camlp4.exceptiontracer"; 615 | "camlp4.extend"; 616 | "camlp4.foldgenerator"; 617 | "camlp4.listcomprehension"; 618 | "camlp4.locationstripper"; 619 | "camlp4.macro"; 620 | "camlp4.mapgenerator"; 621 | "camlp4.metagenerator"; 622 | "camlp4.profiler"; 623 | "camlp4.tracer" 624 | ] 625 | 626 | 627 | let dispatch conf = 628 | function 629 | | After_options -> 630 | (* By using Before_options one let command line options have an higher 631 | * priority on the contrary using After_options will guarantee to have 632 | * the higher priority override default commands by ocamlfind ones *) 633 | Options.ocamlc := ocamlfind & A"ocamlc"; 634 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 635 | Options.ocamldep := ocamlfind & A"ocamldep"; 636 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 637 | Options.ocamlmktop := ocamlfind & A"ocamlmktop"; 638 | Options.ocamlmklib := ocamlfind & A"ocamlmklib" 639 | 640 | | After_rules -> 641 | 642 | (* Avoid warnings for unused tag *) 643 | flag ["tests"] N; 644 | 645 | (* When one link an OCaml library/binary/package, one should use 646 | * -linkpkg *) 647 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 648 | 649 | (* For each ocamlfind package one inject the -package option when 650 | * compiling, computing dependencies, generating documentation and 651 | * linking. *) 652 | List.iter 653 | begin fun pkg -> 654 | let base_args = [A"-package"; A pkg] in 655 | (* TODO: consider how to really choose camlp4o or camlp4r. *) 656 | let syn_args = [A"-syntax"; A "camlp4o"] in 657 | let (args, pargs) = 658 | (* Heuristic to identify syntax extensions: whether they end in 659 | ".syntax"; some might not. 660 | *) 661 | if not (conf.no_automatic_syntax) && 662 | (Filename.check_suffix pkg "syntax" || 663 | List.mem pkg well_known_syntax) then 664 | (syn_args @ base_args, syn_args) 665 | else 666 | (base_args, []) 667 | in 668 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; 669 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; 670 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; 671 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; 672 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; 673 | 674 | (* TODO: Check if this is allowed for OCaml < 3.12.1 *) 675 | flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; 676 | flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; 677 | flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; 678 | flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; 679 | end 680 | (find_packages ()); 681 | 682 | (* Like -package but for extensions syntax. Morover -syntax is useless 683 | * when linking. *) 684 | List.iter begin fun syntax -> 685 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 686 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 687 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 688 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & 689 | S[A"-syntax"; A syntax]; 690 | end (find_syntaxes ()); 691 | 692 | (* The default "thread" tag is not compatible with ocamlfind. 693 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 694 | * options when using this tag. When using the "-linkpkg" option with 695 | * ocamlfind, this module will then be added twice on the command line. 696 | * 697 | * To solve this, one approach is to add the "-thread" option when using 698 | * the "threads" package using the previous plugin. 699 | *) 700 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 701 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 702 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 703 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); 704 | flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); 705 | flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); 706 | flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); 707 | flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); 708 | flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); 709 | flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); 710 | 711 | | _ -> 712 | () 713 | end 714 | 715 | module MyOCamlbuildBase = struct 716 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 717 | 718 | 719 | (** Base functions for writing myocamlbuild.ml 720 | @author Sylvain Le Gall 721 | *) 722 | 723 | 724 | open Ocamlbuild_plugin 725 | module OC = Ocamlbuild_pack.Ocaml_compiler 726 | 727 | 728 | type dir = string 729 | type file = string 730 | type name = string 731 | type tag = string 732 | 733 | 734 | type t = 735 | { 736 | lib_ocaml: (name * dir list * string list) list; 737 | lib_c: (name * dir * file list) list; 738 | flags: (tag list * (spec OASISExpr.choices)) list; 739 | (* Replace the 'dir: include' from _tags by a precise interdepends in 740 | * directory. 741 | *) 742 | includes: (dir * dir list) list; 743 | } 744 | 745 | 746 | (* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 747 | 748 | 749 | let env_filename = Pathname.basename BaseEnvLight.default_filename 750 | 751 | 752 | let dispatch_combine lst = 753 | fun e -> 754 | List.iter 755 | (fun dispatch -> dispatch e) 756 | lst 757 | 758 | 759 | let tag_libstubs nm = 760 | "use_lib"^nm^"_stubs" 761 | 762 | 763 | let nm_libstubs nm = 764 | nm^"_stubs" 765 | 766 | 767 | let dispatch t e = 768 | let env = BaseEnvLight.load ~allow_empty:true () in 769 | match e with 770 | | Before_options -> 771 | let no_trailing_dot s = 772 | if String.length s >= 1 && s.[0] = '.' then 773 | String.sub s 1 ((String.length s) - 1) 774 | else 775 | s 776 | in 777 | List.iter 778 | (fun (opt, var) -> 779 | try 780 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 781 | with Not_found -> 782 | Printf.eprintf "W: Cannot get variable %s\n" var) 783 | [ 784 | Options.ext_obj, "ext_obj"; 785 | Options.ext_lib, "ext_lib"; 786 | Options.ext_dll, "ext_dll"; 787 | ] 788 | 789 | | After_rules -> 790 | (* Declare OCaml libraries *) 791 | List.iter 792 | (function 793 | | nm, [], intf_modules -> 794 | ocaml_lib nm; 795 | let cmis = 796 | List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") 797 | intf_modules in 798 | dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis 799 | | nm, dir :: tl, intf_modules -> 800 | ocaml_lib ~dir:dir (dir^"/"^nm); 801 | List.iter 802 | (fun dir -> 803 | List.iter 804 | (fun str -> 805 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 806 | ["compile"; "infer_interface"; "doc"]) 807 | tl; 808 | let cmis = 809 | List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") 810 | intf_modules in 811 | dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] 812 | cmis) 813 | t.lib_ocaml; 814 | 815 | (* Declare directories dependencies, replace "include" in _tags. *) 816 | List.iter 817 | (fun (dir, include_dirs) -> 818 | Pathname.define_context dir include_dirs) 819 | t.includes; 820 | 821 | (* Declare C libraries *) 822 | List.iter 823 | (fun (lib, dir, headers) -> 824 | (* Handle C part of library *) 825 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 826 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 827 | A("-l"^(nm_libstubs lib))]); 828 | 829 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 830 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 831 | 832 | if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then 833 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 834 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 835 | 836 | (* When ocaml link something that use the C library, then one 837 | need that file to be up to date. 838 | This holds both for programs and for libraries. 839 | *) 840 | dep ["link"; "ocaml"; tag_libstubs lib] 841 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 842 | 843 | dep ["compile"; "ocaml"; tag_libstubs lib] 844 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 845 | 846 | (* TODO: be more specific about what depends on headers *) 847 | (* Depends on .h files *) 848 | dep ["compile"; "c"] 849 | headers; 850 | 851 | (* Setup search path for lib *) 852 | flag ["link"; "ocaml"; "use_"^lib] 853 | (S[A"-I"; P(dir)]); 854 | ) 855 | t.lib_c; 856 | 857 | (* Add flags *) 858 | List.iter 859 | (fun (tags, cond_specs) -> 860 | let spec = BaseEnvLight.var_choose cond_specs env in 861 | let rec eval_specs = 862 | function 863 | | S lst -> S (List.map eval_specs lst) 864 | | A str -> A (BaseEnvLight.var_expand str env) 865 | | spec -> spec 866 | in 867 | flag tags & (eval_specs spec)) 868 | t.flags 869 | | _ -> 870 | () 871 | 872 | 873 | let dispatch_default conf t = 874 | dispatch_combine 875 | [ 876 | dispatch t; 877 | MyOCamlbuildFindlib.dispatch conf; 878 | ] 879 | 880 | 881 | end 882 | 883 | 884 | # 884 "myocamlbuild.ml" 885 | open Ocamlbuild_plugin;; 886 | let package_default = 887 | { 888 | MyOCamlbuildBase.lib_ocaml = [("mqtt", ["lib"], [])]; 889 | lib_c = []; 890 | flags = 891 | [ 892 | (["oasis_library_mqtt_byte"; "ocaml"; "link"; "byte"], 893 | [ 894 | (OASISExpr.EBool true, 895 | S [A "-bin-annot"; A "-ppopt"; A "-lwt-debug"]) 896 | ]); 897 | (["oasis_library_mqtt_native"; "ocaml"; "link"; "native"], 898 | [ 899 | (OASISExpr.EBool true, 900 | S [A "-bin-annot"; A "-ppopt"; A "-lwt-debug"]) 901 | ]); 902 | (["oasis_library_mqtt_byte"; "ocaml"; "ocamldep"; "byte"], 903 | [ 904 | (OASISExpr.EBool true, 905 | S [A "-bin-annot"; A "-ppopt"; A "-lwt-debug"]) 906 | ]); 907 | (["oasis_library_mqtt_native"; "ocaml"; "ocamldep"; "native"], 908 | [ 909 | (OASISExpr.EBool true, 910 | S [A "-bin-annot"; A "-ppopt"; A "-lwt-debug"]) 911 | ]); 912 | (["oasis_library_mqtt_byte"; "ocaml"; "compile"; "byte"], 913 | [ 914 | (OASISExpr.EBool true, 915 | S [A "-bin-annot"; A "-ppopt"; A "-lwt-debug"]) 916 | ]); 917 | (["oasis_library_mqtt_native"; "ocaml"; "compile"; "native"], 918 | [ 919 | (OASISExpr.EBool true, 920 | S [A "-bin-annot"; A "-ppopt"; A "-lwt-debug"]) 921 | ]) 922 | ]; 923 | includes = [("test", ["lib"]); ("example", ["lib"])] 924 | } 925 | ;; 926 | 927 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 928 | 929 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 930 | 931 | # 932 "myocamlbuild.ml" 932 | (* OASIS_STOP *) 933 | Ocamlbuild_plugin.dispatch dispatch_default;; 934 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open Mqtt 3 | open Subscriptions 4 | 5 | let _ = 6 | let tests = Mqtt.tests @ Subscriptions.tests in 7 | let suite = "mqtt">:::tests in 8 | run_test_tt_main suite 9 | 10 | 11 | --------------------------------------------------------------------------------