├── .gitignore ├── .merlin ├── DEVEL.md ├── LICENSE ├── Makefile ├── README.md ├── _tags ├── examples ├── cat.ml └── tcp_echo_server.ml ├── lib_gen ├── consts_gen.ml ├── consts_stub.c ├── libuv_accessor_gen.ml ├── libuv_bindgen.ml └── libuv_bindings.ml ├── myocamlbuild.ml ├── src ├── buf.ml ├── coat_check.ml ├── coat_check.mli ├── refcount.ml ├── refcount.mli ├── util.ml ├── uv.ml └── uv.mli └── test ├── test_coat_check.ml ├── test_consts.ml ├── test_fs.ml ├── test_handle.ml ├── test_lifecycle.ml └── test_runner.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.native 3 | *.byte 4 | _build -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S . 2 | S src 3 | S lib_gen 4 | B _build 5 | B _build/src 6 | B _build/lib_gen 7 | PKG ounit 8 | PKG ctypes -------------------------------------------------------------------------------- /DEVEL.md: -------------------------------------------------------------------------------- 1 | API Design 2 | ---------- 3 | 0. This is a low level api meant for other frameworks to use to provide 4 | blocking and/or not blocking system calls. 5 | 1. Don't expose the blocking functionality -- only the non-blocking. 6 | The entire point of this library is to get the non-blocking functionality. 7 | 2. Errors are with a return type -- no exceptions are thrown. 8 | This library is meant for framework creators to build on top of. 9 | Frameworks will need to make an explicit decision of how they deal with 10 | errors. 11 | 3. Threading. We assume that only fs, getaddrinfo, getnameinfo and 12 | user specified work use other threads. We need to call 13 | caml_c_thread_register () _once_ on each of the threads in the 14 | internal thread pool. However, there is no mechanism exposed to allow 15 | one to run initialization code on the threads. So we make a call to 16 | caml_c_thread_register before _any_ callback that can be running in another 17 | thread. This is more expensive than needs be, however it gets the job done, 18 | and (from looking at the implementation of caml_c_thread_register) it appears 19 | that it is pretty cheap to call this subsequent times. 20 | See http://docs.libuv.org/en/v1.x/design.html 21 | See http://caml.inria.fr/pub/docs/manual-ocaml-4.00/manual033.html#toc151 22 | See https://github.com/ocaml/ocaml/blob/4.02/otherlibs/systhreads/st_stubs.c#L544 23 | 4. Callback arguments. We tried to add type safety where reasonable. 24 | TODO once we get some feedback add thoughts. 25 | 26 | * As few dependencies as possible (no Core). 27 | 28 | Questions 29 | --------- 30 | * Should we try and use the Unix.sockaddr for sockaddr? or try and use the libuv methods? 31 | eg see the tcp_echo_server example. 32 | let make_sockaddr port : Unix.sockaddr = 33 | let open Unix in 34 | let host = gethostbyname "localhost" in 35 | let inet_addr = host.h_addr_list.(0) in 36 | ADDR_INET(inet_addr, port) -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2015 Trevor Summers Smith , 2 | Zachary Newman 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the "Software"), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # This makefile is jank. We will redo. 2 | .PHONY: all 3 | all: cat tcp 4 | 5 | tcp: 6 | ocamlbuild -Is src examples/tcp_echo_server.native -lflags -cclib,-luv -tag debug -cflag -g 7 | 8 | cat: 9 | ocamlbuild -Is src examples/cat.native -lflags -cclib,-luv -tag debug -cflag -g 10 | 11 | tests: 12 | ocamlbuild -Is src test/test_runner.native -lflags -cclib,-luv && ./test_runner.native 13 | 14 | clean: 15 | ocamlbuild -clean 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Dependencies 2 | ------------ 3 | 4 | This is currently built and tested to work with: 5 | 6 | * ctypes 0.3.4 7 | * libuv 1.1.0 8 | * OCaml 4.02 -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: package(ctypes), package(ctypes.stubs), package(ctypes.foreign) 2 | : use_ctypes_c_headers 3 | : use_accessor_headers 4 | : use_libuv_generated_stubs, custom, use_libuv, use_accessors 5 | : use_libuv_generated_stubs, use_libuv, use_accessors, thread 6 | : use_libuv_generated_stubs, custom, use_libuv, use_accessors, package(oUnit) 7 | : use_libuv_generated_stubs, use_libuv, use_accessors, thread, package(oUnit) 8 | : package(oUnit) 9 | : include 10 | : include 11 | : use_uv_consts 12 | : link_consts_stub, custom 13 | : thread -------------------------------------------------------------------------------- /examples/cat.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open Uv 10 | 11 | let fd_ref = ref 0 12 | 13 | let rec read_callback fs _ = 14 | match ok_exn (FS.result fs) with 15 | r when r < 0 -> Printf.printf "ok" 16 | | r when r = 0 -> ok_exn(FS.close !fd_ref ~cb:(fun _ -> ())) 17 | | r -> 18 | let buf = FS.buf fs in 19 | let buf2 = Bigarray.Array1.sub buf 0 r in 20 | ok_exn(FS.write ~offset:(-1) ~cb:write_callback 1 buf2) 21 | and write_callback fs _ = 22 | if ok_exn(FS.result fs) < 0 then 23 | Printf.fprintf stderr "Write error\n" 24 | else 25 | let buf = Bigarray.(Array1.create char c_layout 1024) in 26 | ok_exn (FS.read ~offset:(-1) !fd_ref ~cb:read_callback buf) 27 | 28 | let open_callback fs = 29 | let fd = ok_exn (FS.result fs) in 30 | let _ = fd_ref := fd in 31 | let buf = Bigarray.(Array1.create char c_layout 1024) in 32 | ok_exn (FS.read fd ~offset:0 ~cb:read_callback buf) 33 | 34 | let () = 35 | if Array.length Sys.argv != 2 then 36 | Printf.fprintf stderr "Usage: %s \n" Sys.argv.(0) 37 | else 38 | let () = ok_exn (FS.openfile Sys.argv.(1) ~cb:open_callback 0) in 39 | let ret = Loop.run Loop.RunDefault in 40 | match ret with 41 | Ok _ -> exit 0 42 | | Error e -> failwith (error_to_string e) 43 | -------------------------------------------------------------------------------- /examples/tcp_echo_server.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open Uv 10 | 11 | let default_backlog = 128;; 12 | let server_port = 7889 13 | 14 | let echo_write _req status = 15 | if status == -1 then 16 | failwith "Error!" 17 | else 18 | () (* Nothing free memory. *) 19 | 20 | let echo_read (client : 'a Stream.t) nread buf = 21 | match nread with 22 | | -4095 -> Printf.fprintf stderr "Error reading! "; Handle.close client 23 | | -1 -> Handle.close client 24 | | 0 -> () 25 | | _ -> 26 | (* All good. Write back what we read. *) 27 | let _ = Stream.write ~cb:echo_write client buf in 28 | Printf.printf "Received and wrote back '%s'\n%!" (Util.of_bigarray buf) 29 | 30 | let on_new_conn (server : 'a Stream.t) (status : int) : unit = 31 | if status = -1 then 32 | failwith "Error!" 33 | else 34 | let client = TCP.init () in 35 | match Stream.accept server client with 36 | | _ -> Stream.read_start ~cb:echo_read client 37 | (* TODO: handle exceptions *) 38 | 39 | let make_sockaddr () = ip4_addr "0.0.0.0" server_port 40 | 41 | let () = 42 | let _ = Printf.printf "(^_^) Server listening on localhost:%d\n%!" server_port in 43 | let _ = Printf.printf " Try `echo -n 'hello' | nc localhost %d`\n%!" server_port in 44 | let server = TCP.init () in 45 | let sockaddr = make_sockaddr () in 46 | let _ = TCP.bind server sockaddr 0 in 47 | let _ = Stream.listen ~cb:on_new_conn server default_backlog in 48 | let _ = Loop.run Loop.RunDefault in 49 | () 50 | -------------------------------------------------------------------------------- /lib_gen/consts_gen.ml: -------------------------------------------------------------------------------- 1 | (* 2 | This file runs the consts_stubs generation. 3 | This file only exists because it is easier to have 4 | ocamlbuild generate an ocaml executable. If I could 5 | figure out how to make it generate a c executable 6 | then this file would not exist. 7 | *) 8 | 9 | external output_consts : string -> unit = "output_consts" 10 | 11 | let main () = 12 | let outf = 13 | if Array.length Sys.argv < 2 then "" 14 | else if Sys.argv.(1) = "" then "" 15 | else if Sys.argv.(1) = "-" then "" 16 | else Sys.argv.(1) in 17 | output_consts outf 18 | 19 | let () = main () 20 | -------------------------------------------------------------------------------- /lib_gen/consts_stub.c: -------------------------------------------------------------------------------- 1 | /* Generate a list of constant definitions from c to ocaml. 2 | * 3 | * Heavily indebted to 4 | * https://github.com/dbuenzli/tsdl/blob/master/support/consts_stub.c . 5 | */ 6 | 7 | 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | void let (FILE *fd, const char *symb) { 16 | int i; 17 | fprintf (fd, "let "); 18 | for (i = 0; i < strlen(symb); i++) { 19 | fprintf (fd, "%c", tolower (symb[i])); 20 | } 21 | } 22 | 23 | void string_v (FILE *fd, char *symb, const char *value) { 24 | let (fd, symb); fprintf (fd, " = \"%s\"\n", value); 25 | } 26 | 27 | void integer_v (FILE *fd, char *symb, int value) { 28 | let (fd, symb); fprintf (fd, " = %d\n", value); 29 | } 30 | 31 | void integer_vx (FILE *fd, char *symb, int value) { 32 | let (fd, symb); fprintf (fd, " = 0x%X\n", value); 33 | } 34 | 35 | void integer32_v (FILE *fd, char *symb, int32_t value) { 36 | let (fd, symb); fprintf (fd, " = 0x%Xl\n", value); 37 | } 38 | 39 | #define int_v(e) integer_v(fd, "" # e, (int)e) 40 | #define int_vx(e) integer_vx(fd, "" # e, (int)e) 41 | #define int32_v(e) integer32_v(fd, "" # e, (int32_t)e) 42 | #define str_v(e) string_v(fd, "" # e, (const char *)e) 43 | #define size_of(e) integer_v(fd, "size_of_" # e, (int)(sizeof(e))) 44 | 45 | void make_error_codes(FILE *fd) { 46 | /* Error codes. 47 | 48 | We need to: 49 | 1) generate a set of constructors from the error names 50 | 2) generate a function for converting from the integer error 51 | and the enum. 52 | 3) (We don't really need this but people will probably want it) 53 | Generate ocaml error type -> int. 54 | 4) Generate error to string message 55 | 56 | uv.h exposes UV_ERRNO_MAP which is basically a map function on 57 | a set of pairs that are name without UV_ prefix, and string. 58 | We'll take this list and get the names of the enums it creates. 59 | */ 60 | // 1) Generate ocaml datatype 61 | fprintf(fd, "type error =\n"); 62 | #define XX(code, _) fprintf(fd, " | UV_" #code "\n"); 63 | UV_ERRNO_MAP(XX) 64 | #undef XX 65 | 66 | // 2) Convert from int to error type 67 | fprintf(fd, "let int_to_error = function\n"); 68 | #define XX(code, _) fprintf(fd, " | %d -> UV_" # code "\n", UV_ ## code); 69 | UV_ERRNO_MAP(XX) 70 | #undef XX 71 | fprintf(fd, " | _ -> failwith \"Unknown error code. " 72 | "This should not happen. This means the version " 73 | "of libuv is different than the version used to compile " 74 | "ocaml-libuv.\"\n"); 75 | 76 | // 3) Convert from error type to int 77 | fprintf(fd, "let error_to_int = function\n"); 78 | #define XX(code, _) fprintf(fd, " | UV_" #code " -> %d\n", UV_ ## code); 79 | UV_ERRNO_MAP(XX) 80 | #undef XX 81 | 82 | // 4) Generate error to string. (we could use uv_strerror but then we'd 83 | // have to cast back to an int, etc. Easier to just define it here in ocaml) 84 | fprintf(fd, "let error_to_string = function\n"); 85 | #define XX(code, msg) fprintf(fd, " | UV_" #code " -> \"%s\"\n", msg); 86 | UV_ERRNO_MAP(XX) 87 | #undef XX 88 | 89 | } 90 | 91 | void consts (FILE *fd) { 92 | 93 | /* Size of structs (because their sizes are platform dependent) */ 94 | size_of(uv_fs_t); 95 | size_of(uv_connect_t); 96 | 97 | } 98 | 99 | CAMLprim value output_consts (value fname) { 100 | char *outf = String_val (fname); 101 | FILE *fd; 102 | if (strlen(outf) == 0) { 103 | fd = stdout; 104 | } else { 105 | fd = fopen (outf, "w"); 106 | if (!fd) { 107 | perror(outf); exit (1); 108 | } 109 | } 110 | consts(fd); 111 | make_error_codes(fd); 112 | fflush(fd); 113 | if (fd != stdout) { 114 | fclose (fd); 115 | } 116 | return Val_unit; 117 | } 118 | -------------------------------------------------------------------------------- /lib_gen/libuv_accessor_gen.ml: -------------------------------------------------------------------------------- 1 | (** 2 | We need to generate a c and h file. It seems the least brittle way to do 3 | this is to generate them both from this single ml file. 4 | *) 5 | 6 | let accessors = 7 | [ 8 | ["uv_handle_t", "uv_loop_t*", "loop"]; 9 | ["uv_stream_t", "size_t", "write_queue_size"]; 10 | ["uv_fs_t", "uv_loop_t*", "loop"]; 11 | ["uv_fs_t", "ssize_t", "result"]; 12 | ["uv_fs_t", "char*", "path"]; 13 | ["uv_fs_t", "uv_buf_t*", "bufs"]; 14 | (* XXX TMP going to bufs nix this in a future commit just here for now 15 | while we transition from the old way *) 16 | ] 17 | 18 | let make_header entity typ field = 19 | (* 20 | uv_loop_t* get_uv_handle_t_loop (const uv_handle_t* v); *) 21 | Printf.sprintf "%s get_%s_%s(const %s* v);" typ entity field entity 22 | 23 | let make_body entity typ field = 24 | (* uv_loop_t* get_uv_handle_t_loop (const uv_handle_t* v) { return v->loop; } *) 25 | Printf.sprintf "%s get_%s_%s(const %s* v) { return (%s)v->%s; }" 26 | typ entity field entity typ field 27 | 28 | let make_header_file () = 29 | let fmt = Format.formatter_of_out_channel (open_out "src/libuv_accessors.h") in 30 | let p = (function [e, t, f] -> make_header e t f | _ -> failwith "bad") in 31 | let strings = List.map p accessors in 32 | Format.fprintf fmt "#include \n\n"; 33 | (* TODO the struct here is tmp. When I tried to return a non-ptr I got an 34 | OCaml Memory_stubs unfound module error. Didn't want to deal with that 35 | with the large refactor. Will revisit later. Same goes for the line in 36 | make_c_file below.*) 37 | Format.fprintf fmt "struct uv_stat_t* get_uv_fs_t_statbuf(const uv_fs_t* v); \n" ; 38 | List.iter (fun s -> Format.fprintf fmt "%s\n" s) strings 39 | 40 | let make_c_file () = 41 | let fmt = Format.formatter_of_out_channel (open_out "src/libuv_accessors.c") in 42 | let p = (function [e, t, f] -> make_body e t f | _ -> failwith "bad") in 43 | let strings = List.map p accessors in 44 | Format.fprintf fmt "#include \"libuv_accessors.h\"\n\n"; 45 | Format.fprintf fmt "struct uv_stat_t* get_uv_fs_t_statbuf(const uv_fs_t* v) { return (struct uv_stat_t*)&(v->statbuf); }\n" ; 46 | List.iter (fun s -> Format.fprintf fmt "%s\n" s) strings 47 | 48 | let _ = 49 | make_header_file (); 50 | make_c_file () 51 | -------------------------------------------------------------------------------- /lib_gen/libuv_bindgen.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | let _ = 4 | let fmt = Format.formatter_of_out_channel (open_out "src/libuv_generated_stubs.c") in 5 | Format.fprintf fmt "#include @."; 6 | Format.fprintf fmt "#include @."; (* TODO might need a lot more *) 7 | Format.fprintf fmt "#include \"libuv_accessors.h\"@."; 8 | Cstubs.write_c fmt ~prefix:"caml_" (module Libuv_bindings.C); 9 | 10 | let fmt = Format.formatter_of_out_channel (open_out "src/libuv_generated.ml") in 11 | Cstubs.write_ml fmt ~prefix:"caml_" (module Libuv_bindings.C) 12 | -------------------------------------------------------------------------------- /lib_gen/libuv_bindings.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | module C(F : Cstubs.FOREIGN) = 4 | struct 5 | 6 | (** 7 | The first part of this giant file defines all of the types. 8 | These types need to be in here because the funptr type is defined 9 | in the Cstubs.FOREIGN module. 10 | 11 | The second part of the file defines the functions. 12 | 13 | Maybe later we'll split this up. 14 | 15 | NB the order the structs are sealed in matters. 16 | If struct a references struct b (ie has a non-pointer field to b) 17 | and struct b is not sealed you will receive a 18 | "Fatal error: exception Static.IncompleteType" when running libuv_bindgen 19 | *) 20 | 21 | (* types first, then callbacks, then structure fields *) 22 | 23 | (* Get the size of all of the types to be used to allocate them. 24 | We'll probably replace this soon with constants. *) 25 | let uv_handle_size = F.foreign "uv_handle_size" (int @-> returning size_t) 26 | let uv_req_size = F.foreign "uv_req_size" (int @-> returning size_t) 27 | 28 | (* TODO figure out what to do with this?*) 29 | type uv_sockaddr 30 | let uv_sockaddr : uv_sockaddr structure typ = structure "sockaddr" 31 | let sa_len = field uv_sockaddr "sa_len" uint8_t 32 | let sa_family = field uv_sockaddr "sa_family" uint8_t (* TODO typedef *) 33 | let sa_data = field uv_sockaddr "sa_data" (array 14 char) 34 | let () = seal uv_sockaddr 35 | 36 | type uv_sockaddr_in 37 | let uv_sockaddr_in : uv_sockaddr_in structure typ = structure "sockaddr_in" 38 | let sin_len = field uv_sockaddr_in "sin_len" uint8_t 39 | let sin_family = field uv_sockaddr_in "sin_family" uint8_t (* TODO Type *) 40 | let sin_data = field uv_sockaddr_in "sa_data" (array 14 char) (* XXX *) 41 | let () = seal uv_sockaddr_in 42 | (*let sin_port = field uv_sockaddr_in "sin_port" uint16_t (* TODO xplatform type *) 43 | let sin_addr = field uv_sockaddr_in "sin_addr" *) 44 | let uv_ip4_addr = F.foreign "uv_ip4_addr" 45 | (string @-> int @-> ptr uv_sockaddr_in @-> returning int) 46 | (* END *) 47 | 48 | (* PLATFORM SPECIFIC TYPES *) 49 | type uv__io 50 | let uv__io : uv__io structure typ = structure "uv__io_t" 51 | (* END PLATFORM SPECIFIC TYPES *) 52 | 53 | (* uv_loop *) 54 | type uv_loop = unit ptr 55 | let uv_loop : uv_loop typ = ptr void 56 | 57 | (* uv_buf *) 58 | type uv_buf 59 | let uv_buf : uv_buf structure typ = structure "uv_buf_t" 60 | let _uv_buf_base = field uv_buf "base" (ptr char) (* bigarray *) 61 | let _uv_buf_len = field uv_buf "len" size_t 62 | let () = seal uv_buf (* TODO this is a platform dependent type *) 63 | 64 | (* uv_handle *) 65 | type uv_handle 66 | let uv_handle : uv_handle structure typ = structure "uv_handle_s" 67 | let uv_close_cb = ptr uv_handle @-> returning void 68 | let uv_alloc_cb = ptr uv_handle @-> size_t @-> ptr uv_buf @-> returning void 69 | 70 | let add_handle_fields s = 71 | let ( -: ) ty label = field s label ty in 72 | let data = ptr void -: "data" in 73 | let loop = uv_loop -: "loop" in 74 | let handle_type = int -: "type" in 75 | let close_cb = Foreign.funptr uv_close_cb -: "close_cb" in 76 | let handle_queue = (array 2 (ptr void)) -: "handle_queue" in 77 | let reserved = (array 4 (ptr void)) -: "reserved" in 78 | (* UV_HANDLE_PRIVATE_FIELDS for unix XXX TODO *) 79 | let next_closing = ptr uv_handle -: "next_closing" in (* TODO check type *) 80 | let flags = uint -: "flags" in 81 | (* END*) 82 | (data, loop, handle_type, close_cb, handle_queue, reserved, next_closing, flags) 83 | 84 | let _ = add_handle_fields uv_handle 85 | let () = seal uv_handle 86 | 87 | (* uv_stream *) 88 | type uv_stream 89 | let uv_stream : uv_stream structure typ = structure "uv_stream_s" 90 | let uv_read_cb = ptr uv_stream @-> PosixTypes.ssize_t 91 | @-> ptr uv_buf @-> returning void 92 | 93 | (* uv_tcp *) 94 | type uv_tcp 95 | let uv_tcp : uv_tcp structure typ = structure "uv_tcp_s" 96 | 97 | (* uv_shutdown *) 98 | type uv_shutdown 99 | let uv_shutdown : uv_shutdown structure typ = structure "uv_shutdown_s" 100 | 101 | (* uv_write *) 102 | type uv_write_t 103 | let uv_write_t : uv_write_t structure typ = structure "uv_write_s" 104 | 105 | (* Callbacks *) 106 | let uv_connection_cb = ptr uv_stream @-> int @-> returning void 107 | (* Platform specific callbacks (Unix) *) 108 | let uv__io_cb = uv_loop @-> ptr uv__io @-> uint @-> returning void 109 | 110 | (* Structure Fields *) 111 | 112 | (* uv__io *) 113 | let make_uv__io_fields s = 114 | let ( -: ) ty label = field s label ty in 115 | let cb = field uv__io "cb" (Foreign.funptr uv__io_cb) in 116 | let pending_queue = (array 2 (ptr void)) -: "pending_queue" in 117 | let watcher_queue = (array 2 (ptr void)) -: "watcher_queue" in 118 | let pevents = uint -: "pevents" in 119 | let events = uint -: "events" in 120 | let fd = int -: "fd" in 121 | (* UV_IO_PRIVATE_PLATFORM_FIELDS darwin TODO (for linux comment these out) *) 122 | let rcount = int -: "rcount" in 123 | let wcount = int -: "wcount" in 124 | (* END *) 125 | (cb, pending_queue, watcher_queue, pevents, events, fd, rcount, wcount) 126 | let _ = make_uv__io_fields uv__io 127 | let () = seal uv__io 128 | 129 | let abstr name size = abstract ~name:name ~size:size ~alignment:4 130 | (* TODO(tss) figure out alignment *) 131 | 132 | (* uv_connect *) 133 | type uv_connect 134 | let uv_connect : uv_connect abstract typ = abstr "uv_connect_t" Uv_consts.size_of_uv_connect_t 135 | let uv_connect_cb = ptr uv_connect @-> int @-> returning void 136 | 137 | let add_stream_fields s = 138 | let ( -: ) ty label = field s label ty in 139 | let write_queue_size = size_t -: "write_queue_size" in 140 | let alloc_cb = Foreign.funptr uv_alloc_cb -: "alloc_cb" in 141 | let read_cb = Foreign.funptr uv_read_cb -: "read_cb" in 142 | (* UV_STREAM_PRIVATE_FIELDS for unix XXX TODO *) 143 | let connect_req = ptr uv_connect -: "connect_req" in 144 | let shutdown_req = ptr uv_shutdown -: "shutdown_req" in 145 | let io_watcher = uv__io -: "io_watcher" in 146 | let write_queue = (array 2 (ptr void)) -: "write_queue" in 147 | let write_completed_queue = (array 2 (ptr void)) -: "write_completed_queue" in 148 | let connection_cb = Foreign.funptr uv_connection_cb -: "connection_cb" in 149 | let delayed_error = int -: "delayed_error" in 150 | let accepted_fd = int -: "accepted_fd" in 151 | let queued_fds = ptr void -: "queued_fds" in 152 | (* UV_STREAM_PRIVATE_PLATFORM_FIELDS darwin TODO *) 153 | let select = ptr void -: "select" in 154 | (* END *) 155 | (* END *) 156 | (write_queue_size, alloc_cb, read_cb, 157 | connect_req, shutdown_req, io_watcher, write_queue, write_completed_queue, 158 | connection_cb, delayed_error, accepted_fd, queued_fds, select) 159 | let _ = add_handle_fields uv_stream 160 | let _ = add_stream_fields uv_stream 161 | 162 | let () = seal uv_stream 163 | 164 | (* uv_tcp *) 165 | let _ = add_handle_fields uv_tcp 166 | let _ = add_stream_fields uv_tcp 167 | (* TODO private *) 168 | let () = seal uv_tcp 169 | 170 | (* uv_timespec *) 171 | type uv_timespec 172 | let uv_timespec : uv_timespec structure typ = structure "uv_timespec_t" 173 | let _tv_sec = field uv_timespec "tv_sec" long 174 | let _tv_nsec = field uv_timespec "tv_nsec" long 175 | let () = seal uv_timespec 176 | 177 | (* uv_stat *) 178 | type uv_stat 179 | let uv_stat : uv_stat structure typ = structure "uv_stat_t" 180 | let _st_dev = field uv_stat "st_dev" uint64_t 181 | let _st_mode = field uv_stat "st_mode" uint64_t 182 | let _st_nlink = field uv_stat "st_nlink" uint64_t 183 | let _st_uid = field uv_stat "st_uid" uint64_t 184 | let _st_gid = field uv_stat "st_gid" uint64_t 185 | let _st_rdev = field uv_stat "st_rdev" uint64_t 186 | let _st_ino = field uv_stat "st_ino" uint64_t 187 | let _st_size = field uv_stat "st_size" uint64_t 188 | let _st_blksize = field uv_stat "st_blksize" uint64_t 189 | let _st_blocks = field uv_stat "st_blocks" uint64_t 190 | let _st_flags = field uv_stat "st_flags" uint64_t 191 | let _st_gen = field uv_stat "st_gen" uint64_t 192 | let _st_atim = field uv_stat "st_atim" uv_timespec 193 | let _st_mtim = field uv_stat "st_mtim" uv_timespec 194 | let _st_ctim = field uv_stat "st_ctim" uv_timespec 195 | let _st_birthtim = field uv_stat "st_birthtim" uv_timespec 196 | let () = seal uv_stat 197 | 198 | (* uv_req *) 199 | let add_req_fields s = 200 | let ( -: ) ty label = field s label ty in 201 | let data = ptr void -: "data" in 202 | let req_type = long -: "type" in 203 | let active_queue = (array 2 (ptr void)) -: "active_queue" in 204 | let reserved = (array 4 (ptr void)) -: "reserved" in 205 | (data, req_type, active_queue, reserved) (* TODO private fields *) 206 | 207 | (* uv_shutdown *) 208 | let uv_shutdown_cb = ptr uv_shutdown @-> int @-> returning void 209 | let _ = add_req_fields uv_shutdown 210 | let _handle = field uv_shutdown "handle" (ptr uv_stream) 211 | let _shutdown_cb = field uv_shutdown "cb" (Foreign.funptr uv_shutdown_cb) 212 | let () = seal uv_shutdown (* TODO private *) 213 | 214 | (* uv_write *) 215 | let uv_write_cb = ptr uv_write_t @-> int @-> returning void 216 | let add_write_req_fields s = 217 | let ( -: ) ty label = field s label ty in 218 | let cb = Foreign.funptr uv_write_cb -: "cb" in 219 | let send_handle = ptr uv_stream -: "send_handle" in 220 | let handle = ptr uv_stream -: "handle" in (* TODO do these need accessors? *) 221 | (* UV_WRITE_PRIVATE_FIELDS for unix *) 222 | let queue = array 2 (ptr void) -: "queue" in 223 | let write_index = uint -: "write_index" in 224 | let bufs = ptr uv_buf -: "bufs" in 225 | let nbufs = uint -: "nbufs" in 226 | let error = int -: "error" in 227 | let bufsml = array 4 uv_buf -: "bufsml" in 228 | (* END *) 229 | (cb, send_handle, handle, queue, write_index, bufs, nbufs, error, bufsml) 230 | let _ = add_req_fields uv_write_t 231 | let _ = add_write_req_fields uv_write_t 232 | let () = seal uv_write_t 233 | 234 | (* uv_fs *) 235 | type uv_fs 236 | let uv_fs : uv_fs abstract typ = abstr "uv_fs_t" Uv_consts.size_of_uv_fs_t 237 | (* When we need one of these we allocate a char array of sizeof(uv_fs) then 238 | coerce it to this type. *) 239 | let uv_fs_cb = ptr uv_fs @-> returning void 240 | 241 | (* uv_dirent *) 242 | type uv_dirent 243 | let uv_dirent : uv_dirent structure typ = structure "uv_dirent_s" 244 | 245 | let ( -: ) ty label = field uv_dirent label ty 246 | let _name = string -: "name" 247 | let _type = long -: "type" 248 | let () = seal uv_dirent 249 | 250 | (* Begin functions *) 251 | 252 | (* Accessors *) 253 | let get_uv_handle_t_loop = F.foreign "get_uv_handle_t_loop" 254 | (ptr uv_handle @-> returning uv_loop) 255 | 256 | let get_uv_fs_t_loop = F.foreign "get_uv_fs_t_loop" 257 | (ptr uv_fs @-> returning uv_loop) 258 | 259 | let get_uv_fs_t_result = F.foreign "get_uv_fs_t_result" 260 | (ptr uv_fs @-> returning PosixTypes.ssize_t) 261 | 262 | let get_uv_fs_t_path = F.foreign "get_uv_fs_t_path" 263 | (ptr uv_fs @-> returning string) 264 | 265 | let get_uv_fs_t_bufs = F.foreign "get_uv_fs_t_bufs" 266 | (ptr uv_fs @-> returning (ptr uv_buf)) (* XXX TMP going to nix this. *) 267 | 268 | let get_uv_fs_t_statbuf = F.foreign "get_uv_fs_t_statbuf" 269 | (ptr uv_fs @-> returning (ptr uv_stat))(* XXX TMP going to nix this. *) 270 | 271 | (* uv_handle functions *) 272 | let uv_close = F.foreign "uv_close" 273 | (ptr uv_handle @-> Foreign.funptr_opt uv_close_cb @-> returning void) 274 | 275 | (* uv_stream functions *) 276 | let uv_listen = F.foreign "uv_listen" 277 | (ptr uv_stream @-> int @-> Foreign.funptr_opt uv_connection_cb @-> returning int) 278 | 279 | let uv_accept = F.foreign "uv_accept" 280 | (ptr uv_stream @-> ptr uv_stream @-> returning int) 281 | 282 | let uv_read_start = F.foreign "uv_read_start" 283 | (* TODO is this alloc cb optional? *) 284 | (ptr uv_stream @-> Foreign.funptr uv_alloc_cb @-> 285 | Foreign.funptr_opt uv_read_cb @-> returning int) 286 | 287 | let uv_write = F.foreign "uv_write" 288 | (* TODO should the ptr buf_t be array buf_t? *) 289 | (ptr uv_write_t @-> ptr uv_stream @-> ptr uv_buf @-> uint @-> 290 | Foreign.funptr_opt uv_write_cb @-> returning int) 291 | 292 | (* tcp functions *) 293 | let uv_tcp_init = F.foreign "uv_tcp_init" 294 | (uv_loop @-> ptr uv_tcp @-> returning int) 295 | 296 | let uv_tcp_bind = F.foreign "uv_tcp_bind" 297 | (ptr uv_tcp @-> ptr uv_sockaddr @-> uint @-> returning int) 298 | 299 | let uv_tcp_connect = F.foreign "uv_tcp_connect" 300 | (ptr uv_connect @-> ptr uv_tcp @-> ptr uv_sockaddr @-> 301 | Foreign.funptr uv_connect_cb @-> returning int) 302 | 303 | let uv_tcp_nodelay = F.foreign "uv_tcp_nodelay" 304 | (ptr uv_tcp @-> int @-> returning int) 305 | 306 | let uv_tcp_keepalive = F.foreign "uv_tcp_keepalive" 307 | (ptr uv_tcp @-> int @-> uint @-> returning int) 308 | 309 | let uv_tcp_simultaneous_accepts = F.foreign "uv_tcp_simultaneous_accepts" 310 | (ptr uv_tcp @-> int @-> returning int) 311 | 312 | let uv_tcp_getsockname = F.foreign "uv_tcp_getsockname" 313 | (ptr uv_tcp @-> ptr uv_sockaddr @-> ptr int @-> returning int) 314 | 315 | let uv_tcp_getpeername = F.foreign "uv_tcp_getpeername" 316 | (ptr uv_tcp @-> ptr uv_sockaddr @-> ptr int @-> returning int) 317 | 318 | let uv_tcp_open = F.foreign "uv_tcp_open" 319 | (ptr uv_tcp @-> int @-> returning int) 320 | 321 | (* uv_loop functions *) 322 | let uv_default_loop = F.foreign "uv_default_loop" (void @-> returning uv_loop) 323 | 324 | let uv_run = F.foreign "uv_run" (uv_loop @-> int @-> returning int) 325 | 326 | (* uv_fs functions *) 327 | let uv_fs_req_cleanup = F.foreign "uv_fs_req_cleanup" 328 | (ptr uv_fs @-> returning void) 329 | 330 | let uv_fs_close = F.foreign "uv_fs_close" 331 | (uv_loop @-> ptr uv_fs @-> int @-> 332 | Foreign.funptr uv_fs_cb @-> returning int) 333 | 334 | let uv_fs_open = F.foreign "uv_fs_open" 335 | (uv_loop @-> ptr uv_fs @-> string @-> int @-> 336 | int @-> Foreign.funptr uv_fs_cb @-> returning int) 337 | 338 | let uv_fs_read = F.foreign "uv_fs_read" 339 | (uv_loop @-> ptr uv_fs @-> int @-> ptr uv_buf @-> 340 | int @-> long @-> Foreign.funptr uv_fs_cb @-> returning int) 341 | 342 | let uv_fs_unlink = F.foreign "uv_fs_unlink" 343 | (uv_loop @-> ptr uv_fs @-> string @-> 344 | Foreign.funptr uv_fs_cb @-> returning int) 345 | 346 | let uv_fs_write = F.foreign "uv_fs_write" 347 | (uv_loop @-> ptr uv_fs @-> int @-> ptr uv_buf @-> 348 | int @-> long @-> Foreign.funptr uv_fs_cb @-> returning int) 349 | 350 | let uv_fs_mkdir = F.foreign "uv_fs_mkdir" 351 | (uv_loop @-> ptr uv_fs @-> string @-> int @-> 352 | Foreign.funptr uv_fs_cb @-> returning int) 353 | 354 | let uv_fs_mkdtemp = F.foreign "uv_fs_mkdtemp" 355 | (uv_loop @-> ptr uv_fs @-> string @-> 356 | Foreign.funptr uv_fs_cb @-> returning int) 357 | 358 | let uv_fs_rmdir = F.foreign "uv_fs_rmdir" 359 | (uv_loop @-> ptr uv_fs @-> string @-> 360 | Foreign.funptr uv_fs_cb @-> returning int) 361 | 362 | (* Scandir is not present until 1.0.0, which I don't have installed. 363 | * let uv_fs_scandir = F.foreign "uv_fs_scandir" 364 | * (uv_loop @-> ptr uv_fs @-> string @-> int @-> 365 | * Foreign.funptr uv_fs_cb @-> returning int) 366 | * 367 | * let uv_fs_scandir_next = F.foreign "uv_fs_scandir_next" 368 | * (ptr uv_fs @-> ptr uv_dirent @-> returning int) *) 369 | 370 | let uv_fs_stat = F.foreign "uv_fs_stat" 371 | (uv_loop @-> ptr uv_fs @-> string @-> 372 | Foreign.funptr uv_fs_cb @-> returning int) 373 | 374 | let uv_fs_fstat = F.foreign "uv_fs_fstat" 375 | (uv_loop @-> ptr uv_fs @-> int @-> 376 | Foreign.funptr uv_fs_cb @-> returning int) 377 | 378 | let uv_fs_lstat = F.foreign "uv_fs_lstat" 379 | (uv_loop @-> ptr uv_fs @-> string @-> 380 | Foreign.funptr uv_fs_cb @-> returning int) 381 | 382 | let uv_fs_rename = F.foreign "uv_fs_rename" 383 | (uv_loop @-> ptr uv_fs @-> string @-> string @-> 384 | Foreign.funptr uv_fs_cb @-> returning int) 385 | 386 | let uv_fs_fsync = F.foreign "uv_fs_fsync" 387 | (uv_loop @-> ptr uv_fs @-> int @-> 388 | Foreign.funptr uv_fs_cb @-> returning int) 389 | 390 | let uv_fs_fdatasync = F.foreign "uv_fs_fdatasync" 391 | (uv_loop @-> ptr uv_fs @-> int @-> 392 | Foreign.funptr uv_fs_cb @-> returning int) 393 | 394 | let uv_fs_ftruncate = F.foreign "uv_fs_ftruncate" 395 | (uv_loop @->ptr uv_fs @-> int @-> int64_t @-> 396 | Foreign.funptr uv_fs_cb @-> returning int) 397 | 398 | let uv_fs_sendfile = F.foreign "uv_fs_sendfile" 399 | (uv_loop @-> ptr uv_fs @-> int @-> int @-> 400 | int64_t @-> size_t @-> 401 | Foreign.funptr uv_fs_cb @-> returning int) 402 | 403 | let uv_fs_chmod = F.foreign "uv_fs_chmod" 404 | (uv_loop @-> ptr uv_fs @-> string @-> int @-> 405 | Foreign.funptr uv_fs_cb @-> returning int) 406 | 407 | let uv_fs_fchmod = F.foreign "uv_fs_fchmod" 408 | (uv_loop @-> ptr uv_fs @-> int @-> int @-> 409 | Foreign.funptr uv_fs_cb @-> returning int) 410 | 411 | let uv_fs_utime = F.foreign "uv_fs_utime" 412 | (uv_loop @-> ptr uv_fs @-> string @-> double @-> double @-> 413 | Foreign.funptr uv_fs_cb @-> returning int) 414 | 415 | let uv_fs_futime = F.foreign "uv_fs_futime" 416 | (uv_loop @-> ptr uv_fs @-> int @-> double @-> double @-> 417 | Foreign.funptr uv_fs_cb @-> returning int) 418 | 419 | let uv_fs_link = F.foreign "uv_fs_link" 420 | (uv_loop @-> ptr uv_fs @-> string @-> string @-> 421 | Foreign.funptr uv_fs_cb @-> returning int) 422 | 423 | let uv_fs_symlink = F.foreign "uv_fs_symlink" 424 | (uv_loop @-> ptr uv_fs @-> string @-> string @-> int @-> 425 | Foreign.funptr uv_fs_cb @-> returning int) 426 | 427 | let uv_fs_readlink = F.foreign "uv_fs_readlink" 428 | (uv_loop @-> ptr uv_fs @-> string @-> 429 | Foreign.funptr uv_fs_cb @-> returning int) 430 | 431 | let uv_fs_chown = F.foreign "uv_fs_chown" 432 | (uv_loop @-> ptr uv_fs @-> string @-> 433 | PosixTypes.uid_t @-> PosixTypes.gid_t @-> 434 | Foreign.funptr uv_fs_cb @-> returning int) 435 | 436 | let uv_fs_fchown = F.foreign "uv_fs_fchown" 437 | (uv_loop @-> ptr uv_fs @-> int @-> 438 | PosixTypes.uid_t @-> PosixTypes.gid_t @-> 439 | Foreign.funptr uv_fs_cb @-> returning int) 440 | end 441 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin;; 2 | 3 | let make_accessors () = 4 | (* Create the accessor wrapper c and h files. 5 | 1) Compile the ocaml script that generates these two files 6 | 2) Run it 7 | 3) Compile the c file into an object file 8 | 4) Add dependencies *) 9 | flag ["compile"; "use_accessor_headers"] (S[A"-I"; Px ("../src")]); 10 | flag ["compile"; "use_ctypes_c_headers"] (S[A"-I"; Px ("../src")]); 11 | rule "generate libuv_accessors.{c,h}" 12 | ~prods:["src/libuv_accessors.c"; "src/libuv_accessors.h"] 13 | ~deps: ["lib_gen/libuv_accessor_gen.byte"] 14 | (fun _ _ -> Cmd (S[P"lib_gen/libuv_accessor_gen.byte"])); 15 | flag ["ocaml"; "compile"; "use_accessors"] (S[Px"src/libuv_accessors.o"]); 16 | dep ["ocaml"; "use_accessors"] ["src/libuv_accessors.o"] 17 | ;; 18 | 19 | let uv_consts_build () = 20 | dep [ "link"; "ocaml"; "link_consts_stub" ] [ "lib_gen/consts_stub.o" ]; 21 | dep [ "use_uv_consts" ] [ "src/uv_consts.ml" ]; 22 | rule "uv_consts: consts_gen.byte -> uv_consts.ml" 23 | ~dep:"lib_gen/consts_gen.byte" 24 | ~prod:"src/uv_consts.ml" 25 | begin fun env build -> 26 | (* This is brittle! The generation file outputs to src/filename.ml 27 | depending on the order the ocamlbuild's execution that dir will 28 | or won't exist. The mkdir line below obviously ensures it exists. 29 | Probably a better way to go about doing this. *) 30 | let enums = env "lib_gen/consts_gen.byte" in 31 | let prod = env "src/uv_consts.ml" in 32 | let ensure_src = Cmd (Sh "mkdir -p src") in 33 | let generate = Cmd (S [A enums; A prod]) in 34 | Seq [ensure_src; generate] 35 | end; 36 | ;; 37 | 38 | dispatch begin function 39 | | Before_options -> 40 | Options.use_ocamlfind := true 41 | | After_rules -> 42 | rule "generated c & ml" 43 | ~prods:["src/libuv_generated_stubs.c"; "src/libuv_generated.ml"] 44 | ~deps: ["lib_gen/libuv_bindgen.byte"] 45 | (fun _ _ -> Cmd (S[P"lib_gen/libuv_bindgen.byte"])); 46 | let ctypes = Findlib.query "ctypes" in 47 | flag ["compile"; "use_ctypes_c_headers"] (S[A"-I"; Px (ctypes.Findlib.location ^ "/..")]); 48 | flag ["compile"; "use_ctypes_c_headers"] (S[A"-I"; Px ("../lib_gen")]); 49 | flag ["ocaml"; "compile"; "use_libuv_generated_stubs"] (S[Px"src/libuv_generated_stubs.o"]); 50 | dep ["ocaml"; "use_accessors"] ["src/libuv_accessors.o"]; 51 | dep ["ocaml"; "use_libuv_generated_stubs"] ["src/libuv_generated_stubs.o"]; 52 | flag ["ocaml"; "link"; "use_libuv"] (S[A"-cclib"; A"-luv"]); 53 | uv_consts_build (); 54 | make_accessors () 55 | | _ -> () 56 | end 57 | -------------------------------------------------------------------------------- /src/buf.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 10 | (** The type of io buffers. *) 11 | -------------------------------------------------------------------------------- /src/coat_check.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | (** 10 | Locking: 11 | This is the most straight-forward implementation of thread safe locking. 12 | Once we get this going and profiled it is likely we'll want to replace 13 | it with something more performant. 14 | *) 15 | 16 | module HashPhysical = Hashtbl.Make 17 | (struct 18 | type t = int 19 | let hash = Hashtbl.hash 20 | let equal = ( == ) 21 | end) 22 | 23 | type t = {tbl : Obj.t HashPhysical.t; lock : Mutex.t} 24 | 25 | type ticket_stub = int 26 | 27 | let create () = 28 | let tbl = HashPhysical.create 10 in 29 | let lock = Mutex.create () in 30 | {tbl; lock} 31 | 32 | let ticket _ = 33 | Oo.id (object end) 34 | 35 | let store {tbl; lock} id s = 36 | let obj = Obj.repr s in 37 | Mutex.lock lock; 38 | HashPhysical.add tbl id obj; 39 | Mutex.unlock lock 40 | 41 | let forget {tbl; lock} id = 42 | Mutex.lock lock; 43 | HashPhysical.remove tbl id; 44 | Mutex.unlock lock 45 | -------------------------------------------------------------------------------- /src/coat_check.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | (** 10 | A forgetful coat check. You can give something to the coat check with 11 | a ticket and it will store that for you. 12 | You can never get your object back. The coat check can forget that it 13 | is holding on to something for you, if you ask it to. 14 | A questionably useful coat check! 15 | *) 16 | 17 | type t 18 | 19 | type ticket_stub 20 | 21 | val create : unit -> t 22 | 23 | val ticket : t -> ticket_stub 24 | 25 | val store : t -> ticket_stub -> 'a -> unit 26 | 27 | val forget : t -> ticket_stub -> unit 28 | -------------------------------------------------------------------------------- /src/refcount.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | type 'a t = ('a, int) Hashtbl.t 10 | 11 | let create () = Hashtbl.create 10 (* TODO figure out what this should be *) 12 | 13 | let incr t s = 14 | if Hashtbl.mem t s then 15 | Hashtbl.replace t s ((Hashtbl.find t s) + 1) 16 | else 17 | Hashtbl.add t s 0 18 | 19 | let decr t s = 20 | let count = Hashtbl.find t s in 21 | if count > 0 then 22 | Hashtbl.replace t s (count - 1) 23 | else 24 | Hashtbl.remove t s 25 | -------------------------------------------------------------------------------- /src/refcount.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | (* A reference counter: maintains a reference to an object until its count goes 10 | * to zero; useful for preventing GC cleaning up function callbacks passed to 11 | * libuv calls *) 12 | type 'a t 13 | 14 | (* Empty reference counter *) 15 | val create : unit -> 'a t 16 | 17 | (* Increment the number of references to an object *) 18 | val incr : 'a t -> 'a -> unit 19 | 20 | (* Decrement the number of references to an object, removing it if the count 21 | * drops to zero *) 22 | val decr : 'a t -> 'a -> unit 23 | -------------------------------------------------------------------------------- /src/util.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | let to_bigarray s = 10 | let len = String.length s in 11 | let t = Bigarray.(Array1.create char c_layout len) in 12 | for i = 0 to len - 1 do t.{i} <- s.[i] done; 13 | t 14 | 15 | let c_len ba = 16 | (* Return length of a bigarray representing a null terminated c string 17 | Returns the length of the bigarray if there is no null. *) 18 | let len = ref (Bigarray.Array1.dim ba) in 19 | begin 20 | try 21 | for i = 0 to (!len - 1) do 22 | if ba.{i} = '\000' then 23 | (len := i; raise Exit) 24 | done 25 | with Exit -> () 26 | end; 27 | !len 28 | 29 | let of_bigarray ba = 30 | let len = c_len ba in 31 | let b = Bytes.create len in 32 | for i = 0 to len - 1 do Bytes.set b i ba.{i} done; 33 | Bytes.to_string b 34 | -------------------------------------------------------------------------------- /src/uv.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open Ctypes 10 | open Foreign 11 | 12 | type error = Uv_consts.error 13 | 14 | let error_to_string = Uv_consts.error_to_string 15 | 16 | type 'a result = Ok of 'a | Error of error 17 | 18 | type status = unit result 19 | 20 | let ok : status = Ok () 21 | (* Convenience *) 22 | 23 | let ok_exn = function 24 | Ok a -> a 25 | | Error e -> failwith (error_to_string e) 26 | 27 | let int_to_status = function 28 | i when i = 0 -> ok 29 | | i when i < 0 -> Error (Uv_consts.int_to_error i) 30 | | _ -> failwith "This should never happen. Status code returned > 0." 31 | 32 | external caml_c_thread_register : unit -> int = "caml_c_thread_register" 33 | (* See DEVEL.md for more information *) 34 | 35 | module C = Libuv_bindings.C(Libuv_generated) 36 | 37 | type iobuf = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 38 | 39 | let make_buft buf = 40 | (* Note we return the struct and not the address because we need to 41 | keep a reference to the allocated struct during the callback *) 42 | let buf_data = make C.uv_buf in 43 | let buf_ptr = bigarray_start array1 buf in 44 | let buf_len = Bigarray.Array1.dim buf in 45 | let () = setf buf_data C._uv_buf_base buf_ptr in 46 | let () = setf buf_data C._uv_buf_len (Unsigned.Size_t.of_int buf_len) in 47 | buf_data 48 | 49 | type timespec = { 50 | tv_sec : int64; 51 | tv_nsec : int64 (* TODO what type should these be? *) 52 | } 53 | 54 | let from_uv_timespec uv_t = 55 | let tv_sec = Signed.Long.to_int64 (getf uv_t C._tv_sec) in 56 | let tv_nsec = Signed.Long.to_int64 (getf uv_t C._tv_nsec) in 57 | {tv_sec; tv_nsec} 58 | 59 | module Loop = 60 | struct 61 | type t = C.uv_loop 62 | type run_mode = RunDefault | RunOnce | RunNoWait 63 | 64 | let run_mode_to_int = function 65 | RunDefault -> 0 66 | | RunOnce -> 1 67 | | RunNoWait -> 2 68 | 69 | let default_loop = C.uv_default_loop 70 | 71 | let run ?(loop=default_loop()) run_mode = 72 | let ret = C.uv_run loop (run_mode_to_int run_mode) in 73 | int_to_status ret 74 | 75 | end 76 | 77 | let default_loop = Loop.default_loop () 78 | 79 | type stat = { 80 | (* Note a lot of these types have standard Posix types. libuv, being 81 | a cross platform library, does not use these types, and uses uint64_t 82 | for all of these fields. This struct follows suit. 83 | *) 84 | st_dev : int64; 85 | st_mode : int64; 86 | st_nlink : int64; 87 | st_uid : int64; 88 | st_gid : int64; 89 | st_rdev : int64; 90 | st_ino : int64; 91 | st_size : int64; 92 | st_blksize : int64; 93 | st_blocks : int64; 94 | st_flags : int64; 95 | st_gen : int64; 96 | st_atim : timespec; 97 | st_mtim : timespec; 98 | st_ctim : timespec; 99 | st_birthtim : timespec 100 | } 101 | 102 | 103 | module Request = 104 | struct 105 | type 'a t = unit ptr 106 | 107 | type write_req 108 | type write = write_req t 109 | 110 | let cancel req = failwith "Not Implemented" 111 | end 112 | 113 | module Handle = 114 | struct 115 | type 'a t = unit ptr 116 | 117 | let loop handle = 118 | let ptr = from_voidp C.uv_handle handle in 119 | C.get_uv_handle_t_loop ptr 120 | 121 | let close ?cb handle = 122 | (* assume handle is a void ptr *) 123 | let cb' = match cb with None -> None | Some f -> Some (fun x -> f(to_voidp x)) in 124 | let handle_ptr = from_voidp C.uv_handle handle in 125 | let _ = C.uv_close handle_ptr cb' in (* TODO exn *) 126 | () 127 | end 128 | 129 | module Stream = 130 | struct 131 | type 'a stream 132 | type 'a t = 'a stream Handle.t 133 | 134 | let refs = Refcount.create () 135 | let ref_incr = Refcount.incr refs 136 | let ref_decr = Refcount.decr refs 137 | 138 | let read_cb_refs = Refcount.create () 139 | let read_cb_ref_incr = Refcount.incr read_cb_refs 140 | let read_cb_ref_decr = Refcount.decr read_cb_refs 141 | 142 | let write_cb_refs = Refcount.create () 143 | let write_cb_ref_incr = Refcount.incr write_cb_refs 144 | let write_cb_ref_decr = Refcount.decr write_cb_refs 145 | 146 | let make_callback (cb : 'a t -> int -> unit) = 147 | let rec callback cb uv_stream = 148 | let finally () = ref_decr callback in 149 | (* This receives a uv_stream but we need a void ptr *) 150 | let stream : 'a t = to_voidp uv_stream in 151 | try cb stream 152 | with exn -> (* we got an exception. Clear gc ref and re-raise *) 153 | (finally (); 154 | raise exn) 155 | finally () 156 | in 157 | ref_incr callback; 158 | callback cb 159 | 160 | let make_callback_opt = function 161 | None -> None 162 | | Some cb -> Some (make_callback cb) 163 | 164 | let make_read_callback (cb : 't -> int -> Buf.t -> unit) = 165 | let rec callback cb uv_stream size buf = 166 | let finally () = read_cb_ref_decr cb in 167 | (* This receives a uv_stream but we need a void ptr *) 168 | let stream : 'a t = to_voidp uv_stream in 169 | (* This receives a uv_buf, we need a buf *) 170 | let ok = (getf (!@buf) C._uv_buf_base) in 171 | let len = Unsigned.Size_t.to_int (getf (!@buf) C._uv_buf_len) in 172 | let buf' = bigarray_of_ptr array1 len Bigarray.char ok in 173 | (* This receives a ssize_t, we need an int *) 174 | let size' = coerce PosixTypes.ssize_t int64_t size in 175 | let size' = Signed.Int64.to_int size' in (* TODO coerce is it ok? *) 176 | try cb stream size' buf' 177 | with exn -> (* we got an exception. Clear gc ref and re-raise *) 178 | (finally (); 179 | raise exn) 180 | finally () 181 | in 182 | read_cb_ref_incr cb; 183 | callback cb 184 | 185 | let make_read_callback_opt = function 186 | None -> None 187 | | Some cb -> Some (make_read_callback cb) 188 | 189 | let make_write_callback (cb : Request.write -> int -> unit) = 190 | let rec callback (cb : Request.write -> int -> unit) (req : C.uv_write_t structure ptr) (status : int) = 191 | let finally () = write_cb_ref_decr callback in 192 | (* from specific to void *) 193 | let req' : Request.write = to_voidp req in 194 | let v = cb req' in 195 | try v status 196 | with exn -> (* we got an exception. Clear gc ref and re-raise *) 197 | (finally (); 198 | raise exn) 199 | finally () 200 | in 201 | write_cb_ref_incr callback; 202 | callback cb 203 | 204 | let make_write_callback_opt = function 205 | None -> None 206 | | Some cb -> Some (make_write_callback cb) 207 | 208 | let listen ?cb stream backlog = 209 | let stream_ptr = from_voidp C.uv_stream stream in 210 | let cb' = make_callback_opt cb in 211 | let _ = C.uv_listen stream_ptr backlog cb' in (* TODO exn. TODO callback *) 212 | () 213 | 214 | let accept (server : 'a t) (client : 'a t) = 215 | let server_ptr = from_voidp C.uv_stream server in 216 | let client_ptr = from_voidp C.uv_stream client in 217 | let _ = C.uv_accept server_ptr client_ptr in (* TODO exn *) 218 | () 219 | 220 | let alloc_cb handle (suggested_size : PosixTypes.size_t) bufptr = 221 | (* Allocate suggested_size *) 222 | let size = Unsigned.Size_t.to_int suggested_size in 223 | let memory = Bigarray.(Array1.create char c_layout size) in 224 | let buf = !@bufptr in 225 | let _ = setf buf C._uv_buf_base (bigarray_start array1 memory) in 226 | let _ = setf buf C._uv_buf_len suggested_size in 227 | (* TODO deal with buffers *) 228 | () 229 | 230 | let read_start ?cb stream = 231 | let stream_ptr = from_voidp C.uv_stream stream in 232 | let cb' = make_read_callback_opt cb in 233 | let _ = C.uv_read_start stream_ptr alloc_cb cb' in (* TODO exn *) 234 | () 235 | 236 | let write ?cb stream buf = 237 | let uv_buf_ptr = addr (make_buft buf) in 238 | let nbufs = Unsigned.UInt.one in 239 | let req = addr (make C.uv_write_t) in 240 | (* convert from void *) 241 | let stream_ptr = from_voidp C.uv_stream stream in 242 | let cb' = make_write_callback_opt cb in 243 | let _ = C.uv_write req stream_ptr uv_buf_ptr nbufs cb' in 244 | to_voidp req 245 | 246 | end 247 | 248 | module Shutdown = 249 | struct 250 | type shutdown 251 | type t = shutdown Request.t 252 | end 253 | 254 | module FS = 255 | struct 256 | type fs 257 | type t = fs Request.t 258 | type iobuf = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 259 | 260 | let c_to_ocaml data = 261 | (* Convert from the value we pass to uv_* methods to the FS.t method *) 262 | to_voidp data 263 | 264 | let ocaml_to_c data = 265 | (* From FS.t to struct *) 266 | from_voidp C.uv_fs data 267 | 268 | let coatCheck = Coat_check.create () 269 | (* Stores callback closures and data while in the uv event loop *) 270 | 271 | let alloc_uv_fs () = 272 | let memory = allocate_n char ~count:(sizeof C.uv_fs) in 273 | coerce (ptr char) (ptr C.uv_fs) memory 274 | 275 | let make_callback cb (data : 'a) = 276 | (* There's something kind of subtle here: 277 | we need to pass the Ocaml user's callback function (cb) to libuv, so 278 | we'll need to wrap the user's function in a method that converts the 279 | ctype passed to the callback into an OCaml value. Call the ctype 280 | callback (ie the actual callback called by libuv cb'). 281 | So basically this look likes: 282 | 283 | let cb' arg = cb(make_ctype_into_ocaml_type(arg)) 284 | 285 | However we don't want that callback, nor the ocaml-allocated data 286 | to get gc'd before it is called. 287 | So we keep track of the callbacks (cb' mind you) and data in a coat 288 | check. We add cb' to the coat check right before passing it to libuv. 289 | And we remove cb' from the coat check right after calling the user's 290 | callback, cb. 291 | 292 | make_callback, does all of that. Looks a little dense, not so bad. 293 | 294 | This method also registers the thread with the ocaml subsystem. 295 | See more comments in DEVEL.md 296 | 297 | TODO I would like to think of a way to abstract the gc-avoidance 298 | part of this out so that it could be reused across all methods. 299 | *) 300 | let id = Coat_check.ticket coatCheck in 301 | let callback cb _uv_fs = 302 | (* Register the thread first thing. Ignore its return code. *) 303 | let _ = caml_c_thread_register () in 304 | let finally () = Coat_check.forget coatCheck id in 305 | let fs = c_to_ocaml _uv_fs in 306 | (* If we get an exception clear gc ref and re-raise *) 307 | let _ = try cb fs with exn -> finally (); raise exn in 308 | finally () 309 | in 310 | let storage = (callback, data) in 311 | Coat_check.store coatCheck id storage; 312 | callback cb 313 | 314 | let make_cb_and_data cb = 315 | (* Allocate the data and return the life-cycle'd cb. *) 316 | let data = alloc_uv_fs () in 317 | let cb' = make_callback cb data in 318 | (cb', data) 319 | 320 | let make_cb_and_data_rw cb buft = 321 | (* Allocate the data and return the life-cycle'd cb. *) 322 | let data = alloc_uv_fs () in 323 | let cb' = make_callback cb (data, buft) in 324 | (cb', data) 325 | 326 | let openfile ?(loop=default_loop) ?(perm=0o644) ~cb (filename : string) flags = 327 | let (cb', data) = make_cb_and_data cb in 328 | let ret = C.uv_fs_open loop data filename flags perm cb' in 329 | int_to_status ret 330 | 331 | let close ?(loop=default_loop) ~cb file = 332 | let (cb', data) = make_cb_and_data cb in 333 | let ret = C.uv_fs_close loop data file cb' in 334 | int_to_status ret 335 | 336 | let rw f ?(loop=default_loop) ?(offset=0) ~cb file buf = 337 | (* read and write functions are exactly the same, save for the 338 | actual call. This implements the body of both. 339 | 340 | 1) Wrap the user's callback so we provide the buffer back to them. 341 | 2) Keep a reference to the callback, fs struct, buf and 342 | buf_t struct to avoid gc. *) 343 | let cb' fs = cb fs buf in 344 | let buft = make_buft buf in 345 | let (cb'', data) = make_cb_and_data_rw cb' buft in 346 | let ret = f loop data file (addr buft) 1 (Signed.Long.of_int offset) cb'' in 347 | int_to_status ret 348 | 349 | let read ?(loop=default_loop) ?(offset=(-1)) ~cb file buf = 350 | rw C.uv_fs_read ~loop ~offset ~cb file buf 351 | 352 | let write ?(loop=default_loop) ?(offset=(-1)) ~cb file buf = 353 | rw C.uv_fs_write ~loop ~offset ~cb file buf 354 | 355 | let statbuf fs = 356 | let fs = ocaml_to_c fs in 357 | let sb = !@(C.get_uv_fs_t_statbuf fs) in 358 | let f conv field = conv (getf sb field) in 359 | let i = f Unsigned.UInt64.to_int64 in 360 | let t = f from_uv_timespec in 361 | let st_dev = i C._st_dev in 362 | let st_mode = i C._st_mode in 363 | let st_nlink = i C._st_nlink in 364 | let st_uid = i C._st_uid in 365 | let st_gid = i C._st_gid in 366 | let st_rdev = i C._st_rdev in 367 | let st_ino = i C._st_ino in 368 | let st_size = i C._st_size in 369 | let st_blksize = i C._st_blksize in 370 | let st_blocks = i C._st_blocks in 371 | let st_flags = i C._st_flags in 372 | let st_gen = i C._st_gen in 373 | let st_atim = t C._st_atim in 374 | let st_mtim = t C._st_mtim in 375 | let st_ctim = t C._st_ctim in 376 | let st_birthtim = t C._st_birthtim in 377 | {st_dev; st_mode; st_nlink; st_uid; st_gid; st_rdev; st_ino; st_size; 378 | st_blksize; st_blocks; st_flags; st_gen; st_atim; st_mtim; st_ctim; 379 | st_birthtim} 380 | 381 | let stat_wrapper cb = 382 | (* We want the user's callback to receive the stat structure as the second 383 | arg. This wraps the user callback and then gets the stat structure. 384 | The stat structure is a member of the fs struct, that, in libuv one 385 | accesses as a field. However, for most calls this field is null, 386 | which is why we're adding this layer of typing. *) 387 | let cb' fs = 388 | let stat = statbuf fs in 389 | cb fs stat 390 | in 391 | cb' 392 | 393 | let stat ?(loop=default_loop) ~cb (filename : string) = 394 | let cb' = stat_wrapper cb in 395 | let (cb'', data) = make_cb_and_data cb' in 396 | let ret = C.uv_fs_stat loop data filename cb'' in 397 | int_to_status ret 398 | 399 | let fstat ?(loop=default_loop) ~cb (fd : int) = 400 | let cb' = stat_wrapper cb in 401 | let (cb'', data) = make_cb_and_data cb' in 402 | let ret = C.uv_fs_fstat loop data fd cb'' in 403 | int_to_status ret 404 | 405 | let lstat ?(loop=default_loop) ~cb (filename : string) = 406 | let cb' = stat_wrapper cb in 407 | let (cb'', data) = make_cb_and_data cb' in 408 | let ret = C.uv_fs_lstat loop data filename cb'' in 409 | int_to_status ret 410 | 411 | let unlink ?(loop=default_loop) ~cb (filename : string) = 412 | let (cb', data) = make_cb_and_data cb in 413 | let ret = C.uv_fs_unlink loop data filename cb' in 414 | int_to_status ret 415 | 416 | let mkdir ?(loop=default_loop) ?(mode=0o775) ~cb (filename : string) = 417 | let (cb', data) = make_cb_and_data cb in 418 | let ret = C.uv_fs_mkdir loop data filename mode cb' in 419 | int_to_status ret 420 | 421 | let mkdtemp ?(loop=default_loop) ~cb (template : string) = 422 | assert ((Str.last_chars template 6) = "XXXXXX"); 423 | let (cb', data) = make_cb_and_data cb in 424 | let ret = C.uv_fs_mkdtemp loop data template cb' in 425 | int_to_status ret 426 | 427 | let rmdir ?(loop=default_loop) ~cb (path : string) = 428 | let (cb', data) = make_cb_and_data cb in 429 | let ret = C.uv_fs_rmdir loop data path cb' in 430 | int_to_status ret 431 | 432 | let rename ?(loop=default_loop) ~cb (path : string) (new_path : string) = 433 | let (cb', data) = make_cb_and_data cb in 434 | let ret = C.uv_fs_rename loop data path new_path cb' in 435 | int_to_status ret 436 | 437 | let fsync ?(loop=default_loop) ~cb (file : int) = 438 | let (cb', data) = make_cb_and_data cb in 439 | let ret = C.uv_fs_fsync loop data file cb' in 440 | int_to_status ret 441 | 442 | let fdatasync ?(loop=default_loop) ~cb (file : int) = 443 | let (cb', data) = make_cb_and_data cb in 444 | let ret = C.uv_fs_fdatasync loop data file cb' in 445 | int_to_status ret 446 | 447 | let ftruncate ?(loop=default_loop) ~cb (file : int) (offset : int) = 448 | let (cb', data) = make_cb_and_data cb in 449 | let ret = C.uv_fs_ftruncate loop data file (Int64.of_int offset) cb' in 450 | int_to_status ret 451 | 452 | let sendfile ?(loop=default_loop) ?(offset=0) ~cb (in_fd : int) (out_fd : int) (count : int) = 453 | let (cb', data) = make_cb_and_data cb in 454 | let ret = (C.uv_fs_sendfile loop data in_fd out_fd (Int64.of_int offset) 455 | (Unsigned.Size_t.of_int count) cb') in 456 | int_to_status ret 457 | 458 | let chmod ?(loop=default_loop) ~cb (path : string) (mode : int) = 459 | let (cb', data) = make_cb_and_data cb in 460 | let ret = C.uv_fs_chmod loop data path mode cb' in 461 | int_to_status ret 462 | 463 | (* Accessors *) 464 | 465 | let result fs = 466 | (* TODO double check what we want the return type of this to be. 467 | Is int correct? and will that function on 32 bit systems? *) 468 | let fs = ocaml_to_c fs in 469 | (* Get the result which is ssize_t, convert it to an ocaml int 470 | TODO -- ssize_t doesn't convert to a long or nativeint. 471 | Figure out what this should be. 472 | *) 473 | let result = C.get_uv_fs_t_result fs in 474 | let result = coerce PosixTypes.ssize_t int64_t result in 475 | let result = Int64.to_int result in 476 | if result >= 0 then 477 | Ok result 478 | else 479 | Error (Uv_consts.int_to_error result) 480 | 481 | let path fs = 482 | let fs = ocaml_to_c fs in 483 | C.get_uv_fs_t_path fs 484 | end 485 | 486 | 487 | (* TODO Figure what what we want to do with sockaddr. Use Unix stdlib? *) 488 | type mysock = C.uv_sockaddr structure ptr 489 | let ip4_addr str_addr port = 490 | let data = addr (make C.uv_sockaddr_in) in 491 | let _ = C.uv_ip4_addr str_addr port data in (* TODO exn *) 492 | coerce (ptr C.uv_sockaddr_in) (ptr C.uv_sockaddr) data 493 | 494 | type myossock = int 495 | 496 | module TCP = 497 | struct 498 | type tcp 499 | type t = tcp Stream.t 500 | type connect 501 | type c = connect Request.t 502 | 503 | let alloc_uv_tcp () = 504 | let memory = allocate_n char ~count:(sizeof C.uv_tcp) in 505 | coerce (ptr char) (ptr C.uv_tcp) memory 506 | 507 | let alloc_uv_connect () = 508 | let memory = allocate_n char ~count:(sizeof C.uv_connect) in 509 | coerce (ptr char) (ptr C.uv_connect) memory 510 | 511 | let coatCheck = Coat_check.create () 512 | (* Stores callback closures and data while in the uv event loop *) 513 | 514 | let c_to_ocaml data = 515 | (* Convert from the value we pass to uv_* methods to the TCP.t method *) 516 | to_voidp data 517 | 518 | let ocaml_to_c data = 519 | (* From TCP.t to struct *) 520 | from_voidp C.uv_tcp data 521 | 522 | let make_callback cb data = 523 | (* There's something kind of subtle here: 524 | we need to pass the Ocaml user's callback function (cb) to libuv, so 525 | we'll need to wrap the user's function in a method that converts the 526 | ctype passed to the callback into an OCaml value. Call the ctype 527 | callback (ie the actual callback called by libuv cb'). 528 | So basically this look likes: 529 | 530 | let cb' arg = cb(make_ctype_into_ocaml_type(arg)) 531 | 532 | However we don't want that callback, nor the ocaml-allocated data 533 | to get gc'd before it is called. 534 | So we keep track of the callbacks (cb' mind you) and data in a coat 535 | check. We add cb' to the coat check right before passing it to libuv. 536 | And we remove cb' from the coat check right after calling the user's 537 | callback, cb. 538 | 539 | make_callback, does all of that. Looks a little dense, not so bad. 540 | 541 | TODO I would like to think of a way to abstract the gc-avoidance 542 | part of this out so that it could be reused across all methods. 543 | *) 544 | let id = Coat_check.ticket coatCheck in 545 | let callback cb _uv_connect _status = 546 | let finally () = Coat_check.forget coatCheck id in 547 | let connect = c_to_ocaml _uv_connect in 548 | (* If we get an exception clear gc ref and re-raise *) 549 | let _ = try cb connect _status with exn -> finally (); raise exn in 550 | finally () 551 | in 552 | let storage = (callback, data) in 553 | Coat_check.store coatCheck id storage; 554 | callback cb 555 | 556 | let init ?(loop=default_loop) () : t = 557 | let data = addr (make C.uv_tcp) in 558 | let _ = C.uv_tcp_init loop data in (* TODO exn *) 559 | to_voidp data 560 | 561 | let bind tcp (sockaddr : mysock) flags = 562 | (* tcp is a void ptr *) 563 | let tcp_ptr = from_voidp C.uv_tcp tcp in 564 | let ret = C.uv_tcp_bind tcp_ptr sockaddr (Unsigned.UInt.of_int flags) in (* TODO exn *) 565 | int_to_status ret 566 | 567 | let connect tcp (sockaddr : mysock) ~cb = 568 | let connect = alloc_uv_connect () in 569 | let tcp_ptr = from_voidp C.uv_tcp tcp in 570 | let cb' = make_callback cb connect in 571 | let ret = C.uv_tcp_connect connect tcp_ptr sockaddr cb' in 572 | int_to_status ret 573 | 574 | let nodelay tcp enable = 575 | let tcp_ptr = from_voidp C.uv_tcp tcp in 576 | let ret = C.uv_tcp_nodelay tcp_ptr enable in 577 | int_to_status ret 578 | 579 | let keepalive tcp enable delay = 580 | let tcp_ptr = from_voidp C.uv_tcp tcp in 581 | let ret = C.uv_tcp_keepalive tcp_ptr enable delay in 582 | int_to_status ret 583 | 584 | let simultaneous_accepts tcp enable = 585 | let tcp_ptr = from_voidp C.uv_tcp tcp in 586 | let ret = C.uv_tcp_simultaneous_accepts tcp_ptr enable in 587 | int_to_status ret 588 | 589 | let getsockname tcp (sockaddr: mysock) = 590 | let tcp_ptr = from_voidp C.uv_tcp tcp in 591 | let length_ptr = allocate int 0 in 592 | let ret = C.uv_tcp_getsockname tcp_ptr sockaddr length_ptr in 593 | int_to_status ret 594 | 595 | let getpeername tcp (sockaddr: mysock) = 596 | let tcp_ptr = from_voidp C.uv_tcp tcp in 597 | let length_ptr = allocate int 0 in 598 | let ret = C.uv_tcp_getpeername tcp_ptr sockaddr length_ptr in 599 | int_to_status ret 600 | 601 | let open_socket tcp sock = 602 | let tcp_ptr = from_voidp C.uv_tcp tcp in 603 | let ret = C.uv_tcp_open tcp_ptr sock in 604 | int_to_status ret 605 | end 606 | -------------------------------------------------------------------------------- /src/uv.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open Ctypes 10 | open Foreign 11 | 12 | type error = Uv_consts.error 13 | (** Error type returned by functions or passed to callbacks *) 14 | 15 | val error_to_string : error -> string 16 | (** Error to a human readable message *) 17 | 18 | type 'a result = Ok of 'a | Error of error 19 | 20 | type status = unit result 21 | (** Return value for most functions *) 22 | 23 | val ok : status 24 | (** Convenience. Most all functions return Ok ().*) 25 | 26 | val ok_exn : 'a result -> 'a 27 | (** Convenience function. Failswith the error message if not Ok. *) 28 | 29 | type timespec = { 30 | tv_sec : int64; 31 | tv_nsec : int64 (* TODO what type should these be? *) 32 | } 33 | 34 | type stat = { 35 | (* Note a lot of these types have standard Posix types. libuv, being 36 | a cross platform library, does not use these types, and uses uint64_t 37 | for all of these fields. This struct follows suit. 38 | *) 39 | st_dev : int64; 40 | st_mode : int64; 41 | st_nlink : int64; 42 | st_uid : int64; 43 | st_gid : int64; 44 | st_rdev : int64; 45 | st_ino : int64; 46 | st_size : int64; 47 | st_blksize : int64; 48 | st_blocks : int64; 49 | st_flags : int64; 50 | st_gen : int64; 51 | st_atim : timespec; 52 | st_mtim : timespec; 53 | st_ctim : timespec; 54 | st_birthtim : timespec 55 | } 56 | 57 | module Loop : 58 | sig 59 | type t 60 | 61 | type run_mode = RunDefault | RunOnce | RunNoWait 62 | 63 | val default_loop : unit -> t 64 | 65 | val run : ?loop:t -> run_mode -> status 66 | end 67 | 68 | module Request : 69 | sig 70 | type 'a t 71 | 72 | (* Types that don't need their own modules *) 73 | 74 | type write_req 75 | (** Phantom type identifying write requests *) 76 | 77 | type write = write_req t 78 | (** The type of write requests *) 79 | 80 | val cancel : 'a t -> unit 81 | end 82 | 83 | module Handle : 84 | sig 85 | type 'a t 86 | 87 | val loop : 'a t -> Loop.t 88 | 89 | val close : ?cb:('a t -> unit) -> _ t -> unit 90 | end 91 | 92 | module Stream : 93 | sig 94 | type 'a stream 95 | (** Phantom type *) 96 | 97 | type 'a t = 'a stream Handle.t 98 | 99 | val listen : ?cb:('a t -> int -> unit) -> 'a t -> int -> unit 100 | val accept : 'a t -> 'a t -> unit 101 | val read_start : ?cb:('a t -> int -> Buf.t -> unit) -> 'a t -> unit 102 | val write : ?cb:(Request.write -> int -> unit) -> 'a t -> Buf.t -> Request.write 103 | end 104 | 105 | module Shutdown : 106 | sig 107 | type shutdown 108 | type t = shutdown Request.t 109 | end 110 | 111 | type iobuf = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 112 | 113 | module FS : 114 | sig 115 | type fs 116 | type t = fs Request.t 117 | 118 | val openfile : ?loop:Loop.t -> ?perm:int -> cb:(t -> unit) -> string -> int -> status (* TODO unix flags *) 119 | val close : ?loop:Loop.t -> cb:(t -> unit) -> int -> status 120 | 121 | val read : ?loop:Loop.t -> ?offset:int -> cb:(t -> iobuf -> unit) -> int -> iobuf -> status 122 | (** offset defaults to -1 which is use current offset. *) 123 | 124 | val write : ?loop:Loop.t -> ?offset:int -> cb:(t -> iobuf -> unit) -> int -> iobuf -> status 125 | (** offset defaults to -1 which is use current offset. *) 126 | 127 | val stat : ?loop:Loop.t -> cb:(t -> stat -> unit) -> string -> status 128 | val fstat : ?loop:Loop.t -> cb:(t -> stat -> unit) -> int -> status 129 | val lstat : ?loop:Loop.t -> cb:(t -> stat -> unit) -> string -> status 130 | val unlink : ?loop:Loop.t -> cb:(t -> unit) -> string -> status 131 | val mkdir : ?loop:Loop.t -> ?mode:int -> cb:(t -> unit) -> string -> status 132 | val mkdtemp : ?loop:Loop.t -> cb:(t -> unit) -> string -> status 133 | val rmdir : ?loop:Loop.t -> cb:(t -> unit) -> string -> status 134 | val rename : ?loop:Loop.t -> cb:(t -> unit) -> string -> string -> status 135 | val fsync : ?loop:Loop.t -> cb:(t -> unit) -> int -> status 136 | val fdatasync : ?loop:Loop.t -> cb:(t -> unit) -> int -> status 137 | val ftruncate : ?loop:Loop.t -> cb:(t -> unit) -> int -> int -> status 138 | val sendfile : ?loop:Loop.t -> ?offset:int -> cb:(t -> unit) -> int -> int -> 139 | int -> status 140 | val chmod : ?loop:Loop.t -> cb:(t -> unit) -> string -> int -> status 141 | (* TODO: scandir *) 142 | 143 | (* Accessor functions *) 144 | val result : t -> int result 145 | val path : t -> string 146 | end 147 | 148 | type mysock 149 | type myossock 150 | val ip4_addr : string -> int -> mysock 151 | 152 | module TCP : 153 | sig 154 | type tcp 155 | type t = tcp Stream.t 156 | type connect 157 | type c = connect Request.t 158 | 159 | val init : ?loop:Loop.t -> unit -> t 160 | val bind : t-> mysock (* TODO sockaddr *) -> int (* TODO flags*) -> status 161 | val connect : t -> mysock -> cb:(c -> int -> unit) -> status 162 | val nodelay : t -> int -> status 163 | val keepalive : t -> int -> Unsigned.uint -> status 164 | val simultaneous_accepts : t -> int -> status 165 | val getsockname : t -> mysock -> status 166 | val getpeername : t -> mysock -> status 167 | val open_socket : t -> myossock -> status 168 | end 169 | -------------------------------------------------------------------------------- /test/test_coat_check.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open OUnit 10 | 11 | let assert_not_equal a b = assert_equal ~cmp:( <> ) a b 12 | 13 | let test_same_object_different_ids _ = 14 | let check = Coat_check.create () in 15 | let tckt1 = Coat_check.ticket check in 16 | let tckt2 = Coat_check.ticket check in 17 | Coat_check.store check tckt1 "foo"; 18 | Coat_check.store check tckt2 "foo"; 19 | (* Not testing the collision didn't happen *) 20 | assert_not_equal tckt1 tckt2 21 | 22 | let test_polymorphic _ = 23 | let check = Coat_check.create () in 24 | let tckt1 = Coat_check.ticket check in 25 | let tckt2 = Coat_check.ticket check in 26 | Coat_check.store check tckt1 "foo"; 27 | Coat_check.store check tckt2 1; 28 | assert_not_equal tckt1 tckt2 29 | 30 | let suite = 31 | "coat check">::: 32 | [ 33 | "same object different tickets">::test_same_object_different_ids; 34 | "is not weakly polymorphic">::test_polymorphic; 35 | ] 36 | -------------------------------------------------------------------------------- /test/test_consts.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open OUnit 10 | 11 | (* This is here to ensure that the plumbing works in the whole 12 | compile consts from c to ocaml. *) 13 | 14 | let test_error_to_int _ = 15 | assert_equal (Uv_consts.error_to_int Uv_consts.UV_EOF) (-4095) 16 | 17 | let test_int_to_error _ = 18 | assert_equal (Uv_consts.int_to_error (-4095)) Uv_consts.UV_EOF 19 | 20 | let suite = 21 | "consts suite">::: 22 | ["error -> int">::test_error_to_int; 23 | "int -> error">::test_int_to_error; 24 | ] 25 | -------------------------------------------------------------------------------- /test/test_fs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open OUnit 10 | open Ctypes 11 | open Uv 12 | 13 | let assert_not_equal = assert_equal ~cmp:( <> ) 14 | 15 | let ( !! ) r = ok_exn r 16 | 17 | let run () = !! (Loop.run Loop.RunDefault) 18 | 19 | let mk_buf () = Bigarray.(Array1.create char c_layout 1024) 20 | 21 | let mk_tmpfile contents : string = 22 | let (tmpfile_name, chan) = Filename.open_temp_file "foo" "txt" in 23 | output_string chan contents; 24 | close_out chan; 25 | tmpfile_name 26 | 27 | let mkdtemp () : string = 28 | let tmpdir = Filename.temp_file "foo" ".tmp" in 29 | Unix.unlink tmpdir; 30 | Unix.mkdir tmpdir 0o755; 31 | tmpdir 32 | 33 | let test_fs_stat _ = 34 | let filename = mk_tmpfile "hello" in 35 | let cb fs stats = 36 | assert_equal stats.st_size (Int64.of_int 5); 37 | (* Hard to say what the create time of the file is but it shouldn't be 0. *) 38 | assert_not_equal stats.st_birthtim.tv_sec Int64.zero; 39 | assert_equal (Uv.FS.path fs) filename; 40 | Unix.unlink filename 41 | in 42 | !! (Uv.FS.stat filename ~cb:cb); 43 | run () 44 | 45 | let test_fs_fstat _ = 46 | let filename = mk_tmpfile "boo" in 47 | let fd = ref 0 in 48 | let rec open_callback request = 49 | fd := !!(Uv.FS.result request); 50 | !!(Uv.FS.fstat !fd ~cb:fstat_callback) 51 | and fstat_callback request stats = 52 | assert_equal stats.st_size (Int64.of_int 3); 53 | !!(Uv.FS.close !fd ~cb:close_callback) 54 | and close_callback _ = 55 | Unix.unlink filename 56 | in 57 | !!(Uv.FS.openfile filename 0 ~cb:open_callback); 58 | run () 59 | 60 | let test_fs_lstat _ = 61 | let filename = mk_tmpfile "boo" in 62 | let tmpdir = mkdtemp () in 63 | let linkpath = (Filename.concat tmpdir "link") in 64 | Unix.symlink filename linkpath; 65 | let lstat_callback request stats = 66 | assert_not_equal stats.st_size (Int64.of_int 3); 67 | assert_equal (Uv.FS.path request) linkpath; 68 | Unix.unlink linkpath; 69 | Unix.rmdir tmpdir; 70 | Unix.unlink filename 71 | in 72 | !!(Uv.FS.lstat linkpath ~cb:lstat_callback); 73 | run () 74 | 75 | let test_fs_read _ = 76 | let test_string = "test" in 77 | let filename = mk_tmpfile test_string in 78 | let fd = ref 0 in 79 | let rec open_callback request = 80 | let buf = mk_buf () in 81 | fd := !! (Uv.FS.result request); 82 | !!(Uv.FS.read !fd ~cb:read_callback buf) 83 | and read_callback request buf = 84 | !!(Uv.FS.close !fd ~cb:(fun _ -> Unix.unlink filename)); 85 | assert_equal (Util.of_bigarray buf) "test" 86 | in 87 | !!(Uv.FS.openfile filename 0 ~cb:open_callback); 88 | run () 89 | 90 | (* TODO: put these somewhere more appropriate *) 91 | let o_creat = 0o100 92 | let o_wronly = 0o1 93 | let o_trunc = 0o1000 94 | 95 | let test_fs_write _ = 96 | let filename = mk_tmpfile "" in 97 | let fd = ref 0 in 98 | let rec open_callback request = 99 | let () = fd := !! (Uv.FS.result request) in 100 | let buf = (Util.to_bigarray "test") in 101 | !!(Uv.FS.write !fd buf ~cb:write_callback) 102 | and write_callback _ buf = 103 | assert_equal "test" (Util.of_bigarray buf); 104 | !!(Uv.FS.close !fd ~cb:close_callback) 105 | and close_callback _ = 106 | let input_channel = open_in filename in 107 | let data = input_line input_channel in 108 | assert_equal "test" data; 109 | Unix.unlink filename 110 | in 111 | let flags = (o_creat lor o_wronly lor o_trunc) in 112 | !!(Uv.FS.openfile filename flags ~cb:open_callback); 113 | run () 114 | 115 | let test_fs_unlink _ = 116 | let filename = mk_tmpfile "" in 117 | let unlink_callback _ = 118 | assert_bool "File exists after unlink" (not (Sys.file_exists filename)); 119 | in 120 | !!(Uv.FS.unlink filename ~cb:unlink_callback); 121 | run () 122 | 123 | let test_fs_mkdir _ = 124 | let temp_dir = mkdtemp () in 125 | let target_dir_path = (Filename.concat temp_dir "test_dir") in 126 | let mkdir_callback _ = 127 | assert_bool "Dir" (Sys.file_exists target_dir_path && 128 | Sys.is_directory target_dir_path); 129 | Unix.rmdir target_dir_path; 130 | Unix.rmdir temp_dir 131 | in 132 | !!(Uv.FS.mkdir target_dir_path ~cb:mkdir_callback); 133 | run () 134 | 135 | let test_fs_mkdtemp _ = 136 | let temp_dir = mkdtemp () in 137 | let template = (Filename.concat temp_dir "lalaXXXXXX") in 138 | let mkdtemp_callback request = 139 | let dir_path = Uv.FS.path request in 140 | assert_bool "is dir" (Sys.file_exists dir_path && 141 | Sys.is_directory dir_path); 142 | let prefix_len = (String.length template) - 6 in 143 | let prefix str = Str.first_chars str prefix_len in 144 | assert_bool "dir name" (prefix dir_path = prefix template); 145 | Unix.rmdir dir_path; 146 | Unix.rmdir temp_dir 147 | in 148 | !!(Uv.FS.mkdtemp template ~cb:mkdtemp_callback); 149 | run () 150 | 151 | let test_fs_rmdir _ = 152 | let temp_dir = mkdtemp () in 153 | let rmdir_callback _ = 154 | assert_bool "dir gone" (not (Sys.file_exists temp_dir)) 155 | in 156 | !!(Uv.FS.rmdir temp_dir ~cb:rmdir_callback); 157 | run () 158 | 159 | let test_fs_rename _ = 160 | let temp_dir = mkdtemp () in 161 | let sourcepath = mk_tmpfile "test" in 162 | let destpath = Filename.concat temp_dir "target" in 163 | let rename_callback _ = 164 | assert_bool "original file gone" (not (Sys.file_exists sourcepath)); 165 | assert_bool "new file present" (Sys.file_exists destpath); 166 | let input_channel = open_in destpath in 167 | let data = input_line input_channel in 168 | assert_equal "test" data; 169 | Unix.unlink destpath; 170 | Unix.rmdir temp_dir 171 | in 172 | !!(Uv.FS.rename sourcepath destpath ~cb:rename_callback); 173 | run () 174 | 175 | (* I worry that these tests for fsync/fdatasync don't work on all systems, since 176 | * frequently write updates metadata *) 177 | let test_fs_fsync _ = 178 | let filename = mk_tmpfile "test" in 179 | let fs_before = Unix.stat filename in 180 | let fd = ref 0 in 181 | let rec open_callback request = 182 | let () = fd := !! (Uv.FS.result request) in 183 | let buf = (Util.to_bigarray "testfsync") in 184 | !! (Uv.FS.write !fd buf ~cb:write_callback) 185 | and write_callback _ _ = 186 | !! (Uv.FS.fsync !fd ~cb:fsync_callback) 187 | and fsync_callback _ = 188 | let fs_after = Unix.stat filename in 189 | assert_bool "size updated" (not (fs_before.st_size = fs_after.st_size)); 190 | !! (Uv.FS.close !fd ~cb:(fun _ -> Unix.unlink filename)) 191 | in 192 | let flags = (o_creat lor o_wronly lor o_trunc) in 193 | !!(Uv.FS.openfile filename ~cb:open_callback flags); 194 | run () 195 | 196 | (* TODO: test fdatasync-specific properties *) 197 | let test_fs_fdatasync _ = 198 | let filename = mk_tmpfile "test" in 199 | let fs_before = Unix.stat filename in 200 | let fd = ref 0 in 201 | let rec open_callback request = 202 | let () = fd := !! (Uv.FS.result request) in 203 | let buf = (Util.to_bigarray "testfdatasync") in 204 | !!(Uv.FS.write !fd buf ~cb:write_callback) 205 | and write_callback _ _ = 206 | !!(Uv.FS.fdatasync !fd ~cb:fdatasync_callback) 207 | and fdatasync_callback _ = 208 | let fs_after = Unix.stat filename in 209 | assert_bool "size updated" (not (fs_before.st_size = fs_after.st_size)); 210 | !!(Uv.FS.close !fd ~cb:(fun _ -> Unix.unlink filename)) 211 | in 212 | let flags = (o_creat lor o_wronly lor o_trunc) in 213 | !!(Uv.FS.openfile filename ~cb:open_callback flags); 214 | run () 215 | 216 | let test_fs_ftruncate _ = 217 | let filename = mk_tmpfile "test" in 218 | let fd = ref 0 in 219 | let rec open_callback request = 220 | let () = fd := !! (Uv.FS.result request) in 221 | !!(Uv.FS.ftruncate !fd 2 ~cb:ftruncate_callback) 222 | and ftruncate_callback _ = 223 | !!(Uv.FS.close !fd ~cb:close_callback) 224 | and close_callback _ = 225 | let input_channel = open_in filename in 226 | let data = input_line input_channel in 227 | assert_equal "te" data; 228 | Unix.unlink filename 229 | in 230 | !!(Uv.FS.openfile filename o_wronly ~cb:open_callback); 231 | run () 232 | 233 | let test_fs_sendfile _ = 234 | let filename = mk_tmpfile "test" in 235 | let tempdir = mkdtemp () in 236 | let target_path = Filename.concat tempdir "target" in 237 | let source_fd = ref 0 in 238 | let dest_fd = ref 0 in 239 | let rec open_source_callback request = 240 | let fd = !! (Uv.FS.result request) in 241 | source_fd := fd; 242 | let flags = o_creat lor o_wronly lor o_trunc in 243 | !!(Uv.FS.openfile target_path flags ~cb:open_dest_callback) 244 | and open_dest_callback request = 245 | Printf.printf ""; (* TODO: this makes this test pass for some reason *) 246 | dest_fd := !! (Uv.FS.result request); 247 | !!(Uv.FS.sendfile !dest_fd !source_fd 4 ~cb:sendfile_callback) 248 | and sendfile_callback _ = 249 | !!(Uv.FS.close !source_fd ~cb:close_source_callback) 250 | and close_source_callback _ = 251 | !!(Uv.FS.close !dest_fd ~cb:close_dest_callback) 252 | and close_dest_callback _ = 253 | let input_channel = open_in target_path in 254 | let data = input_line input_channel in 255 | assert_equal "test" data; 256 | Unix.unlink filename; 257 | Unix.unlink target_path; 258 | Unix.rmdir tempdir 259 | in 260 | !!(Uv.FS.openfile filename 0 ~cb:open_source_callback); 261 | run () 262 | 263 | let test_fs_chmod _ = 264 | let filename = mk_tmpfile "test" in 265 | Unix.chmod filename 0o777; 266 | Unix.access filename [R_OK; W_OK; X_OK]; 267 | let chmod_callback _ = 268 | let call () = Unix.access filename [R_OK; W_OK; X_OK] in 269 | assert_raises (Unix.Unix_error(Unix.EACCES, "access", filename)) call 270 | in 271 | !!(Uv.FS.chmod filename 0o000 ~cb:chmod_callback); 272 | run () 273 | 274 | let suite = 275 | "fs_suite">::: 276 | [ 277 | "fs_stat">::test_fs_stat; 278 | "fs_fstat">::test_fs_fstat; 279 | "fs_lstat">::test_fs_lstat; 280 | "fs_read">::test_fs_read; 281 | "fs_write">::test_fs_write; 282 | "fs_unlink">::test_fs_unlink; 283 | "fs_mkdir">::test_fs_mkdir; 284 | "fs_mkdtemp">::test_fs_mkdtemp; 285 | "fs_rmdir">::test_fs_rmdir; 286 | "fs_rename">::test_fs_rename; 287 | "fs_fsync">::test_fs_fsync; 288 | "fs_ftruncate">::test_fs_ftruncate; 289 | "fs_sendfile">::test_fs_sendfile; 290 | "fs_chmod">::test_fs_chmod; 291 | ] 292 | -------------------------------------------------------------------------------- /test/test_handle.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open OUnit 10 | 11 | open Uv 12 | 13 | let test_accessors () = 14 | let loop = Loop.default_loop () in 15 | let handle = TCP.init ~loop:loop () in 16 | assert_equal loop (Handle.loop handle) 17 | 18 | let suite = 19 | "handle suite">::: 20 | [ 21 | "accessors">::test_accessors; 22 | ] 23 | -------------------------------------------------------------------------------- /test/test_lifecycle.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open OUnit 10 | 11 | open Ctypes 12 | open Foreign 13 | module C = Libuv_bindings.C(Libuv_generated) 14 | 15 | let mk_tmpfile contents : string = 16 | let (tmpfile_name, chan) = Filename.open_temp_file "foo" "txt" in 17 | output_string chan contents; 18 | close_out chan; 19 | tmpfile_name 20 | 21 | let coatCheck = Coat_check.create () 22 | 23 | let alloc_uv_fs () = 24 | let memory = allocate_n char ~count:Uv_consts.size_of_uv_fs_t in 25 | coerce (ptr char) (ptr C.uv_fs) memory 26 | 27 | let test_expired_callback () = 28 | (* Pass a callback to libuv. Keep a reference to the data we allocate so 29 | it doesn't crash. We do NOT keep anything to prevent the callback's closure 30 | from getting gc'd. Callback references a variable so the closure gets 31 | allocated. We should get a expired closure exception. 32 | *) 33 | let filename = mk_tmpfile "hello" in 34 | let data = alloc_uv_fs () in 35 | let _ = begin 36 | let cb fs = 37 | let _ = Obj.repr data in 38 | Printf.printf "XXX Called '%s'\n" (C.get_uv_fs_t_path fs) 39 | in 40 | let tckt = Coat_check.ticket coatCheck in 41 | let () = Coat_check.store coatCheck tckt (Obj.repr data) in 42 | let () = Gc.compact () in 43 | let _ = C.uv_fs_stat (C.uv_default_loop ()) data filename cb in 44 | let () = Gc.compact () in () 45 | end in 46 | assert_raises CallToExpiredClosure (fun () -> Uv.Loop.run RunDefault) 47 | 48 | let test_store_callback_and_data () = 49 | (* This test shows a deconstructed version of how we store 50 | the data and callback together. *) 51 | let filename = mk_tmpfile "foo" in 52 | let data = alloc_uv_fs () in 53 | let nameRef = ref "" in 54 | let _ = begin 55 | let cb fs = nameRef := "XXX" 56 | in 57 | let safe = (data, cb) in 58 | let tckt = Coat_check.ticket coatCheck in 59 | let () = Coat_check.store coatCheck tckt safe in 60 | let () = Gc.compact () in 61 | let ret = C.uv_fs_stat (C.uv_default_loop ()) data filename cb in 62 | let () = Gc.compact () in () end 63 | in 64 | let _ = Uv.Loop.run RunDefault in 65 | assert_equal (!nameRef) "XXX" 66 | 67 | let test_store_callback_and_data_then_expired () = 68 | (* Decrement the reference before running and it should not work. 69 | We use the callback-only again because loosing the uv_fs data causes 70 | segfaults which we cannot catch as easily :) *) 71 | let filename = mk_tmpfile "foo" in 72 | let data = alloc_uv_fs () in 73 | let nameRef = ref "" in 74 | let _ = begin 75 | let cb fs = nameRef := "XXX" 76 | in 77 | let safe = (data, cb) in 78 | let tckt = Coat_check.ticket coatCheck in 79 | let () = Coat_check.store coatCheck tckt safe in 80 | let () = Coat_check.forget coatCheck tckt in 81 | (* Add data back in so we don't segfault *) 82 | let tckt = Coat_check.ticket coatCheck in 83 | let () = Coat_check.store coatCheck tckt (Obj.repr data) in 84 | let () = Gc.compact () in 85 | let ret = C.uv_fs_stat (C.uv_default_loop ()) data filename cb in 86 | let () = Gc.compact () in () end 87 | in 88 | assert_raises CallToExpiredClosure (fun () -> Uv.Loop.run RunDefault) 89 | 90 | let suite = 91 | "lifecycle suite">::: 92 | [ 93 | "test expired callback">::test_expired_callback; 94 | "test store callback & data">::test_store_callback_and_data; 95 | "test store callback & data then expired">::test_store_callback_and_data_then_expired; 96 | ] 97 | -------------------------------------------------------------------------------- /test/test_runner.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014-2015 Trevor Summers Smith , 3 | * Zachary Newman 4 | * 5 | * This file is distributed under the terms of the MIT License. 6 | * See the file LICENSE for details. 7 | *) 8 | 9 | open OUnit 10 | 11 | let () = 12 | let suites = [ 13 | Test_fs.suite; 14 | Test_handle.suite; 15 | Test_lifecycle.suite; 16 | Test_consts.suite; 17 | Test_coat_check.suite; 18 | ] in 19 | let _ = List.map (fun s -> run_test_tt_main s) suites in 20 | (* We don't need the results *) 21 | () 22 | --------------------------------------------------------------------------------