pax_global_header00006660000000000000000000000064147625373440014531gustar00rootroot0000000000000052 comment=59d5c3e12ae80ffa95661fac59fb914170e6b1a7 lwt-5.9.1/000077500000000000000000000000001476253734400123535ustar00rootroot00000000000000lwt-5.9.1/.github/000077500000000000000000000000001476253734400137135ustar00rootroot00000000000000lwt-5.9.1/.github/dependabot.yml000066400000000000000000000001601476253734400165400ustar00rootroot00000000000000version: 2 updates: - package-ecosystem: github-actions directory: / schedule: interval: weekly lwt-5.9.1/.github/workflows/000077500000000000000000000000001476253734400157505ustar00rootroot00000000000000lwt-5.9.1/.github/workflows/workflow.yml000066400000000000000000000056011476253734400203470ustar00rootroot00000000000000name: Builds, tests & co on: pull_request: push: schedule: # Prime the caches every Monday - cron: 0 1 * * MON jobs: build-and-test: strategy: fail-fast: false matrix: os: - ubuntu-latest ocaml-compiler: - "4.08" - "4.09" - "4.10" - "4.11" - "4.12" - "4.13" - "4.14" - "5.0" - "5.1" - "5.2" libev: - true - false ppx: - true local-packages: - | *.opam include: - os: ubuntu-latest ocaml-compiler: ocaml-variants.5.2.0+options,ocaml-option-flambda,ocaml-option-musl,ocaml-option-static,ocaml-option-no-compression libev: false ppx: true local-packages: | *.opam - os: macos-latest ocaml-compiler: "5.2" libev: true ppx: true local-packages: | *.opam - os: windows-latest ocaml-compiler: "5.2" libev: false ppx: true local-packages: | *.opam - os: ubuntu-latest ocaml-compiler: "5.2" libev: true ppx: false local-packages: | *.opam !lwt_ppx.opam - os: macos-latest ocaml-compiler: "5.2" libev: true ppx: false local-packages: | *.opam !lwt_ppx.opam - os: windows-latest ocaml-compiler: "5.2" libev: false ppx: false local-packages: | *.opam !lwt_ppx.opam runs-on: ${{ matrix.os }} steps: - name: Checkout tree uses: actions/checkout@v4 - name: Set-up OCaml uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} opam-local-packages: ${{ matrix.local-packages }} - run: opam install conf-libev if: ${{ matrix.libev == true }} - run: opam install lwt_react lwt --deps-only --with-test - run: opam install lwt_ppx --deps-only --with-test if: ${{ matrix.ppx == true }} - run: opam exec -- dune build --only-packages lwt_react,lwt - run: opam exec -- dune build --only-packages lwt_ppx if: ${{ matrix.ppx == true }} - run: opam exec -- dune runtest --only-packages lwt_react,lwt - run: opam exec -- dune runtest --only-packages lwt_ppx if: ${{ matrix.ppx == true }} lint-opam: runs-on: ubuntu-latest steps: - name: Checkout tree uses: actions/checkout@v4 - name: Set-up OCaml uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: "5.2" dune-cache: true - uses: ocaml/setup-ocaml/lint-opam@v3 lwt-5.9.1/.gitignore000066400000000000000000000006271476253734400143500ustar00rootroot00000000000000_build src/unix/discover_arguments *.flag # OPAM 2.0 local switches. _opam # NPM. node_modules/ package-lock.json # package-lock.json should probably be committed once we know what we're doing. # esy _esy esy.lock # Coverage analysis. bisect*.out _coverage/ # For local work, tests, etc. scratch/ # Autogenerated by jbuider .merlin *.install # BuckleScript output. lib/ # Wikidoc output. /docs/api/ lwt-5.9.1/CHANGES000066400000000000000000001354141476253734400133560ustar00rootroot00000000000000===== 5.9.0 ===== ====== Additions ====== * Lwt_stream.junk_available is a Lwt-free alternative to Lwt_stream.junk_old. (Alain Mebsout, #1036) * Lwt_engine.libev#backend indicates which backend was picked by libev. (mefyl, bnguyenvanyen, #985) ====== Documentation ====== * Many fixes. (Arvid Jakobsson, #1038) ====== Other ====== * Misc repository maintenance. (Sora Morimoto, Shon Feder, #1037, #1035) ===== 5.8.0 ===== ====== Improvements ====== * Make Lwt_seq.of_list lazier, make Lwt_set.to_list tail-rec. (Samer Abdallah, #1019) * Convert more Lwt.fail into raise to increase availibility of backtraces. (#1008) ====== Documentation ====== * Small fixes. (Nils André, #1001, #1006) * Convert manual to mld. (#951, Antonin Décimo) ====== Other ====== * Many improbements to the CI. (Sora Morimoto, Idir Lankri, #986, #1009, #1011, #1013, #1014, #1016, #1020, #1021, #1023, #1024, #1025) * Improbements to the packaging. (Sora Morimoto, #1010, #1015) * Make C code pass the stricter checks of GCC 14. (Jerry James, #1004) * Fix many many C warnings and other fixes. (Antonin Décimo, #1007, #1022) ===== 5.7.0 ===== ====== Breaking API changes ====== * Lwt_result.catch now takes a function (unit -> 'a t) rather than a promise ('a t). (#965) * Remove the deprecated Lwt.result type (use Stdlib.result instead). (#968) * Remove the deprecated Lwt.make_value and Lwt.make_result functions (use Ok and Error instead). (#968) * Remove the deprecated and unsafe waiter_of_wakener (keep the waiter around when you create the wakener instead). (#968) * Remove the deprecated Lwt_stream.on_termination and Lwt_stream.on_terminate (bind to Lwt_stream.closed instead). (#968) * Remove the deprecated Lwt_stream.result type (use Stdlib.result instead). (#968) * Remove the deprecated Lwt_stream.map_exn function (use wrap_exn instead). (#968) ====== Additions ====== * Lwt.Exception_filter for enabling/disabling system-exception catching. (#964) * Lwt.reraise an exception raising function which preserves backtraces, recommended for use in Lwt.catch. (#963) * Expose Lwt_io.delete_recursively for deleting a directory and its content recursively. (#984, Antonin Décimo) * Lwt_preemptive.run_in_main_dont_wait to run a function in the main preemptive thread but without waiting for the result. (Kate Deplaix, #960) * Lwt_unix.handle_signal and Lwt_engine.forwards_signal to allow other IO libraries (such as Eio) to share signal handlers. (Thomas Leonard, #993, #991) ====== Build ====== * Remove unused dependency in dune file. (#969, Kate Deplaix) * Fix some compilation warnings for C stubs with OCaml 5. (#976, Antonin Décimo) ====== Fixes ====== * Use SA_ONSTACK on OCaml5 to avoid SIGSEGV. (Thomas Leonard, #993, #981) * Fix race in worker loop. (Thomas Leonard, #993, #994) * Fix marshall header size in Lwt_io.read_value. (Simmo Saan, #995) ====== Misc ====== * Resolve paused promises only once in main loop. This lets Lwt.pause behave identical to Lwt_unix.yield. (#917, Christopher Zimmermann, Favonia) ===== 5.6.1 ===== ====== Fixes ====== * Fix null file descriptor being closed when used as redirection for standard fd of child processes. (#957, Antonin Décimo) ===== 5.6.0 ===== ====== Installability ====== * Lwt is now compatible with OCaml 5.00. Lwt is now incompatible with OCaml 4.02. (#925, #923, Kate Deplaix, Patrick Ferris) * Lwt is now incompatible with OCaml.4.07 and earlier. (#947, Hannes Mehnert, Tim McGilchrist) * Lwt-unix is now compatible with OCaml 5.0.0. (#953, David Allsopp) ====== Additions ====== * In the Lwt_io module, add `?cloexec:bool` optional arguments to functions that create file descriptors (`pipe`). The `?cloexec` argument is simply forwarded to the wrapped Lwt_unix function. (#872, #911, Antonin Décimo) * Add Lwt_result.error, Lwt_result.iter, and Lwt_result.iter_error for consistency with Stdlib. (#927, Antonin Décimo) * Lwt_result.bind_error. (#943, Boning Dong) * Add ?cloexec parameter to Lwt_io.pipe. (#911, Antonin Décimo) ====== Misc ====== * On Windows, make Lwt_process.create_process duplicate standard handles given to the child process if they're not inheritable, to mimic the behaviour of Unix.create_process. (#909, Antonin Décimo) * Add missing dependency to `cppo` in lwt-react's opam file. (#946, Rizo I) * Improve documentation (especially internal links). (#928, Antonin Décimo) * Fix documentation of infix choose. (#952, Reynir Björnsson) * Only define OCAML_NAME_SPACE for OCaml<5.0.0. (#929, Antonin Décimo) * Replace mentions of Pervasives with Stdlib in the doc. (#954, Antonin Décimo) * Improve deprecation message for auto_yield. (#908, Seb Mondet) * Fix mirage tutorial link. (#936, Tuomas Lukka) * Fix issues in opam file. (#937, Andreas Hauptmann) ====== Fixes ====== * Fix win32_spawn leaking dev_null fd in the parent process. (#906, Antonin Décimo) * Prefer SetHandleInformation to DuplicateHandle in set_close_on_exec for sockets. DuplicateHandle mustn't be used on sockets. (#907, Antonin Décimo) * Lwt.pick and Lwt.choose select preferentially failed promises as per documentation (#856, #874, Raman Varabets) * Use the WSA_FLAG_NO_HANDLE_INHERIT on Windows when creating sockets with WSASocket if the cloexec (non-inheritable) parameter is true. Fixes a Windows problem where a child process would inherit a supposedly non-inheritable socket. (#910, Antonin Décimo) * Fix macOS/arm64 tests which have a 16k page. (#932, Kate Deplaix) * Fix Lwt_unix.closedir incorrectly checking the return value of closedir(3). (#942, Antonin Décimo) * Fix custom_operations struct not fully initialized after OCaml 4.08. (Antonin Décimo, #918) * Fix missing include directive. (#940, Antonin Décimo) * Fix missing initialisation in Unix stub. (#941, Antonin Décimo) ====== Deprecations ====== * Alias Lwt_result.map_err and Lwt_result.bind_lwt_err to Lwt_result.map_error and Lwt_result.bind_lwt_error for consistency with Stdlib. (#927, Antonin Décimo) ===== 5.5.0 ===== ====== Deprecations ====== * Lwt_main.yield and Lwt_unix.yield are deprecated in favor of the generic Lwt.pause, and Lwt_unix.auto_yield is deprecated in favor of the new Lwt_unix.auto_pause. Currently, Lwt_main.run resolves paused promises more frequently than yielded promises; the difference is unintended but existing applications could unintentionally depend on it. (#855, #858, Favonia) ====== Fixes ====== * Use is_blocking in dup and dup2 to fix ENOTSOCK on Windows. (#869, Antonin Décimo) * Lwt_unix.lstat was incorrectly calling Unix.stat on Win32. Fixes the behavior of Lwt_io.with_temp_dir following symlinks to directories on Win32. (#883, Antonin Décimo) * Support deleting symlinks on Windows during cleanup of Lwt_io.with_temp_dir. (#886, Antonin Décimo) * Lwt_react.S.l[2-6]_s used polymorphic equality which could cause errors when handling functional values. (#893, Jérôme Vouillon) * On Windows, treat ERROR_BROKEN_PIPE on read as zero-read instead of error. See OCaml PR #4790. (#898, Antonin Décimo) * Fix compilation under MSVC by replacing Noreturn with CAMLnoreturn. (#880, #887, Nicolás Ojeda Bär) ====== Additions ====== * Lwt_bytes.blit_from_string: string complement of Lwt_bytes.blit. (#882, Hugo Heuzard) * Lwt_seq: a Seq-like data-structure with Lwt delayed nodes. (#836, #842, Zach Shipko) * Lwt_unix.auto_pause: the replacement of Lwt_unix.auto_yield that uses Lwt.pause instead of Lwt_unix.yield. (#855, #858, Favonia) * Lwt_stream.return, Lwt_stream.return_lwt: singleton stream constructors. (#864, Boning Dong) * Add ?to_dir param from Unix.symlink to Lwt_unix.symlink wrapper. (#884, Antonin Décimo) * Lwt_stream.of_lwt_seq to convert an Lwt-sequence into an Lwt-stream. (#873) * Support IPv6 (always) and PF_UNIX (with OCaml >= 4.14) socketpair on Windows. (#870, #876, Antonin Décimo, David Allsopp) * In the Lwt_unix module, add `?cloexec:bool` optional arguments to functions that create file descriptors (`dup`, `dup2`, `pipe`, `pipe_in`, `pipe_out`, `socket`, `socketpair`, `accept`, `accept_n`). The `?cloexec` argument is simply forwarded to the wrapped Unix function (with OCaml >= 4.05, see PR ocaml/ocaml#650), or emulated as best-effort with `Unix.set_close_on_exec` on older OCaml versions. (#327, #847, #872, #901, Antonin Décimo) * Lwt_domain: helpers for using domainslib from Lwt. (#860, Sudha Parimala) ====== Misc ====== * Code quality improvement: remove an unneeded Obj.magic. (#844, Benoit Montagu) * On Windows, use the Unicode API in C stubs and functions introduced in OCaml 4.06 to handle Unicode strings. Raise the minimum requirement to OCaml 4.06 (on Windows only). (#843, #903, Antonin Décimo) * More complete coverage in the CI. (#890, #894, #896, Sora Morimoto) * Code quality improvement: use exception pattern instead of try-with. (#895, Antonin Décimo) * Code quality improvement: fix warnings on 4.13. (#899) ===== 5.4.2 ===== ====== Bugs fixed ====== * Fix compilation on Windows by providing missing dummy stubs (#868, Andreas Hauptmann, Antonin Décimo). ===== 5.4.1 ===== ====== Bugs fixed ====== * Fix Lwt_fmt.stderr to actually point to stderr (#852, #850, Volker Diels-Grabsch). * Make temporary files created by Lwt_io.with_temp_dir deletable on Windows by removing the RO bit (#849, #861, Antonin Décimo). * Handle ECONNABORTED in Lwt_io.establish_server* (#829, #830, Reynir Björnsson, Hannes Mehnert). ====== Bugfixes ====== * Fix Lwt_fmt.stderr to actually point to stderr (#852, #850, Volker Diels-Grabsch). * Lwt_io.establish_server* handles ECONNABORTED (#829, #830, Reynir Björnsson) ===== 5.4.0 (2020-12-16) ===== ====== Installability ====== * Support for OCaml 4.12 (#804, #826, Kate Deplaix). * lwt_ppx now uses ppxlib. This introduce a transitive dependency to OCaml.4.04 (#807, Philippe Veber). ====== Bugfixes ====== * Catch exceptions in Lwt_react.of_stream (#809, Petter A. Urkedal). * Avoid segfaults in Lwt_unix.tcsetattr (#798, Frédéric Fortier). ====== Additions ====== * fork method in Lwt_engine. This method is a noop in the released engines but it paves the way to a libuv-based engine (#811, Ulrik Strid, Anton Bachin). * Lwt_main.abandon_yielded_and_paused for use in conjunction with Lwt.fork (#789, Julien Tesson). * Lwt.wrap_in_cancelable to complete protect and no_cancel (#785). * Support for IOV_MAX in [Lwt_unix.IO_vectors.system_limit (#801, Pino Toscano). * Lwt_unix.send_msgto (#805, Antonio Nuno Monteiro). * Lwt.dont_wait, a more explicit alternative to Lwt.async (#820, François Thiré). ====== Miscellaneous ====== * Avoid double-reversing when traversing lists. This may change the order in which some promises are collected, which may change which of several rejection is arbitrarily selected during concurrent traversal (#784). * Numerous documentation improvements (including external contributions from Bikal Lem, Sudha Parimala, and Hannes Mehnert). ===== 5.3.0 (2020-04-22) ===== * Add let* and and* in Lwt.Syntax and Lwt_result.Syntax (#775, Rahul Kumar). * Also add let+ and and+ (#776, Craig Ferguson). * Add Lwt_result.both (#775, Rahul Kumar). * Always use libev if detected (#601). ===== 5.2.0 (2020-03-09) ===== * Add Lwt_unix.pread, Lwt_unix.pwrite, and Lwt_unix.pwrite_string (#768, Pierre Chambart). * Internally use accept4(2) when available (#769, Pierre Chambart). * PPX: internally use 4.10 ASTs (#765). ===== 5.1.2 (2020-02-23) ===== ====== Bugs fixed ====== * Do not run C exit hooks after failed exec (#764, diagnosed Lucian Wischik). * discover.ml: don't add flags for missing system libraries (#760, #761, Olaf Hering). * discover.ml: don't run the opam binary (#761). * Warning on 4.10 in lwt_unix_stubs.c (#766). ===== 5.1.1 (2020-01-07) ===== ====== Bugs fixed ====== * Exception raised by Lwt_main.run upon call to exit (#758, reported Gal Schlezinger). ===== 5.1.0 (2019-12-28) ===== ====== Additions ====== * Lwt.all (9976f67). ====== Documentation ====== * Add index.mld for nicer odoc output (1059a80, prompted Anurag Soni). * Link to rwo-lwt from the online manual to make it more discoverable (4129a22, suggested Anurag Soni). * Fix doc links in opam files (7617607). ===== 5.0.1 (2019-12-22) ===== ====== Bugs fixed ====== * Additional fix for libev detection under esy (#757, Antonio Nuno Monteiro). ===== 5.0.0 (2019-12-15) ===== ====== Breaking ====== See #584 for an extended summary and discussion of this release as a whole, or individual issues for each change specifically. * The callback passed to Lwt.async must now evaluate to unit Lwt.t, rather than _ Lwt.t (#603, requested @cfcs). * Lwt.choose, Lwt.nchoose, Lwt.nchoose_split, Lwt.pick, and Lwt.npick now raise Invalid_argument if given the empty list (#557, Tim Reinke). * Catch nested calls to Lwt_main.run (#607, #609, prompted François-René Rideau). * Use the new Lwt_unix.IO_vectors in Lwt_unix.recv_msg and Lwt_unix.send_msg (#594, prompted Marcello Seri). * Make Lwt_unix.Async_switch a synonym for Lwt_unix.Async_detach (#572). * Remove the redundant configure.ml (#700). * PPX: remove support for general [%lwt ...] expressions (#527). * PPX: remove support for Lwt_log and the -log option (#520). * PPX: remove the -no-debug option (#528). ====== Bugs fixed ====== * libev detection under esy (#755, Antonio Nuno Monteiro). ===== 4.5.0 (2019-12-15) ===== ====== Additions ====== * Implement Lwt_unix.readv and Lwt_unix.writev on Windows using Lwt_unix.read and Lwt_unix.write (#745, requested Ulrik Strid). * Implement Lwt_unix.wait4 on Android using Unix.waitpid, as on Windows (#752, @EduardoRFS). * LWT_DISCOVER_ARGUMENTS=--verbose flag, passed through environment variable, for debugging the feature discovery (configuration) process (#740). ====== Bugs fixed ====== * To help with fork, don't call back into Lwt_main at process exit to call Lwt exit hooks when there are none (#737, prompted Martin Jambon). * Properly retain references to buffers in Lwt_unix.readv, Lwt_unix.writev, Lwt_bytes.read, Lwt_bytes.write, and Lwt_bytes.mincore; the references could be released too early in rare circumstances (#742, prompted Olaf Hering). * Don't install a SIGCHLD handler when Lwt is linked in but not used (#738, requested Sam Goldman, additional information Waleed Khan). * Link with -lpthread on more platforms that support and require the flag (#748, Olivier Andrieu). * Fix syntax errors in feature test programs (#748, Olivier Andrieu). * C warning with OCaml 4.10 (#751, @kit-ty-kate). ====== Miscellaneous ====== * Make tests more reliable (#726, #743, prompted Olaf Hering). * Fix deprecation annotation on internal API (#735, Antonio Nuno Monteiro). * Fix broken link in Lwt_mvar docs (#739, reported @tg-x). * Fix broken links in README (#750, @imbsky). ===== 4.4.0 (2019-10-09) ===== ====== Additions ====== * ?suffix argument for Lwt_io.with_temp_file and Lwt_io.open_temp_file (#724, requested Volker Diels-Grabsch). * Lwt_io.with_temp_dir and Lwt_io.create_temp_dir (#724, requested Volker Diels-Grabsch). ====== Changes ====== * Lwt_io.establish_server: increase default backlog from 5 to SOMAXCONN (#731, suggested Konstantin Olkhovskiy). * PPX: use OCaml 4.09 ASTs to support recent features (074f679). * PPX: deprecate let%lwt structure items (#733, prompted Didier Le Botlan). ====== Miscellaneous ====== * Tests now pass in more environments (#721, #722, #725, #729, reported Olaf Hering). ===== 4.3.1 (2019-09-26) ===== ====== Bugs fixed ====== * Lwt clobbered backtraces (#714, 6e855b8, 4694853, reported Volker Diels-Grabsch). * Lwt_unix.fork was broken on glibc 2.28 (#704, @ygrek). * Fix build with musl-gcc (#718, #719, reported Fabian Hemmer). * Support more Lwt_unix.madvise options (#716, Anton Kochkov). ====== Miscellaneous ====== * Silence configure script (#717, requested Anil Madhavapeddy). * Greatly sped up CI and tests. ===== 4.3.0 (2019-08-20) ===== ====== Planned to break in 5.0.0 ====== For general discussion of breakage in Lwt 5.0.0, see #584. See #293 about how Lwt announces and does breaking changes.* * The signature of Lwt.async will change from (unit -> 'a Lwt.t) -> unit to (unit -> unit Lwt.t) -> unit (#603, prompted @cfcs). * Lwt_unix.send_msg and Lwt_unix.recv_msg will be changed to take Lwt_unix.IO_vectors.t instead of Lwt_unix.io_vectors (#702, prompted Marcello Seri). * Nesting calls to Lwt_main.run will be forbidden, and will raise an Failure. Most programs don't do this (#609, prompted François-René Rideau). * configure.ml will be removed in favor of an improved discover.ml This affects only users who are configuring Lwt as part of a manual installation (i.e., not users of opam or esy). See discover.ml for usage (#700). * Lwt_unix.async_method will have no effect. In practice, it already does nothing, and has almost no users (#572). ====== Additions ====== * Lwt_process: allow setting working directory for new processes (#694, Thomas Leonard). * PPX: use OCaml 4.08 ASTs to support latest features (#697). * Lwt_io.NumberIO: use compiler intrinsics for better performance (#178, requested Mauricio Fernandez). ====== Bugs fixed ====== * Race condition in Lwt_react.S.limit (4e592eb). * Use fallback rule during configuration (#693, Hongchang Wu). * Fix typos (#688, #692, @Fourchaux). ===== 4.2.1 (2019-04-02) ===== ====== Bug fixed ====== * Detect libev correctly when building under esy (#679, Antonio Nuno Monteiro). ===== 4.2.0 (2019-03-25) ===== ====== Additions ====== * Lwt.both (#668, Brendan Long, Jeremy Yallop). * ppx_let support with open Lwt.Infix (#667, Brendan Long). * Lwt_stream.of_seq (#646, Hezekiah Carty). * Lwt_io.is_closed (#635, Andreas Garnaes). * Lwt_unix.IO_vectors.byte_count (#645, Raphaël Proust). * Support for higher baud rates in Lwt_unix.tcgetattr and Lwt_unix.tcsetattr (#678, Frédéric Fortier). * Replacement functions in Lwt_main for deprecated functions based on Lwt_sequence (#660). ====== Bugs fixed ====== * 4.08 compatibility (#658). * Stack overflow in Lwt_stream.iter_p (#432, Varun Kohli). * Incorrect bounds check in Lwt_bytes.mincore (#627, Cédric Le Moigne). * Lwt_bytes.mincore will not be available in future releases of OpenBSD (#663, Kenneth Westerback). * Missing header in the Android build (#652, Justus Matthiesen). * Build broken on MSVC (98303de, 85535f7, Dmitry Bely). * Build broken on OpenBSD (#672, Christopher Zimmermann). * Lwt_io.of_bytes produces a channel with inaccurate positions (#636, Nathan Rebours). * Lwt_io._.read_int behaves incorrectly on 32-bit systems (#671, reported Dmitry Bely). * Inaccurate locations for errors related to ;%lwt (#602, @kandu). * (_ : t) not recognized as a catch-all pattern by the PPX (#640, Florian Angeletti). * Race condition in Lwt_react.E.limit (#606, Avni Fatehpuria). * Premature deallocation in Lwt_react.E.with_finaliser and Lwt_react.S.with_finaliser (#626, El-Hassan Wanas). ====== Miscellaneous ====== * New tests for Lwt_bytes, portions of Lwt_unix (#619, #621, #628, #630, #673, Cédric Le Moigne, Anurag Soni). * Test suite improvements (#656, Dave Parfitt). * Clarifications for documentation of Lwt.try_bind, Lwt.pick (#648, #650, Bikal Lem). * Fixed documentation of Lwt_io.read_line (#657, Yoni Levy). * Fixed some typos (#611, #613, Rich Neswold). ===== 4.1.0 (2018-06-26) ===== ====== Additions ====== * Change license to MIT (#560). * Lwt_fmt, an Lwt-aware version of Format (#548, Gabriel Radanne). * Lwt_io.establish_server_with_client_socket (#586). ====== Bugs fixed ====== * Lwt_stream.iter_n: rename ?max_threads argument to ?max_concurrency (#581, Hezekiah Carty). * PPX: reject match expressions that have only exception cases (#597, Raphaël Proust). ====== Miscellaneous ====== * Improvements to Lwt_pool docs (#575, Bobby Priambodo). * Restore all PPX tests (#590, Jess Smith). ===== 4.0.1 (2018-04-13) ===== ====== Bugs fixed ====== * Race condition in worker thread management in Lwt_unix (#569, diagnosed Gabe Levi). * Hang in Lwt_unix.read on Windows (#574, #569, 86a6baf, diagnosed Gabe Levi). * Docs: note that Lwt_io.open_file for writing truncates the file by default (#570, reported Tóth Róbert). ===== 4.0.0 (2018-03-30) ===== ====== Breaking ====== These changes were announced in Lwt 3.1.0 and Lwt 3.2.0. See #453 about smooth upgrade paths. * Delete package lwt.ppx. The PPX syntax is in package lwt_ppx since Lwt 3.2.0 (#338). * Remove >> syntax from the PPX (#495). * Delete modules Lwt_log, Lwt_daemon, Lwt_log_core, and package lwt.log. These are in package lwt_log since Lwt 3.2.0, but it is recommended to use Logs_lwt from the logs library instead (#484, initiated Hannes Mehnert). * Delete package lwt.preemptive. It is an alias for lwt.unix since Lwt 3.2.0 (#487). * Delete package lwt.syntax. The Camlp4 syntax is in package lwt_camlp4 since Lwt 3.2.0 (#370). * Delete module Lwt_chan, a predecessor of Lwt_io (#441). * Delete package lwt.simple-top, a predecessor of utop (#371). * Make resolvers (Lwt.u) contravariant (#458). ====== Planned to break in 5.0.0 ====== * Lwt.pick will raise Invalid_argument on the empty list, instead of returning a forever-pending promise. Also applies to Lwt.choose, Lwt.npick, Lwt.nchoose, and Lwt.nchoose_split (#562, Tim Reinke, prompted Hezekiah Carty). * Remove translation of [%lwt ...] to Lwt.catch from the PPX (#527). * Remove -no-debug option from the PPX (#528). * Remove Lwt_log support from the PPX (#520). ====== Bugs fixed ====== * Lwt_io.file_length now fails with EISDIR when used on a directory (#563, requested Cedric Cellier). * Lwt_react.E.limit and Lwt_react.S.limit now working more correctly (#566, @Freyr666). ====== Miscellaneous ====== * Documentation improvements (#561, Jason Evans). ===== 3.3.0 (2018-03-07) ===== ====== Bugs fixed ====== * Restore backtrace support (#554, #556, Gabe Levi). * Serious logic error that could cause Lwt to hang or crash (#549, reported @koen-struyve). * All Lwt_list functions are now tail-recursive (#538, Joseph Thomas). ====== Additions ====== * Support ;%lwt syntax in the PPX (#307, Hezekiah Carty). * Lwt_stream.iter_n (#312, Hezekiah Carty). ====== Miscellaneous ====== * Testing improvements (#536, #541, @cedlemo). * Documentation improvements (#544, #546, #547, #553, #559, Daniil Baturin, Jason Evans, Jess Smith, Milo Turner). ===== 3.2.1 (2018-01-11) ===== Lwt 3.2.1 is released because it still packages lwt.ppx, a deprecated copy of package lwt_ppx, and the two packages should be kept in sync. ====== Deprecations ====== * All PPX options are deprecated and should not be used (#534). * The [%lwt ...] PPX syntax should be replaced by Lwt.catch (#534). ====== Fixes ====== * Clean up PPX -help usage message output (#525, Zan Doye). ====== Miscellaneous ====== * More thorough testing (#512, #535, Joseph Thomas). * Clarification of the C binding (#521, @cedlemo). ===== 3.2.0 (2017-12-19) ===== ====== Additions ====== * Lwt_mvar.take_available, Lwt_mvar.is_empty (#459, Hezekiah Carty). * Lwt_io.open_temp_file, Lwt_io.with_temp_file (#467, Joe Thomas). * New reference documentation for module Lwt (#469). * Lwt_pool.clear and ?dispose argument for Lwt_pool.create (#483, Hezekiah Carty). * Lwt_pool.wait_queue_length (#493, Jerome Vouillon). ====== Bugs fixed ====== * Lwt.npick never worked (#447, Zack Coker). * Lwt_pool.use now always calls ?validate on elements (#461, Joe Thomas). * Better locations generated by the PPX (#470, Fabian Hemmer). * Keep worker thread count accurate in Lwt_unix when pthread_create fails (#493, @koen-struyve). * Leaked exceptions in Lwt_list (#499). * Memory leak in Lwt_unix.getnameinfo (#503, Hannes Mehnert). ====== Planned to break in 4.0.0 ====== See #453 for details and instructions about planned breakage in Lwt 4.0.0. * The semantics of Lwt will be adjusted for better exception and stack safety (#500). * The PPX will be factored out into its own opam package, lwt_ppx. This package is installable from opam now, as of Lwt 3.2.0 (#338). * Similarly, the deprecated Camlp4 syntax will be factored out into lwt_camlp4, which is installable from opam now (#370). * Modules Lwt_log, Lwt_log_core, Lwt_log_rules, and Lwt_daemon are being deprecated and factored out into opam package lwt_log, also installable from opam now. Use the logs library for logging, in particular module Logs_lwt. Direct daemonization is deprecated on most platforms (#484, Hannes Mehnert). * The >> construct from the PPX will be deleted (#471, Raphaël Proust). * Package lwt.preemptive is being merged into lwt.unix. In 3.2.0, lwt.preemptive becomes an alias for lwt.unix, and the package name lwt.preemptive will be deleted in 4.0.0 (#487). ====== Deprecations ====== * Lwt.waiter_of_wakener should not be used, as it can lead to soundness bugs in future (but not current) Lwt (#458). * Lwt_sequence was deprecated in Lwt 2.6.0, but it now has a warning attached, as do Lwt.add_task_r and Lwt.add_task_l, which use it (#361). * Use of the following functions is discouraged, but they have not yet received deprecation warnings: Lwt.with_value, Lwt.cancel, Lwt.state, Lwt.ignore_result (#359, #469). ====== Miscellaneous ====== * Replace references to Camlp4 in the manual with the PPX (#457, Bobby Priambodo). * More tests for Lwt_pool (#464, Joe Thomas). * Expect tests for the PPX (#474, Fabian Hemmer). ===== 3.1.0 (2017-07-19) ===== ====== Additions ====== * Port to Jbuilder (#374, Andrew Ray). * Lwt_io.establish_server_with_client_address (#346, Rudi Grinberg). * Lwt_unix.getcwd (#403, Raphaël Proust). ====== Planned to break in 4.0.0 ====== * Delete lwt.simple-top (#371). * Delete Lwt_chan (#441). ====== Fixes ====== * Make Lwt_log functions tail-recursive (#348, Jan Doms). * Make more of Lwt_list tail-recursive (#347, Jan Doms). * Improve string messages in exceptions (#368, #382, Jan Doms, Raphaël Proust). * Don't call Unix.set_nonblock or Unix.clear_nonblock unnecessarily on some fds (#356, David Sheets). * Lwt_unix.sleep and Lwt_unix.timeout returning too early when using libev (#433, Stijn Devriendt). * Lwt_sequence.fold_r iterating the wrong way in some cases (#405, Stijn Devriendt). * Build conflicts in some cases due to duplicate cst_to_constr function (#362, Jérémie Dimino). * Don't use deprecated readdir_r system call (#430, Raphaël Proust). ====== Miscellaneous ====== * The Lwt core, lwt.ml, has been thoroughly refactored and commented (#354, reviewed Gabriel Radanne, Edwin Török, Raphaël Proust, Jan Doms, Fabian Hemmer, Sebastien Mondet, Simon Cruanes, Anil Madhavapeddy, Pierre Chambart, and many others). * Lots of tests for most of the Lwt core (#339, #389, #392, #440, #448, #450, Joseph Thomas, Ryan Slade). * Documentation fixes (including by Joseph Thomas, Raphaël Proust, Richard Degenne, Stavros Polymenis). * Contributing documentation (#379). * Massively adjust whitespace for legibility (#400, #409, #416, Richard Degenne). * Improvements to CI (Etienne Millon, Raphael Rafatpanah, Zack Coker, Yotam Barnoy). * The additional packages lwt_ssl, lwt_react, lwt_glib get new minor releases, the change being new Jbuilder build systems (#374, Andrew Ray). ===== 3.0.0 (2017-04-10) ===== ====== Breaking ====== * These changes were originally announced in release 2.7.0 (#308). * Lwt_engine.libev now has an optional argument for selecting the libev back end (#269, #294, Jeremy Yallop). * Lwt_io.establish_server has been changed to make it more difficult to leak file descriptors (#258, #260). * Lwt_io.shutdown_server now evaluates to a promise, which completes when the listening socket's close(2) operation completes (#259). * Lwt_unix.bind now evaluates to a promise, because the bind(2) system call can block for Unix domain sockets (#296, requested David Sheets). * ocamlfind packages lwt.react, lwt.ssl, lwt.glib are replaced by lwt_react, lwt_ssl, lwt_glib. These have been separate OPAM packages, under those names, since 2.7.0 (#301). ===== 2.7.1 (2017-04-08) ===== ====== Fixes ====== * OCaml 4.05 compatibility (Mauricio Fernandez, #322). * Give Lwt_unix.file_exists the same semantics as Sys.file_exists, with respect to not raising Unix.Unix_error (Mauricio Fernandez, #316). * Improve diagnostics from build scripts (Tim Cuthbertson, #313, #314). ====== Additions ====== * Announce Lwt_result, which was originally released as an experimental module in release 2.6.0 (Simon Cruanes, #320, #247). ===== 2.7.0 (2017-01-03) ===== ====== General ====== * Values of types a Lwt.t are now referred to as promises rather than threads (#300). The manual has not yet been updated. ====== Breaking ====== * After this release, Lwt will switch to semantic versioning. Future breaking changes will first require deprecation, then a major version number increase (#293). * Lwt no longer supports OCaml 4.01 (#272). * Lwt_unix.fdatasync is no longer available on macOS. It was calling an undocumented system call on that system (#285, Jeremy Yallop). ====== Planned to break in 3.0.0 ====== * APIs in this category have deprecation messages attached. The messages will be displayed if you recompile your code, and can also be seen in #308. * Lwt_engine.libev will have an argument for selecting the libev back end (#269, #294, Jeremy Yallop). * Lwt_io.establish_server will be replaced by a version that makes it difficult to leak file descriptors (#258, #260). * Lwt_io.shutdown_server will evaluate to a promise, which indicates when the close operation completes (#259). * Lwt_unix.bind will evaluate to a promise, since bind can block for Unix domain sockets (#296, requested David Sheets). * ocamlfind packages lwt.react, lwt.ssl, and lwt.glib will be replaced by the new lwt_react, lwt_ssl, and lwt_glib. These are now distributed in new OPAM packages with the same names, separately from OPAM package lwt (#301). ====== Additions ====== * Lwt_unix.readv and Lwt_unix.writev - zero-copy scatter/gather I/O (#291, #299). * ?fail_on_error argument for Lwt_log.load_rules (#306, Daniil Baturin). * Lwt_log.level_of_string (#306, Daniil Baturin). ====== Changes ====== * Lwt_stream.of_list, Lwt_stream.of_array, Lwt_stream.of_string now immediately push all elements into the created streams (#239, Spiros Eliopoulos). ====== Deprecations ====== * Lwt_stream.map_exn in favor of Lwt_stream.wrap_exn, which uses OCaml's standard result type (#295). ====== Bugs fixed ====== * Ungraceful failure if directory handle used after Lwt_unix.closedir (#292). * Buffer overflow in Lwt_unix.readdir and Lwt_unix.readdir_n (#292). * Unnecessary allocations in Lwt_unix.readdir_n (#292, found Jeremly Yallop). ====== Miscellaneous ====== * Annotate existing deprecations with [@@ocaml.deprecated ...] (5737f5b). * Improvements to the examples (#288, Rich Neswold). * Documentation fixes, including by Rich Neswold. * New tests and various minor internal improvements. * Run tests in CI with all OCaml warnings enabled (dadb926). * Much cleaner build output. * Add scratch/ directory for local use by developers. ===== 2.6.0 (2016-10-27) ===== ====== Additions ====== * Lwt_stream.closed and Lwt_stream.is_closed (#223, Spiros Eliopoulos). * Lwt_switch.with_switch (#256, Thomas Leonard). * Define 'a Lwt.result as ('a, exn) result (#247, Simon Cruanes). * Lwt_condition.broadcast_exn (#241, Nicolas Ojeda Bar). * Lwt_unix.utimes (#193). ====== Bugfixes ====== * Memory leak in Lwt_unix.readdir_n (#229, diagnosed Thomas Leonard). * Memory leak in Lwt.protected (#56, #181, reported @ygrek, Mauricio Fernandez). * Lwt_switch.turn_off hook exception handling (995b704). * Handling of ENOTCONN when channels passed to handler of Lwt_io.establish_server are closed (95fb431). * Duplicate exceptions on implicit close in Lwt_io.with_connection (b1afe45). * Deadlock in Lwt_main.at_exit (#48, #114, reported Jérôme Vouillon, Vincent Bernardoff). * Performance of Lwt_preemptive.detach (#218, #219, Mauricio Fernandez). * Bad hash functions for libev loops (#146, reported Mark Christiaens). * Hash of uninitialized data in Lwt_io (#217, reported Jeremy Yallop). * Update log sections after Lwt_log.load_rules (#188, reported @rand00). * Print three digits for milliseconds in Lwt_log (#264, Fabian Hemmer). * Do not truncate Unix job notification ids in C (#277, diagnosed @stijn-devriendt). ====== Deprecations ====== * Lwt_stream.on_termination: bind on Lwt_stream.closed instead. * Lwt.make_value, Lwt.make_error: use result's Ok and Error constructors. * Lwt_pqueue, Lwt_sequence: use min-heaps and linked lists from another library (#135). * Pa_lwt, Pa_lwt_log: use Ppx_lwt. ====== Miscellaneous ====== * Update examples to use PPX syntax instead of Camlp4 (#108, Peter Zotov). * Set up Travis, AppVeyor for testing on Linux, OS X, Cygwin, and MinGW. MSVC also planned. * Large amount of local documentation fixes (Hezekiah Carty, Etienne Millon, Leo Wzukw, Sebastien Mondet, reports by others). * A bunch of new tests. ===== 2.5.2 (2016-04-25) ===== * Fix compatibility for 4.03 (#227) * Various documentation fixes (#199,#200,#210) * Improve wildcard detection in the ppx (#198) * Fix Lwt_stream: bounded_push#close wake the reader (#201) * Fix infinite loop with Lwt_stream.choose (#214) * Fix laziness failure with Lwt_io.common#close (#207) ===== 2.5.1 (2015-12-07) ===== * Lwt_stream.on_terminate -> Lwt_stream.on_termination * Lwt_unix: handle O_CLOEXEC * Lwt_log: add OSX syslog path * Ppx: Improve lwt%match, improve catchall detection * Add Lwt_unix.file_exists and Lwt_unix.Large_file.file_exists * Build fixes ===== 2.5.0 (2015-07-03) ===== * API CHANGE: Functions in Lwt_io that were previously using a ~buffer_size argument now takes a ~buffer argument. * Accept ?buffer argument in Lwt_ssl.{in,out}_channel_of_descr. * Use newer Ssl bigarray read/write functionality to avoid allocation in Lwt_ssl. * Fix non-reentrant function calls (#136) * IPv4 multicast support. * Add support for if%lwt in ppx extension. * Add Lwt.return_some. * Disable log syntax extension by default in ppx. Give [-log] as ppx argument to enable it. * Nanosecond precision for Lwt_unix.stat. * Minor fixes + documentation improvements. ===== 2.4.8 (2015-03-11) ===== * Fix compilation under Windows (#117, #129) * Fix Lwt_engine.on_timer (#121) * Add Lwt_log_core.reset_rules (#123) * Fixed typos in the documentation (#119, #131) ===== 2.4.7 (2015-01-06) ===== * camlp4 is now optional. * Add safe_string compliance except for Lwt_ssl (need ocaml-ssl fix). * Add Lwt.Infix module to open instead of Lwt to have (>>=), etc. * Add Lwt_list.filter_map_{s,p} functions. * Add Lwt.fail_{with,invalid_arg} functions. * Improved Android support. * Remove deprecated lwt.text and lwt.top libraries. * Remove deprecated Lwt_signal and Lwt_event modules from lwt.react. * Fix #111: try_lwt wrongly warns about unused match case. * Fix #96: Fix Lwt_react.S.limit and Lwt_react.E.limit. * Fix #91: Workaround to fix compilation on OSX. ===== 2.4.6 (2014-10-12) ===== * Add a ppx syntax extension * Add a ?fd argument to Lwt_io.{open_connection,with_connection,establish_server}. * Fix stub for getaddrinfo and getprotobyname * Windows fix: don't throw an exception in the notification handler if we're shutting down * Fix include file search in ./configure * ./configure fixes for windows * Fix: use sys_exit instead of exit when Unix.execv fails ===== 2.4.5 (2014-04-21) ===== * Lwt_ssl: expand API to allow setting socket options with Ssl functions * fix for camlp4 trunk * support for React 1.0.0 * add Lwt_sequence.find_node_* functions * Lwt_log: get backtrace early to overcome exns in Printexc.to_string * fix potential deadlock in lwt_unix_recv_notifications * lwt.glib fixes: - handle HUP - fix for BSD/OSX * do not raise an exception in Lwt_log if argv[0] is blank ===== 2.4.4 (2013-10-22) ===== * add Android support * fix issues in stubs for Lwt_unix jobs * fix compatibility issue with OCaml 4.01 * fix the stub for ev_timer_init * add Lwt.log containing Lwt_log_core, the Unix-free part of Lwt_log * add Lwt_ssl.get_fd * fix stdout/stderr redirections in Lwt_daemon.daemonize * add Lwt_list.{map,iter}i{_s,_p} ===== 2.4.3 (2012-12-27) ===== * fix Lwt_ssl.{in,out}_channel_of_descr: shutdown and close the socket when the channel is closed ===== 2.4.2 (2012-09-28) ===== * fix the stub for Lwt_unix.readdir * change the default method for Lwt_glib.install (use the glib main loop by default: more portable) * ignore invalid file descriptors returned by glib (like the emulation of select in glib does) * use environment variables in discover.ml - use LIBRARY_PATH and C_INCLUDE_PATH for searching headers - allow to pass flags for a library in _CLFAGS and _LIBS * add Lwt_unix.on_signal_full ===== 2.4.1 (2012-08-22) ===== * Add Lwt_stream.on_terminate * Fix Lwt_gc * Fix stubs for get_credentials on *BSD ===== 2.4.0 (2012-07-16) ===== * Reimplement Lwt_stream - much simpler and more efficient - do not use Weak - add bounded push streams * Add Lwt.async * Add Lwt_preemptive.run_in_main * Implement Lwt_unix.get_credentials on MacOS X/OpenBSD * Ensure that on_cancel functions are executed first * Better implementation of Lwt.cancel with more tests * Simplify the API for unix jobs * Better handling of the master lock in libev stubs * Windows fixes/updates: - pass -lws2_32 instead of ws2_32.lib if building with mingw - fix a bug causing Lwt_unix.read/write to block when a socket is not readable/writable - port Lwt_process and Lwt_unix.system to Windows * Compatibility with OCaml 4.00: - add O_SHARE_DELETE to Lwt_unix.open_flag - add -package compiler-libs.toplevel for files using Toploop * Do not use module Sys for signal handling to avoid OCaml code to be called in a C thread * Fix Lwt_unix.wrap_syscall: try instead of Lwt.catch * Fix a dead-lock between lwt_unix_send_notification and lwt_unix_recv_notifications * Fix #277: add a function to return the Ssl.socket of a Lwt_ssl.socket * Fix problems with C libraries detection/linking ===== 2.3.2 (2011-11-04) ===== * Add location informations in logs: ** allow loggers to get the current location through local storage ** pass current location to logging functions ** pass the current location with the syntax extension * Add Lwt.on_termination * Add Lwt_unix.reinstall_signal_handler * Add Lwt_io.flush_all * Add assert_lwt keyword to the syntax extension * Add Lwt.wrap * Add Lwt_glib.iter and Lwt_glib.wakeup * OCaml 3.13 ready * Allow to compile without libev support * Fix bugs in Lwt_io * Better handling of forks * Fix many problems on Windows ===== 2.3.1 (2011-07-13) ===== * Fix building of documentation when using the tarball * Add Lwt_unix.fsync and Lwt_unix.fdatasync * Fix the stubs for Lwt_unix.send_msg when fd-passing is not available * Add -lwt-sequence-strict option to the syntax extension * Use a custom PRNG state for Lwt.choose and Lwt.pick * Fix a display glitch when starting the toplevel * Add Lwt_unix.fork which should now be used when one want to use Lwt in the child process * Better implementation of Lwt_unix.readlink and Lwt_unix.gethostbyname, which fixes compilation on Hurd * Add Lwt.wakeup_later and Lwt.wakeup_later_exn to be used when one need to do lot of nested wakeup, which fixes a buffer overflow in Lwt_mutex * Fix Lwt_unix.abort and Lwt_unix.close (threads was never wakeup) * Fix Lwt_throttle for correct timings * Fix subtle use of cancel ===== 2.3.0 (2011-04-12) ===== * Add an extensible system of engines to: ** allow the user to replace libev by another event system, such as select ** allow easier integration of external libraries supporting asynchronous operations * Lots of improvements for Windows: ** use the OCaml select instead of libev by default on Windows ** make asynchronous operations on non-socket file descriptors such as pipes to work ** make glib integration to work * Better use of engines in Lwt_unix: now events are cached to minimize the amount of calls to epoll_ctl * Use an eventfd when possible for notifications for faster delivery * Add modules: ** Lwt_sys: allow to test availability of extra features ** Lwt_react: replace Lwt_event and Lwt_signal * Allow to configure logging rules at runtime in Lwt_log * Add match_lwt and while_lwt to the syntax extension * Fixes: ** syntax extension: handle "lwt ... = ... in ..." at toplevel ** make the notification system fork-proof ** fix an issue with stubs not raising correctly exceptions ===== 2.2.1 (2011-01-26) ===== * Better interaction with Js_of_OCaml. * Add functions {{{Lwt.register_pause_notifier}}} and {{{Lwt.paused_count}}}. ===== 2.2.0 (2010-12-13) ===== * Bugfixes: ** Fix a bug with cancellable threads causing {{{Canceled}}} exceptions to be raised randomly ** Fix a fd-leak in Lwt_io.open_connection * {{{Lwt_unix}}} now use libev instead of select * Add thread local storage support to {{{Lwt}}} * Add backtrace support to {{{Lwt}}}. Now {{{Lwt}}} exceptions can be recorded by using the syntax extension with the {{{-lwt-debug}}} command line switch. * Allow blocking system calls to be executed in parallels * Change the type of many functions of {{{Lwt_unix}}}, which now return a {{{Lwt}}} thread * Add functions {{{Lwt_unix.readable}}} and {{{Lwt_unix.writable}}} * Add function {{{Lwt_io.is_busy}}} * Add functions {{{Lwt_event.delay}}} and {{{Lwt_signal.delay}}} * Add function {{{Lwt_term.render_update}}} * Add function {{{Lwt_ssl.embed_socket}}} * Add module {{{Lwt_bytes}}} defining operations on bigarrays instead of strings * Use bigarrays in Lwt_io instead of strings for the internal buffer. Lwt_io.make now takes a function that uses a bigarray. * Add module {{{Lwt_switch}}} ===== 2.1.1 (2010-06-13) ===== * Many bugfixes, including: ** buggy behaviour of cancellable threads ** file descriptor leakage in {{{Lwt_unix.accept_n}}} * Add {{{Lwt.nchoose}}} and {{{Lwt.npick}}} * Use {{{set_close_on_exec}}} for fds created by {{{Lwt_log}}} * Better implementation of lwtized react functions ===== 2.1.0 (2010-04-19) ===== * Rename {{{Lwt.select}}} to {{{Lwt.pick}}} * Removing module {{{Lwt_monitor}}} in favour of {{{Lwt_mutex}}} and new module {{{Lwt_condition}}} * More react helpers: ** {{{Lwt_event.next}}} ** {{{Lwt_event.limit}}} and {{{Lwt_signal.limit}}} ** {{{Lwt_event.from}}} * Adding function {{{Lwt_main.fast_yield}}} * Adding unit tests * Optimisation of {{{Lwt}}} * Adding module {{{Lwt_log}}} for logging * Adding a camlp4 filter for remmoving logging statement or inlining tests * Adding module {{{Lwt_daemon}}} * Adding function {{{Lwt_unix.recv_msg}}} and {{{Lwt_unix.send_msg}}} * Adding function {{{Lwt_unix.wait4}}} * Adding function {{{Lwt_io.establish_server}}} * Adding module {{{Lwt_list}}} * Enhancement in {{{Lwt_process}}}, it now support redirections and timeouts * Allow to use {{{select}}} on arbitrary high file descriptors * More commands and features in {{{Lwt_read_line}}}: ** Handle "undo" command ** New controllable read-lines instances ** More edition commands ** Completion as you type ** Backward search * Enhancement in {{{Lwt_term}}}: more drawing functions and allow to put the terminal into drawing mode * Optimisation of {{{Lwt_stream}}} * Optimisation of {{{Lwt_io.write_char}}} and {{{Lwt_io.read_char}}} * Bugfix of {{{Lwt_stream}}}: two parallel {{{Lwt_stream.get}}} returned the same value * Bugfix in {{{Lwt_unix.connect}}}: it returned immediately on EINPROGRESS * Bugfixes in {{{Lwt_glib}}}: file descriptors were not monitored correctly ===== 2.0.0 (2009-10-15) ===== * Adding modules: ** {{{Lwt_stream}}}: lwt-aware version of the {{{Stream}}} module ** {{{Lwt_gc}}} for using {{{finalise}}} without {{{Lwt_unix.run}}} ** {{{Lwt_io}}}: a new implementation of buffered channels with more features and better handling of concurrent access ** {{{Lwt_text}}}: implementation of text channels ** {{{Lwt_process}}}: helpers to spawn processes and communicate with them ** {{{Lwt_main}}} for abstracting the main loop and allowing replacement by a custom main loop ** {{{Lwt_glib}}} for integration into the glib main event loop ** {{{Lwt_term}}} for interaction with the terminal ** {{{Lwt_read_line}}} for interactive user input ** {{{Lwt_monitor}}}, {{{Lwt_mvar}}}: combined locks for synchronization with conditional variables for notification ** {{{Lwt_throttle}}} for limiting rate of execution (e.g. for authentication procedure) ** {{{Lwt_sequence}}}: mutable sequence of elements ** {{{Lwt_event}}}, {{{Lwt_signal}}}: helpers for reactive programming with lwt * Adding a syntax extension {{{pa_lwt}}}: ** handles anonymous bind {{{a >> b}}} ** adds syntactic sugar for catching errors (ticket #6) ** adds syntactic sugar for parallel let-binding construction ** adds syntactic sugar for for-like loops * Top-level integration: ** threads can runs while reading user input ** line editing support * New enhanced OCaml toplevel with some basic completion features * Adding C stubs to reimplement {{{Unix.read}}} and {{{Unix.write}}} with assumption of non-blocking behaviour * Adding more functions/helpers in {{{Lwt}}} * Fixing memory leaks in {{{Lwt.choose}}} * Bugfix in {{{Lwt_chan.close_*}}} (ticket #66) * Separate the type of threads (covariant) from the type of thread wakeners (contravariant); the type of many functions related to {{{Lwt.wait}}} has been changed * Add cancelable threads * Unix-dependent part is now put in its own archive and findlib package. ===== 1.1.0 (2008-06-25) ===== * Adding module {{{Lwt_pool}}} for creating pools (for example pools of connections) * Adding a few functions in {{{Lwt_chan}}} * Fixing bugs in {{{Lwt_util.map_serial}}} and {{{Lwt_util.iter_serial}}} * Putting {{{Lwt_preemptive}}}, {{{Lwt_lib}}} and {{{Lwt_ssl}}} in separate libraries and findlib subpackages so that lwt.cma depends only on unix.cma. ===== 1.0.0 (and before) ===== * See Ocsigen changelog lwt-5.9.1/CODE_OF_CONDUCT.md000066400000000000000000000007751476253734400151630ustar00rootroot00000000000000# Code of Conduct This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). # Enforcement This project follows the OCaml Code of Conduct [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). To report any violations, please contact Jérôme Vouillon, Raphaël Proust, Vincent Balat, Hugo Heuzard and Gabriel Radanne at (or some of them individually). lwt-5.9.1/LICENSE.md000066400000000000000000000020731476253734400137610ustar00rootroot00000000000000Copyright (c) 1999-2020, the Authors of Lwt (docs/AUTHORS) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. lwt-5.9.1/Makefile000066400000000000000000000033331476253734400140150ustar00rootroot00000000000000# Default rule .PHONY: default default: build # build the usual development packages .PHONY: build build: dune build # run unit tests for package lwt .PHONY: test test: build dune runtest # Promote expect test output. .PHONY : promote promote : for FILE in $$(ls _build/default/test/ppx_expect/cases/*.fixed); \ do \ EXPECT=test/ppx_expect/cases/$$(basename $${FILE%.fixed}).expect; \ cp $$FILE $$EXPECT; \ done # Install dependencies needed during development. .PHONY : dev-deps dev-deps : opam install . --deps-only --yes # Use Dune+odoc to generate static html documentation. # Currently requires ocaml 4.03.0 to install odoc. .PHONY: doc doc: dune build @doc # Build HTML documentation with ocamldoc .PHONY: doc-api-html doc-api-html: build $(MAKE) -C docs api/html/index.html # Build wiki documentation with wikidoc # requires ocaml 4.03.0 and pinning the repo # https://github.com/ocsigen/wikidoc .PHONY: doc-api-wiki doc-api-wiki: build $(MAKE) -C docs api/wiki/index.wiki # ppx_let integration test. .PHONY : ppx_let-test ppx_let-test : dune build test/ppx_let/test.exe dune exec test/ppx_let/test.exe .PHONY: clean clean : dune clean rm -fr docs/api rm -f src/unix/discover_arguments rm -rf _coverage/ EXPECTED_FILES := \ --expect src/core/ \ --expect src/react/ \ --expect src/unix/ \ --do-not-expect src/unix/config/ \ --do-not-expect src/unix/lwt_gc.ml \ --do-not-expect src/unix/lwt_throttle.ml \ --do-not-expect src/unix/unix_c/ .PHONY: coverage coverage : rm -rf _build/default/test/ppx_expect find _build -name '*.coverage' | xargs rm -f BISECT_ENABLE=yes dune runtest --force bisect-ppx-report html $(EXPECTED_FILES) bisect-ppx-report summary @echo See _coverage/index.html lwt-5.9.1/README.md000066400000000000000000000155461476253734400136450ustar00rootroot00000000000000# Lwt [![version][version]][releases] [![GitHub Actions status][github-actions-img]][github-actions] [version]: https://img.shields.io/github/v/release/ocsigen/lwt [releases]: https://github.com/ocsigen/lwt/releases [github-actions]: https://github.com/ocsigen/lwt/actions [github-actions-img]: https://github.com/ocsigen/lwt/actions/workflows/workflow.yml/badge.svg?branch=master Lwt is a concurrent programming library for OCaml. It provides a single data type: the *promise*, which is a value that will become determined in the future. Creating a promise spawns a computation. When that computation is I/O, Lwt runs it in parallel with your OCaml code. OCaml code, including creating and waiting on promises, is run in a single thread by default, so you don't have to worry about locking or preemption. You can detach code to be run in separate threads on an opt-in basis. Here is a simplistic Lwt program which requests the Google front page, and fails if the request is not completed in five seconds: ```ocaml open Lwt.Syntax let () = let request = let* addresses = Lwt_unix.getaddrinfo "google.com" "80" [] in let google = Lwt_unix.((List.hd addresses).ai_addr) in Lwt_io.(with_connection google (fun (incoming, outgoing) -> let* () = write outgoing "GET / HTTP/1.1\r\n" in let* () = write outgoing "Connection: close\r\n\r\n" in let* response = read incoming in Lwt.return (Some response))) in let timeout = let* () = Lwt_unix.sleep 5. in Lwt.return None in match Lwt_main.run (Lwt.pick [request; timeout]) with | Some response -> print_string response | None -> prerr_endline "Request timed out"; exit 1 (* ocamlfind opt -package lwt.unix -linkpkg example.ml && ./a.out *) ``` In the program, functions such as `Lwt_io.write` create promises. The `let* ... in` construct is used to wait for a promise to become determined; the code after `in` is scheduled to run in a "callback." `Lwt.pick` races promises against each other, and behaves as the first one to complete. `Lwt_main.run` forces the whole promise-computation network to be executed. All the visible OCaml code is run in a single thread, but Lwt internally uses a combination of worker threads and non-blocking file descriptors to resolve in parallel the promises that do I/O.
### Overview Lwt compiles to native code on Linux, macOS, Windows, and other systems. It's also routinely compiled to JavaScript for the front end and Node by js_of_ocaml. In Lwt, - The [core library `Lwt`][core] provides promises... - ...and a few pure-OCaml helpers, such as promise-friendly [mutexes][mutex], [condition variables][cond], and [mvars][mvar]. - There is a big Unix binding, [`Lwt_unix`][unix] that binds almost every Unix system call. A higher-level module [`Lwt_io`][io] provides nice I/O channels. - [`Lwt_process`][process] is for subprocess handling. - [`Lwt_preemptive`][preemptive] spawns system threads. - The [PPX syntax][ppx] allows using all of the above without going crazy! - There are also some other helpers, such as [`Lwt_react`][react] for reactive programming. See the table of contents on the linked manual pages! [core]: https://ocsigen.org/lwt/latest/api/Lwt [cond]: https://ocsigen.org/lwt/latest/api/Lwt_condition [mutex]: https://ocsigen.org/lwt/latest/api/Lwt_mutex [mvar]: https://ocsigen.org/lwt/latest/api/Lwt_mvar [unix]: https://ocsigen.org/lwt/latest/api/Lwt_unix [io]: https://ocsigen.org/lwt/latest/api/Lwt_io [process]: https://ocsigen.org/lwt/latest/api/Lwt_process [preemptive]: https://ocsigen.org/lwt/latest/api/Lwt_preemptive [ppx]: https://ocsigen.org/lwt/latest/api/Ppx_lwt [react]: https://ocsigen.org/lwt/latest/api/Lwt_react
## Installing 1. Use your system package manager to install a development libev package. It is often called `libev-dev` or `libev-devel`. 2. `opam install conf-libev lwt`
## Documentation We are currently working on improving the Lwt documentation (drastically; we are rewriting the manual). In the meantime: - The current manual can be found [here][manual]. - Mirage has a nicely-written [Lwt tutorial][mirage-tutorial]. - An example of a [simple server][counter-server] written in Lwt. - [Concurrent Programming with Lwt][rwo-lwt] is a nice source of Lwt examples. They are translations of code from the excellent Real World OCaml, but are just as useful if you are not reading the book. *Note: much of the current manual refers to `'a Lwt.t` as "lightweight threads" or just "threads." This will be fixed in the new manual. `'a Lwt.t` is a promise, and has nothing to do with system or preemptive threads.* [manual]: https://ocsigen.org/lwt/ [rwo-lwt]: https://github.com/dkim/rwo-lwt#readme [mirage-tutorial]: https://mirage.io/docs/tutorial-lwt [counter-server]: https://baturin.org/code/lwt-counter-server/
## Contact Open an [issue][issues], visit [Discord][discord] chat, ask on [discuss.ocaml.org][discourse], or on [Stack Overflow][so]. Release announcements are made on [discuss.ocaml.org][discourse]. Watching the repo for "Releases only" is also an option. [so]: https://stackoverflow.com/questions/ask?tags=ocaml,lwt,ocaml-lwt [discourse]: https://discuss.ocaml.org/tag/lwt [issues]: https://github.com/ocsigen/lwt/issues/new [discord]: https://discord.com/invite/cCYQbqN
## Contributing - [`CONTRIBUTING.md`][contributing-md] contains tips for working on the code, such as how to check the code out, how review works, etc. There is also a high-level outline of the code base. - [Ask](#contact) us anything, whether it's about working on Lwt, or any question at all about it :) - The [documentation](#documentation) always needs proofreading and fixes. - You are welcome to pick up any other [issue][issues-and-prs], review a PR, add your opinion, etc. - Any feedback is welcome, including how to make contributing easier! [issues-and-prs]: https://github.com/ocsigen/lwt/issues?utf8=%E2%9C%93&q=is%3Aopen [contributing-md]: https://github.com/ocsigen/lwt/blob/master/docs/CONTRIBUTING.md#readme
## Libraries to use with Lwt - [alcotest](https://github.com/mirage/alcotest/) — unit testing - [angstrom](https://github.com/inhabitedtype/angstrom) — parser combinators - [cohttp](https://github.com/mirage/ocaml-cohttp) — HTTP client and server - [cstruct](https://github.com/mirage/ocaml-cstruct) — interop with C-like structures - [ezjsonm](https://github.com/mirage/ezjsonm) — JSON parsing and output - [faraday](https://github.com/inhabitedtype/faraday) — serialization combinators - [logs](https://github.com/dbuenzli/logs) — logging - [lwt-parallel](https://github.com/ivg/lwt-parallel) — distributed computing - [mwt](https://github.com/hcarty/mwt) — preemptive (system) thread pools - [opium](https://github.com/rgrinberg/opium) — web framework - [lwt_domain](https://github.com/ocsigen/lwt_domain) — domain parallelism when using Lwt with OCaml 5 lwt-5.9.1/docs/000077500000000000000000000000001476253734400133035ustar00rootroot00000000000000lwt-5.9.1/docs/AUTHORS000066400000000000000000000015101476253734400143500ustar00rootroot00000000000000Copyright (c) 1999-2008 Jérôme Vouillon Laboratoire PPS - CNRS Université Paris Diderot 2005 Nataliya Guts, Vincent Balat Laboratoire PPS - CNRS Université Paris Diderot 2008 Stéphane Glondu 2009 Mauricio Fernandez 2009, 2010 Pierre Chambart 2009-2012 Jérémie Dimino Laboratoire PPS - CNRS Université Paris Diderot 2014 Peter Zotov 2014, 2018 Gabriel Radanne 2015 Nicolas Ojeda Bar 2016 Simon Cruanes 2016-2018 Anton Bachin 2017 Joseph Thomas 2017 Andrew Ray 2020 Raphaël Proust Nomadic Labs lwt-5.9.1/docs/CONTRIBUTING.md000066400000000000000000000231001476253734400155300ustar00rootroot00000000000000# Contributing to the Lwt code Contributing to Lwt doesn't only mean writing code! Asking questions, fixing docs, etc., are all valuable contributions. For notes on contributing in general, see [Contributing][contributing] in the Lwt `README`. This file contains extra information for working on code specifically. This file is meant to be an aid, not a hindrance. If you think you already have a good idea of what to do, go ahead and work without reading this :)
#### Table of contents - [General](#General) - [OPAM+git workflow](#Workflow) - [Getting the code](#Checkout) - [Testing](#Testing) - [Testing with coverage analysis](#Test_with_coverage_analysis) - [Getting your change merged](#Getting_your_change_merged) - [Making additional changes](#Making_additional_changes) - [Cleaning up](#Cleaning_up) - [Internal documentation](#Documentation) - [Code overview](#Code_overview)
## General 1. If you get stuck, or have any question, please [ask][contact]! 2. If you start working, but then life interferes and you don't want to continue, there is no problem in stopping. This can be for any reason whatsoever, and you don't have to tell anyone what that reason is. Lwt respects your time and your needs. 3. If a maintainer is trying your patience (hopefully by accident) by making you fix too many nits, do excessive history rewriting, or something else like that, please let them know! Lwt doesn't want to tire you out! 4. To find something to work on, you can look at the [easy issues][easy]. If those don't look interesting, some [medium issues][medium] are self-contained. If you [contact][contact] the maintainers, they may be able to suggest a few. Otherwise, you are welcome to work on anything at all. 5. If you begin working on an issue, it's good to leave a comment on it to claim it. This prevents multiple people from doing the same work. [contact]: https://github.com/ocsigen/lwt#contact [contributing]: https://github.com/ocsigen/lwt#contributing [easy]: https://github.com/ocsigen/lwt/labels/easy [medium]: https://github.com/ocsigen/lwt/labels/medium
## OPAM+git workflow #### Getting the code To get started, fork the Lwt repo by clicking on the "Fork" button at the very top of this page. You will now have a repository at `https://github.com/your-user-name/lwt`. Let's clone it to your machine: ``` git clone https://github.com/your-user-name/lwt.git cd lwt/ ``` Now, we need to install Lwt's development dependencies. Before doing that, you may want to switch to a special OPAM switch for working on Lwt: ``` opam switch create . 4.08.2 --no-install # optional eval `opam config env` # optional make dev-deps ``` On most systems, you should also [install libev][installing]: ``` your-package-manager install libev-devel opam install conf-libev ``` [installing]: https://github.com/ocsigen/lwt#installing Now, check out a new branch, and make your changes: ``` git checkout -b my-awesome-change ``` #### Testing Each time you are ready to test, run ``` make test ``` If you want to test your development branch using another OPAM package that depends on Lwt, install your development copy of Lwt with: ``` opam pin add lwt . opam install lwt ``` If you make further changes, you can install your updated code with: ``` opam upgrade lwt ``` Since Lwt is pinned, these commands will install Lwt from your modified code. All installed OPAM packages that depend on Lwt will be rebuilt against your modified code when you run these commands. #### Testing with coverage analysis To generate coverage reports, run ``` make coverage ``` in the Lwt repo. To view the coverage report, open `_coverage/index.html` in your browser. #### Getting your change merged When you are ready, commit your change: ``` git commit ``` You can see examples of commit messages in the Git log; run `git log`. Now, upload your commit(s) to your fork: ``` git push -u origin my-awesome-change ``` Go to the GitHub web interface for your Lwt fork (`https://github.com/your-user-name/lwt`), and click on the New Pull Request button. Follow the instructions, and open the pull request. This will trigger automatic building and testing of your change on many versions of OCaml, and several operating systems, in [GitHub Actions][github-actions]. You can even a submit a preliminary PR just to trigger these tests – just say in the description that it's not ready for review! At about the same time, a (hopefully!) friendly maintainer will review your change and start a conversation with you. Ultimately, this will result in a merged PR and a "thank you!" :smiley: You'll be immortalized in the history, mentioned in the changelog, and you will have helped a bunch of users have an easier time with Lwt. Finally, take a nice break :) This process can be a lot! #### Making additional changes If additional changes are needed after you open the PR, make them in your branch locally, commit them, and run: ``` git push ``` This will push the changes to your fork, and GitHub will automatically update the PR. #### Tidy history In some cases, you may be asked to rebase or squash your PR for a cleaner history (it's normal). If that happens, you will need to run some combination of `git rebase master`, `git rebase -i master`, and/or `git cherry-pick`. There isn't really enough space to explain these commands here, but: - We encourage you to find examples and documentation for them online. - You can always ask a maintainer for help using them. - You can always ask a maintainer to do it for you (and we will usually offer). We can tell you what commands we ran and why. Afterwards, `git push -f` will force the new history into the PR. If we do this rewriting, it is usually at the very end, right before merging the PR. This is to avoid interfering with reviewers while they are still reviewing it. [github-actions]: https://github.com/ocsigen/lwt/actions
## Internal documentation Lwt internal documentation is currently pretty sparse, but we are working on fixing that. - The bulk of documentation is still the [manual][manual]. - The [internals of the Lwt core][lwt.ml] are well-documented. - Working on the Unix binding (`Lwt_unix`, `Lwt_bytes`, etc.) sometimes requires writing C code. To make this easier, we have thoroughly [documented `Lwt_unix.getcwd`][unix-model] as a model function. - Everything else is sparsely documented in comments. [manual]: https://ocsigen.org/lwt/ [lwt.ml]: https://github.com/ocsigen/lwt/blob/master/src/core/lwt.ml [unix-model]: https://github.com/ocsigen/lwt/blob/99d1ec8b5c159456855eb2f55ddab77207bc92b3/src/unix/unix_c/unix_getcwd_job.c#L36
## Code overview Lwt is separated into several layers and sub-libraries, grouped by directory. This list surveys them, roughly in order of importance. - [`src/core/`][core-dir] is the "core" library. It is written in pure OCaml, so it is portable across all systems and to JavaScript. The major file here is [`src/core/lwt.ml`][lwt.ml], which implements the main type, [`'a Lwt.t`][Lwt.t]. Also here are some pure-OCaml data structures and synchronization primitives. Most of the modules besides `Lwt` are relatively trivial – the only exception to this is [`Lwt_stream`][Lwt_stream]. The code in `src/core/` doesn't know how to do I/O – that is system specific. On Unix (including Windows), I/O is provided by the Unix binding (see below). On js_of_ocaml, it is provided by `Lwt_js`, a module distributed with js_of_ocaml. - [`src/ppx/`][ppx-dir] is the Lwt PPX. It is also portable, but separated into its own little code base, as it is an optional separate library. - [`src/unix/`][unix-dir] is the Unix binding, i.e. [`Lwt_unix`][Lwt_unix], [`Lwt_io`][Lwt_io], [`Lwt_main`][Lwt_main], some other related modules, and a bunch of [C code][c]. This is what actually does I/O, maintains a worker thread pool, etc. This is not portable to JavaScript. It supports Unix and Windows. We want to write a future pair of Node.js and Unix/Windows bindings, so that code using them is portable, even if two separate sets of bindings are required. See [#328][issue-328]. - [`src/react/`][react-dir] provides the separate library [`Lwt_react`][Lwt_react]. This is basically an independent project that lives in the Lwt repo. - [`src/util/`][util-dir] contains various scripts, such as the [configure script][configure.ml] scripts, etc. [core-dir]: https://github.com/ocsigen/lwt/tree/master/src/core [lwt.ml]: https://github.com/ocsigen/lwt/blob/master/src/core/lwt.ml [Lwt.t]: https://github.com/ocsigen/lwt/blob/73976987bcae37133e2cd590bcc515afc9e1498e/src/core/lwt.ml#L424 [Lwt_stream]: https://github.com/ocsigen/lwt/blob/master/src/core/lwt_stream.mli [ppx-dir]: https://github.com/ocsigen/lwt/tree/master/src/ppx [unix-dir]: https://github.com/ocsigen/lwt/tree/master/src/unix [Lwt_unix]: https://github.com/ocsigen/lwt/blob/master/src/unix/lwt_unix.cppo.mli [Lwt_io]: https://github.com/ocsigen/lwt/blob/master/src/unix/lwt_io.mli [Lwt_main]: https://github.com/ocsigen/lwt/blob/master/src/unix/lwt_main.mli [c]: https://github.com/ocsigen/lwt/tree/master/src/unix/unix_c [issue-328]: https://github.com/ocsigen/lwt/issues/328 [react-dir]: https://github.com/ocsigen/lwt/tree/master/src/react [Lwt_react]: https://github.com/ocsigen/lwt/blob/master/src/react/lwt_react.mli [util-dir]: https://github.com/ocsigen/lwt/tree/master/src/util lwt-5.9.1/docs/Makefile000066400000000000000000000022151476253734400147430ustar00rootroot00000000000000BLD=../_build/default/src SRC=../src PKGS=\ -package bytes -package result \ -package bigarray -package unix \ -package ocaml-migrate-parsetree -package ppx_tools_versioned \ -package react INCS=\ -I ${BLD}/core/.lwt.objs/byte \ -I ${BLD}/ppx/.ppx_lwt.objs/byte \ -I ${BLD}/react/.lwt_react.objs/byte \ -I ${BLD}/unix/.lwt_unix.objs/byte MLIS=\ $(wildcard ${SRC}/core/*.mli) \ $(wildcard ${SRC}/ppx/*.mli) \ $(wildcard ${SRC}/react/*.mli) \ $(filter-out ${BLD}/unix/lwt_unix.cppo.mli,$(wildcard ${BLD}/unix/*.mli)) MLIS := $(filter-out %.pp.mli,$(MLIS)) DOCOPT := -colorize-code -short-functors -charset utf-8 .PHONY: doc wikidoc doc: api/html/index.html api/html/index.html: ${MLIS} apiref-intro mkdir -p api/html ocamlfind ocamldoc ${DOCOPT} -package ocamlbuild,uchar ${PKGS} ${INCS} -intro apiref-intro -html \ -d api/html \ ${MLIS} wikidoc: api/wiki/index.wiki api/wiki/index.wiki: ${MLIS} apiref-intro mkdir -p api/wiki ocamlfind ocamldoc ${DOCOPT} -package ocamlbuild,uchar ${PKGS} ${INCS} -intro apiref-intro \ -d api/wiki \ -i $(shell ocamlfind query wikidoc) -g odoc_wiki.cma \ ${MLIS} .PHONY : clean clean : rm -rf api/ lwt-5.9.1/docs/apiref-intro000066400000000000000000000031411476253734400156240ustar00rootroot00000000000000{1 Lwt - API Reference} {2 Core library} The {e core} library ({e lwt} package) contains the {!Lwt} module, which defines cooperative threads with all the primitives to manipulate them. It also provides several general purpose modules, which do not depend on any external package. {!modules: Lwt Lwt_result Lwt_condition Lwt_list Lwt_mutex Lwt_mvar Lwt_pool Lwt_stream Lwt_switch Lwt_sequence Lwt_seq Lwt_pqueue } {2 Unix bindings} The {e lwt.unix} package provides: - the {!Lwt_unix} module, which wrap system calls into cooperative ones - the {!Lwt_io} module, which defines cooperative byte channel, in replacement of ones of the standard library - module helpers for spawning processes, ... {!modules: Lwt_gc Lwt_io Lwt_main Lwt_engine Lwt_process Lwt_throttle Lwt_timeout Lwt_unix Lwt_bytes Lwt_fmt Lwt_sys } This package depends on the {e core} library and the {e unix} package. {2 Reactive programming helpers} The {e lwt.react} package provides helpers for functional reactive programming with Lwt. It is based on the {e react} package. The {!Lwt_react} module is a replacement for the [React] module. It contains: - all the functions of the [React] module - Lwt specific primitives - cooperative versions of {e react} functions {!modules: Lwt_react } This package depends on the {e core} library and the {e react} package. {2 PPX syntax extension} Syntactic sugar for Lwt, such as [let%lwt x = e in e'] syntax for [bind]. {!modules: Ppx_lwt } {2 Miscellaneous} The following modules are wrapper for integration of non-Lwt functions/packages into Lwt. {!modules: Lwt_preemptive } {2 Index} {!indexlist} lwt-5.9.1/docs/dune000066400000000000000000000000661476253734400141630ustar00rootroot00000000000000(documentation (package lwt) (mld_files :standard)) lwt-5.9.1/docs/manual.mld000066400000000000000000000747451476253734400152770ustar00rootroot00000000000000{0 Lwt manual } {1 Introduction } When writing a program, a common developer's task is to handle I/O operations. Indeed, most software interacts with several different resources, such as: {ul {- the kernel, by doing system calls,} {- the user, by reading the keyboard, the mouse, or any input device,} {- a graphical server, to build graphical user interface,} {- other computers, by using the network,} {- …and so on.}} When this list contains only one item, it is pretty easy to handle. However as this list grows it becomes harder and harder to make everything work together. Several choices have been proposed to solve this problem: {ul {- using a main loop, and integrating all components we are interacting with into this main loop,} {- using preemptive system threads.}} Both solutions have their advantages and their drawbacks. For the first one, it may work, but it becomes very complicated to write a piece of asynchronous sequential code. The typical example is graphical user interfaces freezing and not redrawing themselves because they are waiting for some blocking part of the code to complete. If you already wrote code using preemptive threads, you should know that doing it right with threads is a difficult job. Moreover, system threads consume non-negligible resources, and so you can only launch a limited number of threads at the same time. Thus, this is not a general solution. [Lwt] offers a third alternative. It provides promises, which are very fast: a promise is just a reference that will be filled asynchronously, and calling a function that returns a promise does not require a new stack, new process, or anything else. It is just a normal, fast, function call. Promises compose nicely, allowing us to write highly asynchronous programs. In the first part, we will explain the concepts of [Lwt], then we will describe the main modules [Lwt] consists of. {2 Finding examples } Additional sources of examples: {ul {- {{: https://github.com/dkim/rwo-lwt#readme }Concurrent Programming with Lwt}} {- {{: https://mirage.io/docs/tutorial-lwt }Mirage Lwt Tutorial}} {- {{: https://baturin.org/code/lwt-counter-server/ }Simple Server with Lwt}}} {1 The Lwt core library } In this section we describe the basics of [Lwt]. It is advised to start [utop] and try the given code examples. {2 Lwt concepts } Let's take a classic function of the [Stdlib] module: {[ # Stdlib.input_char;; - : in_channel -> char = ]} This function will wait for a character to come on the given input channel, and then return it. The problem with this function is that it is blocking: while it is being executed, the whole program will be blocked, and other events will not be handled until it returns. Now, let's look at the lwt equivalent: {[ # Lwt_io.read_char;; - : Lwt_io.input_channel -> char Lwt.t = ]} As you can see, it does not return just a character, but something of type [char Lwt.t]. The type ['a Lwt.t] is the type of promises that can be fulfilled later with a value of type ['a]. [Lwt_io.read_char] will try to read a character from the given input channel and {e immediately} return a promise, without blocking, whether a character is available or not. If a character is not available, the promise will just not be fulfilled {e yet}. Now, let's see what we can do with a [Lwt] promise. The following code creates a pipe, creates a promise that is fulfilled with the result of reading the input side: {[ # let ic, oc = Lwt_io.pipe ();; val ic : Lwt_io.input_channel = val oc : Lwt_io.output_channel = # let p = Lwt_io.read_char ic;; val p : char Lwt.t = ]} We can now look at the state of our newly created promise: {[ # Lwt.state p;; - : char Lwt.state = Lwt.Sleep ]} A promise may be in one of the following states: {ul {- [Return x], which means that the promise has been fulfilled with the value [x]. This usually implies that the asynchronous operation, that you started by calling the function that returned the promise, has completed successfully.} {- [Fail exn], which means that the promise has been rejected with the exception [exn]. This usually means that the asynchronous operation associated with the promise has failed.} {- [Sleep], which means that the promise is has not yet been fulfilled or rejected, so it is {e pending}.}} The above promise [p] is pending because there is nothing yet to read from the pipe. Let's write something: {[ # Lwt_io.write_char oc 'a';; - : unit Lwt.t = # Lwt.state p;; - : char Lwt.state = Lwt.Return 'a' ]} So, after we write something, the reading promise has been fulfilled with the value ['a']. {2 Primitives for promise creation } There are several primitives for creating [Lwt] promises. These functions are located in the module [Lwt]. Here are the main primitives: {ul {- [Lwt.return : 'a -> 'a Lwt.t] creates a promise which is already fulfilled with the given value} {- [Lwt.fail : exn -> 'a Lwt.t] creates a promise which is already rejected with the given exception} {- [Lwt.wait : unit -> 'a Lwt.t * 'a Lwt.u] creates a pending promise, and returns it, paired with a resolver (of type ['a Lwt.u]), which must be used to resolve (fulfill or reject) the promise.}} To resolve a pending promise, use one of the following functions: {ul {- [Lwt.wakeup : 'a Lwt.u -> 'a -> unit] fulfills the promise with a value.} {- [Lwt.wakeup_exn : 'a Lwt.u -> exn -> unit] rejects the promise with an exception.}} Note that it is an error to try to resolve the same promise twice. [Lwt] will raise [Invalid_argument] if you try to do so. With this information, try to guess the result of each of the following expressions: {[ # Lwt.state (Lwt.return 42);; # Lwt.state (Lwt.fail Exit);; # let p, r = Lwt.wait ();; # Lwt.state p;; # Lwt.wakeup r 42;; # Lwt.state p;; # let p, r = Lwt.wait ();; # Lwt.state p;; # Lwt.wakeup_exn r Exit;; # Lwt.state p;; ]} {3 Primitives for promise composition } The most important operation you need to know is [bind]: {[ val bind : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t ]} [bind p f] creates a promise which waits for [p] to become become fulfilled, then passes the resulting value to [f]. If [p] is a pending promise, then [bind p f] will be a pending promise too, until [p] is resolved. If [p] is rejected, then the resulting promise will be rejected with the same exception. For example, consider the following expression: {[ Lwt.bind (Lwt_io.read_line Lwt_io.stdin) (fun str -> Lwt_io.printlf "You typed %S" str) ]} This code will first wait for the user to enter a line of text, then print a message on the standard output. Similarly to [bind], there is a function to handle the case when [p] is rejected: {[ val catch : (unit -> 'a Lwt.t) -> (exn -> 'a Lwt.t) -> 'a Lwt.t ]} [catch f g] will call [f ()], then wait for it to become resolved, and if it was rejected with an exception [exn], call [g exn] to handle it. Note that both exceptions raised with [Pervasives.raise] and [Lwt.fail] are caught by [catch]. {3 Cancelable promises } In some case, we may want to cancel a promise. For example, because it has not resolved after a timeout. This can be done with cancelable promises. To create a cancelable promise, you must use the [Lwt.task] function: {[ val task : unit -> 'a Lwt.t * 'a Lwt.u ]} It has the same semantics as [Lwt.wait], except that the pending promise can be canceled with [Lwt.cancel]: {[ val cancel : 'a Lwt.t -> unit ]} The promise will then be rejected with the exception [Lwt.Canceled]. To execute a function when the promise is canceled, you must use [Lwt.on_cancel]: {[ val on_cancel : 'a Lwt.t -> (unit -> unit) -> unit ]} Note that canceling a promise does not automatically cancel the asynchronous operation that is going to resolve it. It does, however, prevent any further chained operations from running. The asynchronous operation associated with a promise can only be canceled if its implementation has taken care to set an [on_cancel] callback on the promise that it returned to you. In practice, most operations (such as system calls) can't be canceled once they are started anyway, so promise cancellation is useful mainly for interrupting future operations once you know that a chain of asynchronous operations will not be needed. It is also possible to cancel a promise which has not been created directly by you with [Lwt.task]. In this case, the deepest cancelable promise that the given promise depends on will be canceled. For example, consider the following code: {[ # let p, r = Lwt.task ();; val p : '_a Lwt.t = val r : '_a Lwt.u = # let p' = Lwt.bind p (fun x -> Lwt.return (x + 1));; val p' : int Lwt.t = ]} Here, cancelling [p'] will in fact cancel [p], rejecting it with [Lwt.Canceled]. [Lwt.bind] will then propagate the exception forward to [p']: {[ # Lwt.cancel p';; - : unit = () # Lwt.state p;; - : int Lwt.state = Lwt.Fail Lwt.Canceled # Lwt.state p';; - : int Lwt.state = Lwt.Fail Lwt.Canceled ]} It is possible to prevent a promise from being canceled by using the function [Lwt.protected]: {[ val protected : 'a Lwt.t -> 'a Lwt.t ]} Canceling [(protected p)] will have no effect on [p]. {3 Primitives for concurrent composition } We now show how to compose several promises concurrently. The main functions for this are in the [Lwt] module: [join], [choose] and [pick]. The first one, [join] takes a list of promises and returns a promise that is waiting for all of them to resolve: {[ val join : unit Lwt.t list -> unit Lwt.t ]} Moreover, if at least one promise is rejected, [join l] will be rejected with the same exception as the first one, after all the promises are resolved. Conversely, [choose] waits for at least {e one} promise to become resolved, then resolves with the same value or exception: {[ val choose : 'a Lwt.t list -> 'a Lwt.t ]} For example: {[ # let p1, r1 = Lwt.wait ();; val p1 : '_a Lwt.t = val r1 : '_a Lwt.u = # let p2, r2 = Lwt.wait ();; val p2 : '_a Lwt.t = val r2 : '_a Lwt.u = # let p3 = Lwt.choose [p1; p2];; val p3 : '_a Lwt.t = # Lwt.state p3;; - : '_a Lwt.state = Lwt.Sleep # Lwt.wakeup r2 42;; - : unit = () # Lwt.state p3;; - : int Lwt.state = Lwt.Return 42 ]} The last one, [pick], is the same as [choose], except that it tries to cancel all other promises when one resolves. Promises created via [Lwt.wait()] are not cancellable and are thus not cancelled. {3 Rules } A callback, like the [f] that you might pass to [Lwt.bind], is an ordinary OCaml function. [Lwt] just handles ordering calls to these functions. [Lwt] uses some preemptive threading internally, but all of your code runs in the main thread, except when you explicitly opt into additional threads with [Lwt_preemptive]. This simplifies reasoning about critical sections: all the code in one callback cannot be interrupted by any of the code in another callback. However, it also carries the danger that if a single callback takes a very long time, it will not give [Lwt] a chance to run your other callbacks. In particular: {ul {- do not write functions that may take time to complete, without splitting them up using [Lwt.pause] or performing some [Lwt] I/O,} {- do not do I/O that may block, otherwise the whole program will hang inside that callback. You must instead use the asynchronous I/O operations provided by [Lwt].}} {2 The syntax extension } [Lwt] offers a PPX syntax extension which increases code readability and makes coding using [Lwt] easier. The syntax extension is documented in {!Ppx_lwt}. To use the PPX syntax extension, add the [lwt_ppx] package when compiling: {[ $ ocamlfind ocamlc -package lwt_ppx -linkpkg -o foo foo.ml ]} Or, in [utop]: {[ # #require "lwt_ppx";; ]} [lwt_ppx] is distributed in a separate opam package of that same name. For a brief overview of the syntax, see the Correspondence table below. {3 Correspondence table } {table {tr {th Without Lwt} {th With Lwt}} {tr {td {[let pattern_1 = expr_1 and pattern_2 = expr2 … and pattern_n = expr_n in expr]}} {td {[let%lwt pattern_1 = expr_1 and pattern_2 = expr2 … and pattern_n = expr_n in expr]}}} {tr {td {[try expr with | pattern_1 = expr_1 | pattern_2 = expr2 … | pattern_n = expr_n]}} {td {[try%lwt expr with | pattern_1 = expr_1 | pattern_2 = expr2 … | pattern_n = expr_n]}}} {tr {td {[match expr with | pattern_1 = expr_1 | pattern_2 = expr2 … | pattern_n = expr_n]}} {td {[match%lwt expr with | pattern_1 = expr_1 | pattern_2 = expr2 … | pattern_n = expr_n]}}} {tr {td {[for ident = expr_init to expr_final do expr done]}} {td {[for%lwt ident = expr_init to expr_final do expr done]}}} {tr {td {[while expr do expr done]}} {td {[while%lwt expr do expr done]}}} {tr {td {[if expr then expr else expr]}} {td {[if%lwt expr then expr else expr]}}} {tr {td {[assert expr]}} {td {[assert%lwt expr]}}} {tr {td {[raise exn]}} {td {[[%lwt raise exn]]}}}} {2 Backtrace support } If an exception is raised inside a callback called by Lwt, the backtrace provided by OCaml will not be very useful. It will end inside the Lwt scheduler instead of continuing into the code that started the operations that led to the callback call. To avoid this, and get good backtraces from Lwt, use the syntax extension. The [let%lwt] construct will properly propagate backtraces. As always, to get backtraces from an OCaml program, you need to either declare the environment variable [OCAMLRUNPARAM=b] or call [Printexc.record_backtrace true] at the start of your program, and be sure to compile it with [-g]. Most modern build systems add [-g] by default. {2 [let*] syntax } To use Lwt with the [let*] syntax introduced in OCaml 4.08, you can open the [Syntax] module: {[ open Syntax ]} Then, you can write {[ let* () = Lwt_io.printl "Hello," in let* () = Lwt_io.printl "world!" in Lwt.return () ]} {2 Other modules of the core library } The core library contains several modules that only depend on [Lwt]. The following naming convention is used in [Lwt]: when a function takes as argument a function, returning a promise, that is going to be executed sequentially, it is suffixed with “[_s]”. And when it is going to be executed concurrently, it is suffixed with “[_p]”. For example, in the [Lwt_list] module we have: {[ val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t ]} {3 Mutexes } [Lwt_mutex] provides mutexes for [Lwt]. Its use is almost the same as the [Mutex] module of the thread library shipped with OCaml. In general, programs using [Lwt] do not need a lot of mutexes, because callbacks run without preempting each other. They are only useful for synchronising or sequencing complex operations spread over multiple callback calls. {3 Lists } The [Lwt_list] module defines iteration and scanning functions over lists, similar to the ones of the [List] module, but using functions that return a promise. For example: {[ val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t ]} In [iter_s f l], [iter_s] will call f on each elements of [l], waiting for resolution between each element. On the contrary, in [iter_p f l], [iter_p] will call f on all elements of [l], only then wait for all the promises to resolve. {3 Data streams } [Lwt] streams are used in a lot of places in [Lwt] and its submodules. They offer a high-level interface to manipulate data flows. A stream is an object which returns elements sequentially and lazily. Lazily means that the source of the stream is touched only for new elements when needed. This module contains a lot of stream transformation, iteration, and scanning functions. The common way of creating a stream is by using [Lwt_stream.from] or by using [Lwt_stream.create]: {[ val from : (unit -> 'a option Lwt.t) -> 'a Lwt_stream.t val create : unit -> 'a Lwt_stream.t * ('a option -> unit) ]} As for streams of the standard library, [from] takes as argument a function which is used to create new elements. [create] returns a function used to push new elements into the stream and the stream which will receive them. For example: {[ # let stream, push = Lwt_stream.create ();; val stream : '_a Lwt_stream.t = val push : '_a option -> unit = # push (Some 1);; - : unit = () # push (Some 2);; - : unit = () # push (Some 3);; - : unit = () # Lwt.state (Lwt_stream.next stream);; - : int Lwt.state = Lwt.Return 1 # Lwt.state (Lwt_stream.next stream);; - : int Lwt.state = Lwt.Return 2 # Lwt.state (Lwt_stream.next stream);; - : int Lwt.state = Lwt.Return 3 # Lwt.state (Lwt_stream.next stream);; - : int Lwt.state = Lwt.Sleep ]} Note that streams are consumable. Once you take an element from a stream, it is removed from the stream. So, if you want to iterate two times over a stream, you may consider “cloning” it, with [Lwt_stream.clone]. Cloned stream will return the same elements in the same order. Consuming one will not consume the other. For example: {[ # let s = Lwt_stream.of_list [1; 2];; val s : int Lwt_stream.t = # let s' = Lwt_stream.clone s;; val s' : int Lwt_stream.t = # Lwt.state (Lwt_stream.next s);; - : int Lwt.state = Lwt.Return 1 # Lwt.state (Lwt_stream.next s);; - : int Lwt.state = Lwt.Return 2 # Lwt.state (Lwt_stream.next s');; - : int Lwt.state = Lwt.Return 1 # Lwt.state (Lwt_stream.next s');; - : int Lwt.state = Lwt.Return 2 ]} {3 Mailbox variables } The [Lwt_mvar] module provides mailbox variables. A mailbox variable, also called a “mvar”, is a cell which may contain 0 or 1 element. If it contains no elements, we say that the mvar is empty, if it contains one, we say that it is full. Adding an element to a full mvar will block until one is taken. Taking an element from an empty mvar will block until one is added. Mailbox variables are commonly used to pass messages between chains of callbacks being executed concurrently. Note that a mailbox variable can be seen as a pushable stream with a limited memory. {1 Running an Lwt program } An [Lwt] computation you have created will give you something of type [Lwt.t], a promise. However, even though you have the promise, the computation may not have run yet, and the promise might still be pending. For example if your program is just: {[ let _ = Lwt_io.printl "Hello, world!" ]} you have no guarantee that the promise for writing ["Hello, world!"] on the terminal will be resolved before the program exits. In order to wait for the promise to resolve, you have to call the function [Lwt_main.run]: {[ val Lwt_main.run : 'a Lwt.t -> 'a ]} This function waits for the given promise to resolve and returns its result. In fact it does more than that; it also runs the scheduler which is responsible for making asynchronous computations progress when events are received from the outside world. So basically, when you write a [Lwt] program, you must call [Lwt_main.run] on your top-level, outer-most promise. For instance: {[ let () = Lwt_main.run (Lwt_io.printl "Hello, world!") ]} Note that you must not make nested calls to [Lwt_main.run]. It cannot be used anywhere else to get the result of a promise. {1 The [lwt.unix] library } The package [lwt.unix] contains all [Unix]-dependent modules of [Lwt]. Among all its features, it implements Lwt-friendly, non-blocking versions of functions of the OCaml standard and Unix libraries. {2 Unix primitives } Module [Lwt_unix] provides non-blocking system calls. For example, the [Lwt] counterpart of [Unix.read] is: {[ val read : file_descr -> string -> int -> int -> int Lwt.t ]} [Lwt_io] provides features similar to buffered channels of the standard library (of type [in_channel] or [out_channel]), but with non-blocking semantics. [Lwt_gc] allows you to register a finalizer that returns a promise. At the end of the program, [Lwt] will wait for all these finalizers to resolve. {2 The Lwt scheduler } Operations doing I/O have to be resumed when some events are received by the process, so they can resolve their associated pending promises. For example, when you read from a file descriptor, you may have to wait for the file descriptor to become readable if no data are immediately available on it. [Lwt] contains a scheduler which is responsible for managing multiple operations waiting for events, and restarting them when needed. This scheduler is implemented by the two modules [Lwt_engine] and [Lwt_main]. [Lwt_engine] is a low-level module, it provides a signature for custom I/O multiplexers as well as two built-in implementations, [libev] and [select]. The signature is given by the class [Lwt_engine.t]. [libev] is used by default on Linux, because it supports any number of file descriptors, while [select] supports only 1024. [libev] is also much more efficient. On Windows, [Unix.select] is used because [libev] does not work properly. The user may change the backend in use at any time. If you see an [Invalid_argument] error on [Unix.select], it may be because the 1024 file descriptor limit was exceeded. Try switching to [libev], if possible. The engine can also be used directly in order to integrate other libraries with [Lwt]. For example, [GTK] needs to be notified when some events are received. If you use [Lwt] with [GTK] you need to use the [Lwt] scheduler to monitor [GTK] sources. This is what is done by the [Lwt_glib] library. The [Lwt_main] module contains the {e main loop} of [Lwt]. It is run by calling the function [Lwt_main.run]: {[ val Lwt_main.run : 'a Lwt.t -> 'a ]} This function continuously runs the scheduler until the promise passed as argument is resolved. To make sure [Lwt] is compiled with [libev] support, tell opam that the library is available on the system by installing the {{: https://opam.ocaml.org/packages/conf-libev/conf-libev.4-11/ }conf-libev} package. You may get the actual library with your system package manager: {ul {- [brew install libev] on MacOSX,} {- [apt-get install libev-dev] on Debian/Ubuntu, or} {- [yum install libev-devel] on CentOS, which requires to set [export C_INCLUDE_PATH=/usr/include/libev/] and [export LIBRARY_PATH=/usr/lib64/] before calling [opam install conf-libev].}} {2 Logging } For logging, we recommend the [logs] package from opam, which includes an Lwt-aware module [Logs_lwt]. {1 The Lwt.react library } The [Lwt_react] module provides helpers for using the [react] library with [Lwt]. It extends the [React] module by adding [Lwt]-specific functions. It can be used as a replacement of [React]. For example you can add at the beginning of your program: {[ open Lwt_react ]} instead of: {[ open React ]} or: {[ module React = Lwt_react ]} Among the added functionalities we have [Lwt_react.E.next], which takes an event and returns a promise which will be pending until the next occurrence of this event. For example: {[ # open Lwt_react;; # let event, push = E.create ();; val event : '_a React.event = val push : '_a -> unit = # let p = E.next event;; val p : '_a Lwt.t = # Lwt.state p;; - : '_a Lwt.state = Lwt.Sleep # push 42;; - : unit = () # Lwt.state p;; - : int Lwt.state = Lwt.Return 42 ]} Another interesting feature is the ability to limit events (resp. signals) from occurring (resp. changing) too often. For example, suppose you are doing a program which displays something on the screen each time a signal changes. If at some point the signal changes 1000 times per second, you probably don't want to render it 1000 times per second. For that you use [Lwt_react.S.limit]: {[ val limit : (unit -> unit Lwt.t) -> 'a React.signal -> 'a React.signal ]} [Lwt_react.S.limit f signal] returns a signal which varies as [signal] except that two consecutive updates are separated by a call to [f]. For example if [f] returns a promise which is pending for 0.1 seconds, then there will be no more than 10 changes per second: {[ open Lwt_react let draw x = (* Draw the screen *) … let () = (* The signal we are interested in: *) let signal = … in (* The limited signal: *) let signal' = S.limit (fun () -> Lwt_unix.sleep 0.1) signal in (* Redraw the screen each time the limited signal change: *) S.notify_p draw signal' ]} {1 Other libraries } {2 Parallelise computations to other cores } If you have some compute-intensive steps within your program, you can execute them on a separate core. You can get performance benefits from the parallelisation. In addition, whilst your compute-intensive function is running on a different core, your normal I/O-bound tasks continue running on the original core. The module {!Lwt_domain} from the [lwt_domain] package provides all the necessary helpers to achieve this. It is based on the [Domainslib] library and uses similar concepts (such as tasks and pools). First, you need to create a task pool: {[ val setup_pool : ?name:string -> int -> pool ]} Then you simple detach the function calls to the created pool: {[ val detach : pool -> ('a -> 'b) -> 'a -> 'b Lwt.t ]} The returned promise resolves as soon as the function returns. {2 Detaching computation to preemptive threads } It may happen that you want to run a function which will take time to compute or that you want to use a blocking function that cannot be used in a non-blocking way. For these situations, [Lwt] allows you to {e detach} the computation to a preemptive thread. This is done by the module [Lwt_preemptive] of the [lwt.unix] package which maintains a pool of system threads. The main function is: {[ val detach : ('a -> 'b) -> 'a -> 'b Lwt.t ]} [detach f x] will execute [f x] in another thread and return a pending promise, usable from the main thread, which will be fulfilled with the result of the preemptive thread. If you want to trigger some [Lwt] operations from your detached thread, you have to call back into the main thread using [Lwt_preemptive.run_in_main]: {[ val run_in_main : (unit -> 'a Lwt.t) -> 'a ]} This is roughly the equivalent of [Lwt.main_run], but for detached threads, rather than for the whole process. Note that you must not call [Lwt_main.run] in a detached thread. {2 SSL support } The library [Lwt_ssl] allows use of SSL asynchronously. {1 Writing stubs using [Lwt] } {2 Thread-safe notifications } If you want to notify the main thread from another thread, you can use the [Lwt] thread safe notification system. First you need to create a notification identifier (which is just an integer) from the OCaml side using the [Lwt_unix.make_notification] function, then you can send it from either the OCaml code with [Lwt_unix.send_notification] function, or from the C code using the function [lwt_unix_send_notification] (defined in [lwt_unix_.h]). Notifications are received and processed asynchronously by the main thread. {2 Jobs } For operations that cannot be executed asynchronously, [Lwt] uses a system of jobs that can be executed in a different threads. A job is composed of three functions: {ul {- A stub function to create the job. It must allocate a new job structure and fill its [worker] and [result] fields. This function is executed in the main thread. The return type for the OCaml external must be of the form ['a job].} {- A function which executes the job. This one may be executed asynchronously in another thread. This function must not: {ul {- access or allocate OCaml block values (tuples, strings, …),} {- call OCaml code.}}} {- A function which reads the result of the job, frees resources and returns the result as an OCaml value. This function is executed in the main thread.}} With [Lwt < 2.3.3], 4 functions (including 3 stubs) were required. It is still possible to use this mode but it is deprecated. We show as example the implementation of [Lwt_unix.mkdir]. On the C side we have: {@c[/**/ /* Structure holding informations for calling [mkdir]. */ struct job_mkdir { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* Pointer to a copy of the path parameter. */ char* path; /* Copy of the mode parameter. */ int mode; /* Buffer for storing the path. */ char data[]; }; /* The function calling [mkdir]. */ static void worker_mkdir(struct job_mkdir* job) { /* Perform the blocking call. */ job->result = mkdir(job->path, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_mkdir(struct job_mkdir* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "mkdir", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_mkdir_job(value path, value mode) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_mkdir* job = (struct job_mkdir*)lwt_unix_new_plus(struct job_mkdir, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initialize function fields. */ job->job.worker = (lwt_unix_job_worker)worker_mkdir; job->job.result = (lwt_unix_job_result)result_mkdir; /* Copy the mode parameter. */ job->mode = Int_val(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } ]} and on the ocaml side: {[ (* The stub for creating the job. *) external mkdir_job : string -> int -> unit job = "lwt_unix_mkdir_job" (* The ocaml function. *) let mkdir name perms = Lwt_unix.run_job (mkdir_job name perms) ]} lwt-5.9.1/docs/menu.wiki000066400000000000000000000000331476253734400151300ustar00rootroot00000000000000= Lwt ==[[manual|Overview]]lwt-5.9.1/dune-project000066400000000000000000000031771476253734400147050ustar00rootroot00000000000000(lang dune 2.7) (name lwt) (generate_opam_files true) (maintainers "Raphaël Proust " "Anton Bachin ") (authors "Jérôme Vouillon" "Jérémie Dimino") (license MIT) (source (github ocsigen/lwt)) (documentation "https://ocsigen.org/lwt") (package (name lwt_retry) (synopsis "Utilities for retrying Lwt computations") (authors "Shon Feder") (maintainers "Raphaël Proust " "Shon Feder ") (depends (ocaml (>= 4.08)) (lwt (>= 5.3.0)))) (package (name lwt_ppx) (version 5.9.1) (synopsis "PPX syntax for Lwt, providing something similar to async/await from JavaScript") (depends (ocaml (>= 4.08)) (ppxlib (and (>= 0.16.0) (< 0.36))) (ppx_let :with-test) lwt)) (package (name lwt_react) (synopsis "Helpers for using React with Lwt") (depends (ocaml (>= 4.08)) (cppo (and :build (>= 1.1.0))) (lwt (>= 3.0.0)) (react (>= 1.0.0)))) (package (name lwt) (version 5.9.1) (synopsis "Promises and event-driven I/O") (description "A promise is a value that may become determined in the future. Lwt provides typed, composable promises. Promises that are resolved by I/O are resolved by Lwt in parallel. Meanwhile, OCaml code, including code creating and waiting on promises, runs in a single thread by default. This reduces the need for locks or other synchronization primitives. Code can be run in parallel on an opt-in basis. ") (depends (ocaml (>= 4.08)) (cppo (and :build (>= 1.1.0))) (ocamlfind (and :dev (>= 1.7.3-1))) (odoc (and :with-doc (>= 2.3.0))) dune-configurator ocplib-endian) (depopts base-threads base-unix conf-libev)) lwt-5.9.1/esy.json000066400000000000000000000004361476253734400140510ustar00rootroot00000000000000{ "name": "lwt-esy-test", "source": "./lwt.opam", "override": { "dependencies": { "ocaml": "~4.9.0", "@opam/conf-libev": "*", "@opam/bisect_ppx": "*" }, "resolutions": { "@opam/conf-libev": "esy-packages/libev:package.json#0b5eb66" } } } lwt-5.9.1/lwt.opam000066400000000000000000000026551476253734400140470ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "5.9.1" synopsis: "Promises and event-driven I/O" description: """ A promise is a value that may become determined in the future. Lwt provides typed, composable promises. Promises that are resolved by I/O are resolved by Lwt in parallel. Meanwhile, OCaml code, including code creating and waiting on promises, runs in a single thread by default. This reduces the need for locks or other synchronization primitives. Code can be run in parallel on an opt-in basis. """ maintainer: [ "Raphaël Proust " "Anton Bachin " ] authors: ["Jérôme Vouillon" "Jérémie Dimino"] license: "MIT" homepage: "https://github.com/ocsigen/lwt" doc: "https://ocsigen.org/lwt" bug-reports: "https://github.com/ocsigen/lwt/issues" depends: [ "dune" {>= "2.7"} "ocaml" {>= "4.08"} "cppo" {build & >= "1.1.0"} "ocamlfind" {dev & >= "1.7.3-1"} "odoc" {with-doc & >= "2.3.0"} "dune-configurator" "ocplib-endian" ] depopts: ["base-threads" "base-unix" "conf-libev"] dev-repo: "git+https://github.com/ocsigen/lwt.git" build: [ ["dune" "subst"] {dev} [ "dune" "exec" "-p" name "src/unix/config/discover.exe" "--" "--save" "--use-libev" "%{conf-libev:installed}%" ] [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] lwt-5.9.1/lwt.opam.template000066400000000000000000000004751476253734400156570ustar00rootroot00000000000000build: [ ["dune" "subst"] {dev} [ "dune" "exec" "-p" name "src/unix/config/discover.exe" "--" "--save" "--use-libev" "%{conf-libev:installed}%" ] [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] lwt-5.9.1/lwt_ppx.opam000066400000000000000000000015021476253734400147240ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "5.9.1" synopsis: "PPX syntax for Lwt, providing something similar to async/await from JavaScript" maintainer: [ "Raphaël Proust " "Anton Bachin " ] authors: ["Jérôme Vouillon" "Jérémie Dimino"] license: "MIT" homepage: "https://github.com/ocsigen/lwt" doc: "https://ocsigen.org/lwt" bug-reports: "https://github.com/ocsigen/lwt/issues" depends: [ "dune" {>= "2.7"} "ocaml" {>= "4.08"} "ppxlib" {>= "0.16.0" & < "0.36"} "ppx_let" {with-test} "lwt" "odoc" {with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/ocsigen/lwt.git" lwt-5.9.1/lwt_react.opam000066400000000000000000000014071476253734400152170ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Helpers for using React with Lwt" maintainer: [ "Raphaël Proust " "Anton Bachin " ] authors: ["Jérôme Vouillon" "Jérémie Dimino"] license: "MIT" homepage: "https://github.com/ocsigen/lwt" doc: "https://ocsigen.org/lwt" bug-reports: "https://github.com/ocsigen/lwt/issues" depends: [ "dune" {>= "2.7"} "ocaml" {>= "4.08"} "cppo" {build & >= "1.1.0"} "lwt" {>= "3.0.0"} "react" {>= "1.0.0"} "odoc" {with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/ocsigen/lwt.git" lwt-5.9.1/lwt_retry.opam000066400000000000000000000012751476253734400152710ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Utilities for retrying Lwt computations" maintainer: [ "Raphaël Proust " "Shon Feder " ] authors: ["Shon Feder"] license: "MIT" homepage: "https://github.com/ocsigen/lwt" doc: "https://ocsigen.org/lwt" bug-reports: "https://github.com/ocsigen/lwt/issues" depends: [ "dune" {>= "2.7"} "ocaml" {>= "4.08"} "lwt" {>= "5.3.0"} "odoc" {with-doc} ] dev-repo: "git+https://github.com/ocsigen/lwt.git" build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] lwt-5.9.1/lwt_retry.opam.template000066400000000000000000000002501476253734400170730ustar00rootroot00000000000000build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] lwt-5.9.1/src/000077500000000000000000000000001476253734400131425ustar00rootroot00000000000000lwt-5.9.1/src/core/000077500000000000000000000000001476253734400140725ustar00rootroot00000000000000lwt-5.9.1/src/core/dune000066400000000000000000000006011476253734400147450ustar00rootroot00000000000000(* -*- tuareg -*- *) let preprocess = match Sys.getenv "BISECT_ENABLE" with | "yes" -> "(preprocess (pps bisect_ppx))" | _ -> "" | exception _ -> "" let () = Jbuild_plugin.V1.send @@ {| (library (public_name lwt) (synopsis "Monadic promises and concurrent I/O") (wrapped false) |} ^ preprocess ^ {| (flags (:standard -w +A-29))) (documentation (package lwt)) |} lwt-5.9.1/src/core/index.mld000066400000000000000000000075171476253734400157110ustar00rootroot00000000000000{0 Lwt} {1 Introduction} Lwt is a concurrent programming library for OCaml. It provides a single data type: the {e promise}, which is a value that will become determined in the future. Creating a promise spawns a computation. When that computation is I/O, Lwt runs it in parallel with your OCaml code. OCaml code, including creating and waiting on promises, is run in a single thread by default, so you don't have to worry about locking or preemption. You can detach code to be run in separate threads on an opt-in basis. Here is a simplistic Lwt program which requests the Google front page, and fails if the request is not completed in five seconds: {[ open Lwt.Syntax let () = let request = let* addresses = Lwt_unix.getaddrinfo "google.com" "80" [] in let google = Lwt_unix.((List.hd addresses).ai_addr) in Lwt_io.(with_connection google (fun (incoming, outgoing) -> let* () = write outgoing "GET / HTTP/1.1\r\n" in let* () = write outgoing "Connection: close\r\n\r\n" in let* response = read incoming in Lwt.return (Some response))) in let timeout = let* () = Lwt_unix.sleep 5. in Lwt.return None in match Lwt_main.run (Lwt.pick [request; timeout]) with | Some response -> print_string response | None -> prerr_endline "Request timed out"; exit 1 (* ocamlfind opt -package lwt.unix -linkpkg example.ml && ./a.out *) ]} In the program, functions such as [Lwt_io.write] create promises. The [let%lwt ... in] construct is used to wait for a promise to become determined; the code after [in] is scheduled to run in a "callback." [Lwt.pick] races promises against each other, and behaves as the first one to complete. [Lwt_main.run] forces the whole promise-computation network to be executed. All the visible OCaml code is run in a single thread, but Lwt internally uses a combination of worker threads and non-blocking file descriptors to resolve in parallel the promises that do I/O. {1 Tour} Lwt compiles to native code on Linux, macOS, Windows, and other systems. It's also routinely compiled to JavaScript for the front end and Node by js_of_ocaml. In Lwt, - The core library {!Lwt} provides promises... - ...and a few pure-OCaml helpers, such as promise-friendly {{!Lwt_mutex} mutexes}, {{!Lwt_condition} condition variables}, and {{!Lwt_mvar} mvars}. - There is a big Unix binding, {!Lwt_unix}, that binds almost every Unix system call. A higher-level module {!Lwt_io} provides nice I/O channels. - {!Lwt_process} is for subprocess handling. - {!Lwt_preemptive} spawns system threads. {1 Installing} + Use your system package manager to install a development libev package. It is often called [libev-dev] or [libev-devel]. + [opam install conf-libev lwt] {1 Additional Docs} - {{!page-manual} Manual} ({{:https://ocsigen.org/lwt/} Online manual}). - {{:https://github.com/dkim/rwo-lwt#readme} Concurrent Programming with Lwt} is a nice source of Lwt examples. They are translations of code from Real World OCaml, but are just as useful if you are not reading the book. - {{:https://mirage.io/docs/tutorial-lwt} Mirage Lwt tutorial}. - {{:https://baturin.org/code/lwt-counter-server/} Example server} written with Lwt. {1 API: Library [lwt]} This is the system-independent, pure-OCaml core of Lwt. To link with it, use [(libraries lwt)] in your [dune] file. {!modules: Lwt Lwt_list Lwt_stream Lwt_result Lwt_mutex Lwt_condition Lwt_mvar Lwt_switch Lwt_pool } {1 API: Library [lwt.unix]} This is the system call and I/O library. Despite its name, it is implemented on both Unix-like systems and Windows, although not all functions are available on Windows. To link with this library, use [(libraries lwt.unix)] in your [dune] file. {!modules: Lwt_unix Lwt_main Lwt_io Lwt_process Lwt_bytes Lwt_preemptive Lwt_fmt Lwt_throttle Lwt_timeout Lwt_engine Lwt_gc Lwt_sys } lwt-5.9.1/src/core/lwt.ml000066400000000000000000003331471476253734400152450ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* Reading guide Welcome to the implementation of the Lwt core! This is a big file, but we hope that reading it (parts at a time!) will not be scary :) Here is why: * Sectioning The code is broken up into sections, each one of which is an internal module. Most of the modules have a signature, which serves as a neat table of contents. It is recommended that you read this file with code folding enabled. If you fold all the modules, you can visualize the logical structure of Lwt quite easily. You can then expand modules as needed, depending on what part of the implementation you are interested in. Without code folding, you face an intimidating wall of code :( You can still visually parse the file, however, because there are plenty of blank lines to help section things off. You can also view this file folded online: https://gist.github.com/aantron/9fab0bdead98a60fccf06e0189186863 https://gist.github.com/aantron/97b58520d5bb4858ccac6f54700a24d7 The signatures are unusual: big comments are absent. They are moved into the modules, so that they are hidden by code folding when you (the reader!) are not interested in those modules. * Documentation The documentation begins with an overview of major concepts and components. This overview puts everything into context. You don't have to read the whole thing. The overview begins with basic concepts, moves on to advanced ones, and then gets into the truly esoteric. You can read about each concept on an as-needed basis. However, once you have read the whole overview, you will be aware of *everything* that is needed to understand, and work with, the core of Lwt. Littered in the code are additional comments, that go in-depth on various local implementation details, opportunities, regrets, and the like. The sections (modules) of the code correspond closely to sections of the overview. * Whitespace The total line count of this file may seem frightening, but one third of it is whitespace and comments, both there to help you read the remaining two thirds! Also, within those two thirds, there are large groups of functions that are repetitive and formulaic, so there is much less conceptually-unique code in Lwt than you might think at first. * Please edit the code and the docs! This code is meant to be readable, and to be edited. If you are reading something, and think there is a better way to express it, please go ahead and open a pull request to the Lwt repository at https://github.com/ocsigen/lwt Even if your pull request somehow doesn't get merged, you will have educated the maintainers, not to mention other contributors, and users. This is true even if the change is trivial -- sometimes, maintainers just need to be educated multiple times before they see the wisdom of it :/ Likewise, if you would like to make a code contribution to the Lwt core, it is quite welcome, and we hope that this code is readable enough for you to be able to make it! Enjoy! *) (* Overview In this file, there is a "model" function -- [Lwt.bind] -- which pulls together many (though not all) of the concepts and helpers discussed in this overview. To find it, search for "let bind," and you can examine it while reading the overview. The authors of this file intend to put extra effort into writing nice comments inside [Lwt.bind] :) 0. Main mechanism and two aspects The Lwt interface ([lwt.mli]) provides one main mechanism, promises, and two "aspects," which are *not* necessary to understand the main mechanism promises, but they are still there: - promise cancellation - sequence-associated storage If you are not interested in cancellation or storage, you can ignore these two complications, and still get a pretty good understanding of the code. To help, all identifiers related to cancellation contain the string "cancel," and all identifiers related to storage contain "storage." 1. Promises A promise is a cell that can be in one of two states: "resolved" or "pending." - Resolved promises A resolved promise is either "fulfilled" with a value, or "rejected" with an exception. The state of a resolved promise will never change again: a resolved promise is immutable. A resolved promise is basically equivalent to an [('a, exn) Stdlib.result]. Resolved promises are produced in two ways: - [Lwt.return], [Lwt.fail], and related functions, produce "trivial" promises that are resolved from the start. - The other way is to resolve a promise that started out pending. Note that rejected promises have nothing to do with unhandled exceptions. - Pending promises ...are those that may become resolved in the future. Each pending promise carries a list of callbacks. These callbacks are added by functions like [Lwt.bind], and called by Lwt if/when the promise is resolved. These callbacks typically end up resolving additional promises; see section "Resolution loop" below. Pending promises are produced in three ways, according to how they can be resolved: - Initial promises ...are created by [Lwt.wait] and [Lwt.task]. The user of Lwt resolves these promises manually, through the resolvers returned by those functions. - Sequential composition For example, [Lwt.bind]. These promises only are only resolved when the preceding sequence of promises resolves. The user cannot resolve these promises directly (but see the section on cancellation below). - Concurrent composition For example, [Lwt.join] or [Lwt.choose]. These promises are only resolved when all or one of a set of "preceding" promises resolve. The user cannot resolve these promises directly (but see the section on cancellation below). 2. Resolvers Resolvers are given to the user by [Lwt.wait] and [Lwt.task], and can be used by the user to resolve the corresponding promises. Note that this means the user only ever gets resolvers for initial promises. Internally, resolvers are the exact same objects as the promises they resolve, even though the resolver is exposed as a reference of a different type by [lwt.mli]. For details on why, see section "Type system abuse" below. 3. Callbacks ...are attached by Lwt to pending promises, and are run by Lwt if/when those promises are resolved. These callbacks are not directly exposed through [lwt.mli] -- they are a low-level mechanism. For example, to implement [Lwt.bind p f], Lwt attaches a callback to [p] that does some internal Lwt book-keeping, and then calls [f] if [p] is fulfilled, and does something else if [p] is rejected. Callbacks come in two flavors: regular callbacks and cancel callbacks. The only material differences between them are that: - regular callbacks are always called when a promise is resolved, but cancel callbacks are called, in addition, only if the promise is canceled, and - all cancel callbacks of a promise are called before any regular callback is called. Cancellation is a special case of resolution, in particular, a special case of rejection, but see the section on cancellation later below. 4. Resolution loop Resolving a pending promise triggers its callbacks, and those might resolve more pending promises, triggering more callbacks, etc. This behavior is the *resolution loop*. Lwt has some machinery to avoid stack overflow and other unfortunate situations during this loop. This chaining of promise resolutions through callbacks can be seen as a kind of promise dependency graph, in which the nodes are pending promises, and the edges are callbacks. During the resolution loop, Lwt starts at some initial promise that is getting resolved by the user, and recursively resolves all dependent promises. The graph is modified: resolved promises are no longer pending, so they are no longer part of the graph. Some of these dependencies are explicit to Lwt, e.g. the callbacks registered by [Lwt.bind]. Others are not visible to Lwt, because the user can always register a callback using a function like [Lwt.on_success], and use that callback to resolve another initial promise. All the explicit dependencies are created by Lwt's own sequential and concurrent composition functions (so, [Lwt.bind], [Lwt.join], etc). Whether dependencies are explicit or not is relevant only to cancellation. 5. Cancellation As described above, ordinary promise resolution proceeds from an initial promise, forward along callbacks through the dependency graph. Since it starts from an initial promise, it can only be triggered using a resolver. Cancellation is a sort of dual to ordinary resolution. Instead of starting at an initial promise/resolver, cancellation starts at *any* promise. It then goes *backwards* through the explicit dependency graph, looking for cancelable initial promises to cancel -- those that were created by [Lwt.task]. After finding them, cancellation resolves them normally with [Rejected Lwt.Canceled], causing an ordinary promise resolution process. To summarize, cancellation is a way to trigger an *ordinary* resolution of promises created with [Lwt.task], by first searching for them in the promise dependency graph (which is assembled by [Lwt.bind], [Lwt.join], etc). This backwards search is triggered only by [Lwt.cancel]. It is also possible for the user to cancel a promise directly by rejecting it with [Lwt.Canceled], but in all cases where the user can do so, the search would be redundant anyway -- the user has only two ways of directly rejecting a promise with [Lwt.Canceled] (or any exception, for that matter): - The user can create an initial promise, then reject it through its resolver. The search is redundant because it would find only the same initial promise to cancel. - The user can create a trivial promise by calling [Lwt.fail Lwt.Canceled]. The search is again redundant; in this case it would find nothing to cancel. Note that there is a quirk: only promises created by [Lwt.task] are susceptible to being canceled by [Lwt.cancel], but the user can manually cancel initial promises created by both [Lwt.task] and [Lwt.wait]. Due to [Lwt.cancel], promise cancellation, and therefore resolution, can be initiated by the user without access to a resolver. This is important for reasoning about state changes in the implementation of Lwt, and is referenced in some implementation detail comments. 6. No I/O The Lwt core deliberately doesn't do I/O. The resolution loop stops running once no promises can be resolved immediately. It has to be restarted later by some surrounding I/O loop. This I/O loop typically keeps track of pending promises that represent blocked or in-progress I/O; other pending promises that indirectly depend on I/O are not explicitly tracked. They are retained in memory by references captured inside callbacks. On Unix and Windows, a separate top-level loop, typically [Lwt_main.run], is necessary to repeatedly call [select], [epoll], or [kevent], and resolve blocked I/O promises. In JavaScript, references to promises are retained by JavaScript code, which is, in turn, triggered by the JS engine. In other words, the top-level loop is buried inside the JS engine. This separation of the Lwt core from the top-level I/O loop keeps the core portable. 7. Promise "proxying" In [Lwt.bind : 'a t -> ('a -> 'b t) -> 'b t], the outer ['b t] is created by [bind] first, and returned to the user. The inner ['b t] is created by the user later, and then returned to [bind]. At that point, [bind] needs to make the inner and outer ['b t]s behave identically. This is accomplished by making one of the promises point to the other. The first of the promises thus becomes a "proxy," and the other is its "underlying" promise. After that, all operations that would be performed by Lwt on the proxy are instead performed on the underlying promise. This is ensured by the numerous calls to the internal function [underlying] in this file. Because of the pervasive use of [underlying], proxies can be more or less ignored on a first reading the code. However, becoming a proxy is a kind of state change, and any promise that is returned by a callback to [bind], or to a similar Lwt function, might become a proxy. That means: just about any promise that is handed to the user, might become a proxy promise by the next time Lwt sees it. This is important for reasoning about possible state changes in implementation of Lwt, and is referenced in some implementation detail comments. 8. Sequence-associated storage Lwt has a global key-value map. The map can be preserved across sequential composition functions, so that it has the same state in the user's callback [f] as it did at the time the user called [Lwt.bind p f]. The details are pretty straightforward, and discussed in module [Sequence_associated_storage]. The main thing to be aware of is the many references to [current_storage] throughout Lwt, which are needed to properly save and restore the mapping. 9. Type system abuse The implementation uses the type system somewhat extensively. Gentle introductions can be found here: https://discuss.ocaml.org/t/161/7 https://discuss.ocaml.org/t/161/16 A short summary follows. The promise state is, internally, a GADT which encodes the state in its type parameters. Thus, if you do [let p = underlying p], the shadowing reference [p] is statically known *not* to be a proxy, and the compiler knows that the corresponding match case [Proxy _] is impossible. The external promise type, ['a t], and the external resolver type, ['a u], are not GADTs. Furthermore, they are, respectively, covariant and contravariant in ['a], while the internal promise type is invariant in ['a]. For these reasons, there are nasty casts between ['a t], ['a u], and the internal promise type. The implementation is, of course, written in terms of the internal type. Casting from an ['a t] to an internal promise produces a reference for which the state is "unknown": this is simulated with a helper GADT, which encodes existential types. There are several similar casts, which are used to document possible state changes between the time a promise is created, and the later time it is used in a callback. You can see these casts in action in [Lwt.bind]. The cast syntax is pretty light, and, besides being commented in [bind], all such casts are documented in modules [Public_types] and [Basic_helpers]. If you've made it this far, you are an Lwt expert! Rejoice! *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] (* Some sequence-associated storage types Sequence-associated storage is defined and documented later, in module [Sequence_associated_storage]. However, the following types are mentioned in the definition of [promise], so they must be defined here first. *) module Storage_map = Map.Make (struct type t = int let compare = compare end) type storage = (unit -> unit) Storage_map.t module Main_internal_types = struct (* Phantom types for use with types [promise] and [state]. These are never constructed; the purpose of the constructors is to prove to the type checker that these types are distinct from each other. Warning 37, "unused constructor," therefore has to be temporarily suppressed. *) [@@@ocaml.warning "-37"] type underlying = private Underlying_and_this_constructor_is_not_used type proxy = private Proxy_and_this_constructor_is_not_used type resolved = private Resolved_and_this_constructor_is_not_used type pending = private Pending_and_this_constructor_is_not_used [@@@ocaml.warning "+37"] (* Promises proper. *) type ('a, 'u, 'c) promise = { mutable state : ('a, 'u, 'c) state; } and (_, _, _) state = | Fulfilled : 'a -> ('a, underlying, resolved) state | Rejected : exn -> ( _, underlying, resolved) state | Pending : 'a callbacks -> ('a, underlying, pending) state | Proxy : ('a, _, 'c) promise -> ('a, proxy, 'c) state (* Note: A promise whose state is [Proxy _] is a "proxy" promise. A promise whose state is *not* [Proxy _] is an "underlying" promise. The "underlying promise of [p]" is: - [p], if [p] is itself underlying. - Otherwise, [p] is a proxy and has state [Proxy p']. The underlying promise of [p] is the underlying promise of [p']. In other words, to find the underlying promise of a proxy, Lwt follows the [Proxy _] links to the end. *) (* Note: When a promise is resolved, or becomes a proxy, its state field is mutated. This invalidates the type invariants on the promise. See internal function [set_promise_state] for details about that. When an Lwt function has a reference to a promise, and also registers a callback that has a reference to the same promise, the invariants on the reference may become invalid by the time the callback is called. All such callbacks have comments explaining what the valid invariants are at that point, and/or casts to (1) get the correct typing and (2) document the potential state change for readers of the code. *) (* Callback information for pending promises. *) and 'a callbacks = { mutable regular_callbacks : 'a regular_callback_list; mutable cancel_callbacks : 'a cancel_callback_list; mutable how_to_cancel : how_to_cancel; mutable cleanups_deferred : int; } and 'a regular_callback = 'a resolved_state -> unit and cancel_callback = unit -> unit and 'a resolved_state = ('a, underlying, resolved) state and how_to_cancel = | Not_cancelable : how_to_cancel | Cancel_this_promise : how_to_cancel | Propagate_cancel_to_one : (_, _, _) promise -> how_to_cancel | Propagate_cancel_to_several : (_, _, _) promise list -> how_to_cancel and 'a regular_callback_list = | Regular_callback_list_empty | Regular_callback_list_concat of 'a regular_callback_list * 'a regular_callback_list | Regular_callback_list_implicitly_removed_callback of 'a regular_callback | Regular_callback_list_explicitly_removable_callback of 'a regular_callback option ref and _ cancel_callback_list = | Cancel_callback_list_empty : _ cancel_callback_list | Cancel_callback_list_concat : 'a cancel_callback_list * 'a cancel_callback_list -> 'a cancel_callback_list | Cancel_callback_list_callback : storage * cancel_callback -> _ cancel_callback_list | Cancel_callback_list_remove_sequence_node : ('a, _, _) promise Lwt_sequence.node -> 'a cancel_callback_list (* Notes: These type definitions are guilty of performing several optimizations, without which they would be much easier to understand. - The type parameters of ['a resolved_state] guarantee that it is either [Fulfilled _] or [Rejected _]. So, it is equivalent to [('a, exn) Stdlib.result], and, indeed, should have an identical memory representation. - As per the Overview, there are regular callbacks and cancel callbacks. Cancel callbacks are called only on cancellation, and, then, before any regular callbacks are called. Despite the different types for the two kinds of callbacks, they are otherwise the same. Cancel callbacks just don't need a result state argument, because it is known to be [Rejected Canceled]. - Regular callbacks are not allowed to raise exceptions. All regular callbacks are created in this file, so this can be checked. Cancel callbacks can raise exceptions, but if they do so, the exceptions are passed to [async_exception_hook]. - [how_to_cancel] implements the dependency graph mentioned in the Overview. It is traversed backwards during [Lwt.cancel]. It is a GADT because we don't care about the actual types of the promise references stored, or their invariants. The constructors correspond to pending promise kinds as follows: - [Not_cancelable]: initial, [Lwt.wait]. - [Cancel_this_promise]: initial, [Lwt.task]. - [Propagate_cancel_to_one]: sequential composition, e.g. [Lwt.bind]. - [Propagate_cancel_to_several]: concurrent composition, e.g. [Lwt.join]. - The two callback list types are ordinary append-friendly lists, with two optimizations inlined: - ['a regular_callback_list] apparently has two "kinds" of regular callbacks, implicitly removed and explicitly removable. All callbacks are removable. It's just that, for some callbacks, they will only be removed at the same time that the promise they are attached to becomes resolved. When that happens, the entire state of that promise changes to [Fulfilled _] or [Rejected _], and the reference to the whole callback list is simply lost. This "removes" the callback. For these callbacks, ['a regular_callback_list] attempts to trim an option and a reference cell with the [Regular_callback_list_implicitly_removed_callback] constructor. - ['a cancel_callback_list] has [Cancel_callback_list_remove_sequence_node node], which is the same as [Cancel_callback_list_callback (_, (fun _ -> Lwt_sequence.remove node))]. This was probably done to avoid a closure allocation. - The [cleanups_deferred] field is explained in module [Pending_callbacks]. *) end open Main_internal_types module Public_types = struct type +'a t type -'a u let to_public_promise : ('a, _, _) promise -> 'a t = Obj.magic let to_public_resolver : ('a, _, _) promise -> 'a u = Obj.magic type _ packed_promise = | Internal : ('a, _, _) promise -> 'a packed_promise [@@ocaml.unboxed] let to_internal_promise (p : 'a t) : 'a packed_promise = Internal (Obj.magic p) let to_internal_resolver (r : 'a u) : 'a packed_promise = Internal (Obj.magic r) (* Most functions that take a public promise (['a t]) convert it to an internal promise as follows: (* p : 'a t *) let Internal p = to_internal_promise p in (* p : ('a, u, c) promise, where u and c are fresh types, i.e. the invariants on p are unknown. *) This cast is a no-op cast. It only produces a reference with a different type. The introduction and immediate elimination of [Internal _] seems to be optimized away even on older versions of OCaml that don't have Flambda and don't support [[@@ocaml.unboxed]]. *) (* This could probably save an allocation by using [Obj.magic]. *) let state_of_result = function | Ok x -> Fulfilled x | Error exn -> Rejected exn end include Public_types module Basic_helpers : sig val identical : ('a, _, _) promise -> ('a, _, _) promise -> bool val underlying : ('a, 'u, 'c) promise -> ('a, underlying, 'c) promise type ('a, 'u, 'c) state_changed = | State_may_have_changed of ('a, 'u, 'c) promise [@@ocaml.unboxed] val set_promise_state : ('a, _, _) promise -> ('a, 'u, 'c) state -> ('a, 'u, 'c) state_changed type 'a may_now_be_proxy = | State_may_now_be_pending_proxy : ('a, _, pending) promise -> 'a may_now_be_proxy [@@ocaml.unboxed] val may_now_be_proxy : ('a, underlying, pending) promise -> 'a may_now_be_proxy end = struct (* Checks physical equality ([==]) of two internal promises. Unlike [==], does not force unification of their invariants. *) let identical p1 p2 = (to_public_promise p1) == (to_public_promise p2) (* [underlying p] evaluates to the underlying promise of [p]. If multiple [Proxy _] links are traversed, [underlying] updates all the proxies to point immediately to their final underlying promise. *) let rec underlying : type u c. ('a, u, c) promise -> ('a, underlying, c) promise = fun p -> match p.state with | Fulfilled _ -> (p : (_, underlying, _) promise) | Rejected _ -> p | Pending _ -> p | Proxy p' -> let p'' = underlying p' in if not (identical p'' p') then p.state <- Proxy p''; p'' type ('a, 'u, 'c) state_changed = | State_may_have_changed of ('a, 'u, 'c) promise [@@ocaml.unboxed] let set_promise_state p state = let p : (_, _, _) promise = Obj.magic p in p.state <- state; State_may_have_changed p (* [set_promise_state p state] mutates the state of [p], and evaluates to a (wrapped) reference to [p] with the same invariants as on [state]. The original reference [p] should be shadowed when calling this function: let State_may_have_changed p = set_promise_state p (Fulfilled 42) in ... This is a kind of cheap imitation of linear typing, which is good enough for the needs of [lwt.ml]. Internal functions that transitively call [set_promise_state] likewise return the new reference. This ends at some top-level function, typically either a callback or a function in the public API. There, the new reference is still bound, but is then explicitly ignored. The state of a promise is never updated directly outside this module [Basic_helpers]. All updates elsewhere are done through [set_promise_state]. To avoid problems with type-level invariants not matching reality, data structures do not store promises with concrete invariants -- except resolved promises, which are immutable. Indeed, if one looks at definitions of data structures that can store pending promises, e.g. the [how_to_cancel] graph, the invariants are existentially quantified. Note: it's possible to statically disallow the setting of the [state] field by making type [promise] private. However, that seems to require writing a signature that is a near-duplicate of [Main_internal_types], or some abuse of functors. *) type 'a may_now_be_proxy = | State_may_now_be_pending_proxy : ('a, _, pending) promise -> 'a may_now_be_proxy [@@ocaml.unboxed] let may_now_be_proxy p = State_may_now_be_pending_proxy p (* Many functions, for example [Lwt.bind] and [Lwt.join], create a fresh pending promise [p] and return it to the user. They do not return a corresponding resolver. That means that only the function itself (typically, a callback registered by it) can resolve [p]. The only thing the user can do directly is try to cancel [p], but, since [p] is not an initial promise, the cancellation attempt simply propagates past [p] to [p]'s predecessors. If that eventually results in canceling [p], it will be through the normal mechanisms of the function (e.g. [Lwt.bind]'s callback). As a result, the only possible state change, before the callback, is that [p] may have become a proxy. Now, - If [p] does not undergo this state change and become a proxy, it remains an underlying, pending promise. - If [p] does become a proxy, it will be a proxy for another promise [p'] created fresh by [Lwt.bind], to which this same argument applies. See [make_into_proxy]. So, by induction on the length of the proxy ([Proxy _]) chain, at the time the callback is called, [p] is either an underlying, pending promise, or a proxy for a pending promise. The cast let State_may_now_be_pending_proxy p = may_now_be_proxy p in ... encodes the possibility of this state change. It replaces a reference p : ('a, underlying, pending) with p : ('a, $Unknown, pending) and is typically seen at the beginning of callbacks registered by [Lwt.bind] and similar functions. The cast is a no-op cast. The introduction and immediate elimination of [State_may_have_changed _] seems to be optimized away even on old versions of OCaml. *) end open Basic_helpers (* Small helpers to avoid catching ocaml-runtime exceptions *) module Exception_filter = struct type t = exn -> bool let handle_all = fun _ -> true let handle_all_except_runtime = function | Out_of_memory -> false | Stack_overflow -> false | _ -> true let v = (* Default value: the legacy behaviour to avoid breaking programs *) ref handle_all let set f = v := f let run e = !v e end module Sequence_associated_storage : sig (* Public interface *) type 'v key val new_key : unit -> _ key val get : 'v key -> 'v option val with_value : 'v key -> 'v option -> (unit -> 'b) -> 'b (* Internal interface *) val current_storage : storage ref end = struct (* The idea behind sequence-associated storage is to preserve some values during a call to [bind] or other sequential composition operation, and restore those values in the callback function: Lwt.with_value my_key (Some "foo") (fun () -> p >|= fun () -> assert (Lwt.get my_key = Some "foo")) (* Will succeed even if this callback is called later. *) Note that it does not matter that the callback is defined within an argument of [with_value], i.e., this does the same: let f = fun () -> assert (Lwt.get my_key = Some "foo") in Lwt.with_value my_key (Some "foo") (fun () -> p >|= f) All that matters is that the top-most sequencing operation (in this case, map) is executed by that argument. This is implemented using a single global heterogeneous key-value map. Sequential composition functions snapshot this map when they are called, and restore the snapshot right before calling the user's callback. The same happens for cancel triggers added by [on_cancel]. Maintainer's note: I think using this mechanism should be discouraged in new code. *) type 'v key = { id : int; mutable value : 'v option; } let next_key_id = ref 0 let new_key () = let id = !next_key_id in next_key_id := id + 1; {id = id; value = None} let current_storage = ref Storage_map.empty let get key = if Storage_map.mem key.id !current_storage then begin let refresh = Storage_map.find key.id !current_storage in refresh (); let value = key.value in key.value <- None; value end else None let with_value key value f = let new_storage = match value with | Some _ -> let refresh = fun () -> key.value <- value in Storage_map.add key.id refresh !current_storage | None -> Storage_map.remove key.id !current_storage in let saved_storage = !current_storage in current_storage := new_storage; try let result = f () in current_storage := saved_storage; result with exn when Exception_filter.run exn -> current_storage := saved_storage; raise exn end include Sequence_associated_storage module Pending_callbacks : sig (* Mutating callback lists attached to pending promises *) val add_implicitly_removed_callback : 'a callbacks -> 'a regular_callback -> unit val add_explicitly_removable_callback_to_each_of : 'a t list -> 'a regular_callback -> unit val add_explicitly_removable_callback_and_give_remove_function : 'a t list -> 'a regular_callback -> cancel_callback val add_cancel_callback : 'a callbacks -> cancel_callback -> unit val merge_callbacks : from:'a callbacks -> into:'a callbacks -> unit end = struct let concat_regular_callbacks l1 l2 = begin match l1, l2 with | Regular_callback_list_empty, _ -> l2 | _, Regular_callback_list_empty -> l1 | _, _ -> Regular_callback_list_concat (l1, l2) end [@ocaml.warning "-4"] let concat_cancel_callbacks l1 l2 = begin match l1, l2 with | Cancel_callback_list_empty, _ -> l2 | _, Cancel_callback_list_empty -> l1 | _, _ -> Cancel_callback_list_concat (l1, l2) end [@ocaml.warning "-4"] (* In a callback list, filters out cells of explicitly removable callbacks that have been removed. *) let rec clean_up_callback_cells = function | Regular_callback_list_explicitly_removable_callback {contents = None} -> Regular_callback_list_empty | Regular_callback_list_explicitly_removable_callback {contents = Some _} | Regular_callback_list_implicitly_removed_callback _ | Regular_callback_list_empty as callbacks -> callbacks | Regular_callback_list_concat (l1, l2) -> let l1 = clean_up_callback_cells l1 in let l2 = clean_up_callback_cells l2 in concat_regular_callbacks l1 l2 (* See [clear_explicitly_removable_callback_cell] and [merge_callbacks]. *) let cleanup_throttle = 42 (* Explicitly removable callbacks are added (mainly) by [Lwt.choose] and its similar functions. In [Lwt.choose [p; p']], if [p'] resolves first, the callback added by [Lwt.choose] to [p] is removed. The removal itself is accomplished when this function clears the reference cell [cell], which contains the reference to that callback. If [p] is a long-pending promise that repeatedly participates in [Lwt.choose], perhaps in a loop, it will accumulate a large number of cleared reference cells in this fashion. To avoid a memory leak, they must be cleaned up. However, the cells are not cleaned up on *every* removal, presumably because scanning the callback list that often, and rebuilding it, can get expensive. Cleanup is throttled by maintaining a counter, [cleanups_deferred], on each pending promise. The counter is incremented each time this function wants to clean the callback list (right after clearing a cell). When the counter reaches [cleanup_throttle], the callback list is actually scanned and cleared callback cells are removed. *) let clear_explicitly_removable_callback_cell cell ~originally_added_to:ps = cell := None; (* Go through the promises the cell had originally been added to, and either defer a cleanup, or actually clean up their callback lists. *) ps |> List.iter (fun p -> let Internal p = to_internal_promise p in match (underlying p).state with (* Some of the promises may already have been resolved at the time this function is called. *) | Fulfilled _ -> () | Rejected _ -> () | Pending callbacks -> match callbacks.regular_callbacks with (* If the promise has only one regular callback, and it is removable, it must have been the cell cleared in this function, above. In that case, just set its callback list to empty. *) | Regular_callback_list_explicitly_removable_callback _ -> callbacks.regular_callbacks <- Regular_callback_list_empty (* Maintainer's note: I think this function shouldn't try to trigger a cleanup in the first two cases, but I am preserving them for now, as this is how the code was written in the past. *) | Regular_callback_list_empty | Regular_callback_list_implicitly_removed_callback _ | Regular_callback_list_concat _ -> let cleanups_deferred = callbacks.cleanups_deferred + 1 in if cleanups_deferred > cleanup_throttle then begin callbacks.cleanups_deferred <- 0; callbacks.regular_callbacks <- clean_up_callback_cells callbacks.regular_callbacks end else callbacks.cleanups_deferred <- cleanups_deferred) (* Concatenates both kinds of callbacks on [~from] to the corresponding lists of [~into]. The callback lists on [~from] are *not* then cleared, because this function is called only by [Sequential_composition.make_into_proxy], which immediately changes the state of [~from] and loses references to the original callback lists. The [cleanups_deferred] fields of both promises are summed, and if the sum exceeds [cleanup_throttle], a cleanup of regular callbacks is triggered. This is to prevent memory leaks; see [clear_explicitly_removable_callback_cell]. *) let merge_callbacks ~from ~into = let regular_callbacks = concat_regular_callbacks into.regular_callbacks from.regular_callbacks in let cleanups_deferred = into.cleanups_deferred + from.cleanups_deferred in let regular_callbacks, cleanups_deferred = if cleanups_deferred > cleanup_throttle then clean_up_callback_cells regular_callbacks, 0 else regular_callbacks, cleanups_deferred in let cancel_callbacks = concat_cancel_callbacks into.cancel_callbacks from.cancel_callbacks in into.regular_callbacks <- regular_callbacks; into.cancel_callbacks <- cancel_callbacks; into.cleanups_deferred <- cleanups_deferred (* General, internal, function for adding a regular callback. *) let add_regular_callback_list_node callbacks node = callbacks.regular_callbacks <- match callbacks.regular_callbacks with | Regular_callback_list_empty -> node | Regular_callback_list_implicitly_removed_callback _ | Regular_callback_list_explicitly_removable_callback _ | Regular_callback_list_concat _ as existing -> Regular_callback_list_concat (node, existing) let add_implicitly_removed_callback callbacks f = add_regular_callback_list_node callbacks (Regular_callback_list_implicitly_removed_callback f) (* Adds [callback] as removable to each promise in [ps]. The first promise in [ps] to trigger [callback] removes [callback] from the other promises; this guarantees that [callback] is called at most once. All the promises in [ps] must be pending. This is an internal function, indirectly used by the implementations of [Lwt.choose] and related functions. *) let add_explicitly_removable_callback_and_give_cell ps f = let rec cell = ref (Some self_removing_callback_wrapper) and self_removing_callback_wrapper result = clear_explicitly_removable_callback_cell cell ~originally_added_to:ps; f result in let node = Regular_callback_list_explicitly_removable_callback cell in ps |> List.iter (fun p -> let Internal p = to_internal_promise p in match (underlying p).state with | Pending callbacks -> add_regular_callback_list_node callbacks node | Fulfilled _ -> assert false | Rejected _ -> assert false); cell let add_explicitly_removable_callback_to_each_of ps f = ignore (add_explicitly_removable_callback_and_give_cell ps f) (* This is basically just to support [Lwt.protected], which needs to remove the callback in circumstances other than the callback being called. *) let add_explicitly_removable_callback_and_give_remove_function ps f = let cell = add_explicitly_removable_callback_and_give_cell ps f in fun () -> clear_explicitly_removable_callback_cell cell ~originally_added_to:ps let add_cancel_callback callbacks f = let node = Cancel_callback_list_callback (!current_storage, f) in callbacks.cancel_callbacks <- match callbacks.cancel_callbacks with | Cancel_callback_list_empty -> node | Cancel_callback_list_callback _ | Cancel_callback_list_remove_sequence_node _ | Cancel_callback_list_concat _ -> Cancel_callback_list_concat (node, callbacks.cancel_callbacks) end open Pending_callbacks module Resolution_loop : sig (* All user-provided callbacks are called by Lwt only through this module. It tracks the current callback stack depth, and decides whether each callback call should be deferred or not. *) (* Internal interface used only in this module Lwt *) val resolve : ?allow_deferring:bool -> ?maximum_callback_nesting_depth:int -> ('a, underlying, pending) promise -> 'a resolved_state -> ('a, underlying, resolved) state_changed val run_callbacks_or_defer_them : ?allow_deferring:bool -> ?maximum_callback_nesting_depth:int -> ('a callbacks) -> 'a resolved_state -> unit val run_callback_or_defer_it : ?run_immediately_and_ensure_tail_call:bool -> callback:(unit -> 'a) -> if_deferred:(unit -> 'a * 'b regular_callback * 'b resolved_state) -> 'a val handle_with_async_exception_hook : ('a -> unit) -> 'a -> unit (* Internal interface exposed to other modules in Lwt *) val abandon_wakeups : unit -> unit (* Public interface *) exception Canceled val async_exception_hook : (exn -> unit) ref end = struct (* When Lwt needs to call a callback, it enters the resolution loop. This typically happens when Lwt sets the state of one promise to [Fulfilled _] or [Rejected _]. The callbacks that were attached to the promise when it was pending must then be called. This also happens in a few other situations. For example, when [Lwt.bind] is called on a promise, but that promise is already resolved, the callback passed to [bind] must be called. The callbacks triggered during the resolution loop might resolve more promises, triggering more callbacks, and so on. This is what makes the resolution loop a {e loop}. Lwt generally tries to call each callback immediately. However, this can lead to a progressive deepening of the call stack, until there is a stack overflow. This can't be avoided by doing tail calls, because Lwt always needs to do exception handling around callbacks calls: each callback call is followed by an exception handler. Instead, what Lwt does is track the current callback call depth. Once that depth reaches a certain number, [default_maximum_callback_nesting_depth], defined below, further callbacks are deferred into a queue instead. That queue is drained when Lwt exits from the top-most callback call that triggered the resolution loop in the first place. To ensure that this deferral mechanism is always properly invoked, all callbacks called by Lwt are called through one of three functions provided by this module: - [resolve], which calls all the callbacks associated to a pending promise (and resolves it, changing its state). - [run_callbacks_or_defer_them], which is internally used by [resolve] to call callbacks that are in a record of type ['a callbacks], which records are associated with pending promises. This function is exposed because the current implementation of [Lwt.cancel] needs to call it directly. Promise resolution and callback calling are separated in a unique way in [cancel]. - [run_callback_or_defer_it], which is used by [Lwt.bind] and similar functions to call single callbacks when the promises passed to [Lwt.bind], etc., are already resolved. Current Lwt actually has a messy mix of callback-calling behaviors. For example, [Lwt.bind] is expected to always call its callback immediately, while [Lwt.wakeup_later] is expected to defer all callbacks of the promise resolved, {e unless} Lwt is not already inside the resolution loop. We planned to make these behaviors uniform in Lwt 4.0.0, but decided against it due to the risk of breaking users. See - https://github.com/ocsigen/lwt/pull/500 - https://github.com/ocsigen/lwt/pull/519 As part of the preparation for the change, the above callback-invoking functions support several optional arguments to emulate the various behaviors. We decided not to remove this machinery, because we might want to expose different APIs to Lwt in the future. - [~allow_deferring:false] allows ignoring the callback stack depth, and calling the callbacks immediately. This emulates the old resolution behavior. - [~maximum_callback_nesting_depth:1] allows limiting the depth which triggers deferral on a per-call-site basis. This is used by [Lwt.wakeup_later]. - [~run_immediately_and_ensure_tail_call:true] is like [~allow_deferring:false], which ignores the callback stack depth. However, to ensure that the callback is tail-called, Lwt doesn't even update the callback stack depth for the benefit of *other* callback calls. It just blindly calls the callback. See discussion of callback-calling semantics in: https://github.com/ocsigen/lwt/issues/329 * Context The resolution loop effectively handles all promises that can be resolved immediately, without blocking on I/O. A complete program that does I/O calls [Lwt_main.run]. See "No I/O" in the Overview. *) let async_exception_hook = ref (fun exn -> prerr_string "Fatal error: exception "; prerr_string (Printexc.to_string exn); prerr_char '\n'; Printexc.print_backtrace stderr; flush stderr; exit 2) let handle_with_async_exception_hook f v = (* Note that this function does not care if [f] evaluates to a promise. In particular, if [f v] evaluates to [p] and [p] is already rejected or will be reject later, it is not the responsibility of this function to pass the exception to [!async_exception_hook]. *) try f v with exn when Exception_filter.run exn -> !async_exception_hook exn exception Canceled (* Runs the callbacks (formerly) associated to a promise. Cancel callbacks are run first, if the promise was canceled. These are followed by regular callbacks. The reason for the "formerly" is that the promise's state has already been set to [Fulfilled _] or [Rejected _], so the callbacks are no longer reachable through the promise reference. This is why the direct [callbacks] record must be given to this function. *) let run_callbacks (callbacks : 'a callbacks) (result : 'a resolved_state) : unit = let run_cancel_callbacks fs = let rec iter_callback_list fs rest = match fs with | Cancel_callback_list_empty -> iter_list rest | Cancel_callback_list_callback (storage, f) -> current_storage := storage; handle_with_async_exception_hook f (); iter_list rest | Cancel_callback_list_remove_sequence_node node -> Lwt_sequence.remove node; iter_list rest | Cancel_callback_list_concat (fs, fs') -> iter_callback_list fs (fs'::rest) and iter_list rest = match rest with | [] -> () | fs::rest -> iter_callback_list fs rest in iter_callback_list fs [] in let run_regular_callbacks fs = let rec iter_callback_list fs rest = match fs with | Regular_callback_list_empty -> iter_list rest | Regular_callback_list_implicitly_removed_callback f -> f result; iter_list rest | Regular_callback_list_explicitly_removable_callback {contents = None} -> iter_list rest | Regular_callback_list_explicitly_removable_callback {contents = Some f} -> f result; iter_list rest | Regular_callback_list_concat (fs, fs') -> iter_callback_list fs (fs'::rest) and iter_list rest = match rest with | [] -> () | fs::rest -> iter_callback_list fs rest in iter_callback_list fs [] in (* Pattern matching is much faster than polymorphic comparison. *) let is_canceled = match result with | Rejected Canceled -> true | Rejected _ -> false | Fulfilled _ -> false in if is_canceled then run_cancel_callbacks callbacks.cancel_callbacks; run_regular_callbacks callbacks.regular_callbacks let default_maximum_callback_nesting_depth = 42 let current_callback_nesting_depth = ref 0 type deferred_callbacks = Deferred : ('a callbacks * 'a resolved_state) -> deferred_callbacks [@@ocaml.unboxed] let deferred_callbacks : deferred_callbacks Queue.t = Queue.create () (* Before entering a resolution loop, it is necessary to take a snapshot of the current state of sequence-associated storage. This is because many of the callbacks that will be run will modify the storage. The storage is restored to the snapshot when the resolution loop is exited. *) let enter_resolution_loop () = current_callback_nesting_depth := !current_callback_nesting_depth + 1; let storage_snapshot = !current_storage in storage_snapshot let leave_resolution_loop (storage_snapshot : storage) : unit = if !current_callback_nesting_depth = 1 then begin while not (Queue.is_empty deferred_callbacks) do let Deferred (callbacks, result) = Queue.pop deferred_callbacks in run_callbacks callbacks result done end; current_callback_nesting_depth := !current_callback_nesting_depth - 1; current_storage := storage_snapshot let run_in_resolution_loop f = let storage_snapshot = enter_resolution_loop () in let result = f () in leave_resolution_loop storage_snapshot; result (* This is basically a hack to fix https://github.com/ocsigen/lwt/issues/48. If currently resolving promises, it immediately exits all recursive entries of the resolution loop, goes to the top level, runs any deferred callbacks, and exits the top-level resolution loop. The name should probably be [abaondon_resolution_loop]. *) let abandon_wakeups () = if !current_callback_nesting_depth <> 0 then leave_resolution_loop Storage_map.empty let run_callbacks_or_defer_them ?(allow_deferring = true) ?(maximum_callback_nesting_depth = default_maximum_callback_nesting_depth) callbacks result = let should_defer = allow_deferring && !current_callback_nesting_depth >= maximum_callback_nesting_depth in if should_defer then Queue.push (Deferred (callbacks, result)) deferred_callbacks else run_in_resolution_loop (fun () -> run_callbacks callbacks result) let resolve ?allow_deferring ?maximum_callback_nesting_depth p result = let Pending callbacks = p.state in let p = set_promise_state p result in run_callbacks_or_defer_them ?allow_deferring ?maximum_callback_nesting_depth callbacks result; p let run_callback_or_defer_it ?(run_immediately_and_ensure_tail_call = false) ~callback:f ~if_deferred = if run_immediately_and_ensure_tail_call then f () else let should_defer = !current_callback_nesting_depth >= default_maximum_callback_nesting_depth in if should_defer then begin let immediate_result, deferred_callback, deferred_result = if_deferred () in let deferred_record = { regular_callbacks = Regular_callback_list_implicitly_removed_callback deferred_callback; cancel_callbacks = Cancel_callback_list_empty; how_to_cancel = Not_cancelable; cleanups_deferred = 0 } in Queue.push (Deferred (deferred_record, deferred_result)) deferred_callbacks; immediate_result end else run_in_resolution_loop (fun () -> f ()) end include Resolution_loop module Resolving : sig val wakeup_later_result : 'a u -> ('a, exn) result -> unit val wakeup_later : 'a u -> 'a -> unit val wakeup_later_exn : _ u -> exn -> unit val wakeup_result : 'a u -> ('a, exn) result -> unit val wakeup : 'a u -> 'a -> unit val wakeup_exn : _ u -> exn -> unit val cancel : 'a t -> unit end = struct (* Note that this function deviates from the "ideal" callback deferral behavior: it runs callbacks directly on the current stack. It should therefore be possible to cause a stack overflow using this function. *) let wakeup_general api_function_name r result = let Internal p = to_internal_resolver r in let p = underlying p in match p.state with | Rejected Canceled -> () | Fulfilled _ -> Printf.ksprintf invalid_arg "Lwt.%s" api_function_name | Rejected _ -> Printf.ksprintf invalid_arg "Lwt.%s" api_function_name | Pending _ -> let result = state_of_result result in let State_may_have_changed p = resolve ~allow_deferring:false p result in ignore p let wakeup_result r result = wakeup_general "wakeup_result" r result let wakeup r v = wakeup_general "wakeup" r (Ok v) let wakeup_exn r exn = wakeup_general "wakeup_exn" r (Error exn) let wakeup_later_general api_function_name r result = let Internal p = to_internal_resolver r in let p = underlying p in match p.state with | Rejected Canceled -> () | Fulfilled _ -> Printf.ksprintf invalid_arg "Lwt.%s" api_function_name | Rejected _ -> Printf.ksprintf invalid_arg "Lwt.%s" api_function_name | Pending _ -> let result = state_of_result result in let State_may_have_changed p = resolve ~maximum_callback_nesting_depth:1 p result in ignore p let wakeup_later_result r result = wakeup_later_general "wakeup_later_result" r result let wakeup_later r v = wakeup_later_general "wakeup_later" r (Ok v) let wakeup_later_exn r exn = wakeup_later_general "wakeup_later_exn" r (Error exn) type packed_callbacks = | Packed : _ callbacks -> packed_callbacks [@@ocaml.unboxed] (* Note that this function deviates from the "ideal" callback deferral behavior: it runs callbacks directly on the current stack. It should therefore be possible to cause a stack overflow using this function. *) let cancel p = let canceled_result = Rejected Canceled in (* Walks the promise dependency graph backwards, looking for cancelable initial promises, and cancels (only) them. Found initial promises are canceled immediately, as they are found, by setting their state to [Rejected Canceled]. This is to prevent them from being "found twice" if they are reachable by two or more distinct paths through the promise dependency graph. The callbacks of these initial promises are then run, in a separate phase. These callbacks propagate cancellation forwards to any dependent promises. See "Cancellation" in the Overview. *) let propagate_cancel : (_, _, _) promise -> packed_callbacks list = fun p -> let rec cancel_and_collect_callbacks : 'a 'u 'c. packed_callbacks list -> ('a, 'u, 'c) promise -> packed_callbacks list = fun (type c) callbacks_accumulator (p : (_, _, c) promise) -> let p = underlying p in match p.state with (* If the promise is not still pending, it can't be canceled. *) | Fulfilled _ -> callbacks_accumulator | Rejected _ -> callbacks_accumulator | Pending callbacks -> match callbacks.how_to_cancel with | Not_cancelable -> callbacks_accumulator | Cancel_this_promise -> let State_may_have_changed p = set_promise_state p canceled_result in ignore p; (Packed callbacks)::callbacks_accumulator | Propagate_cancel_to_one p' -> cancel_and_collect_callbacks callbacks_accumulator p' | Propagate_cancel_to_several ps -> List.fold_left cancel_and_collect_callbacks callbacks_accumulator ps in cancel_and_collect_callbacks [] p in let Internal p = to_internal_promise p in let callbacks = propagate_cancel p in callbacks |> List.iter (fun (Packed callbacks) -> run_callbacks_or_defer_them ~allow_deferring:false callbacks canceled_result) end include Resolving module Trivial_promises : sig val return : 'a -> 'a t val fail : exn -> _ t val of_result : ('a, exn) result -> 'a t val return_unit : unit t val return_true : bool t val return_false : bool t val return_none : _ option t val return_some : 'a -> 'a option t val return_ok : 'a -> ('a, _) result t val return_error : 'e -> (_, 'e) result t val return_nil : _ list t val fail_with : string -> _ t val fail_invalid_arg : string -> _ t end = struct let return v = to_public_promise {state = Fulfilled v} let of_result result = to_public_promise {state = state_of_result result} let fail exn = to_public_promise {state = Rejected exn} let return_unit = return () let return_none = return None let return_some x = return (Some x) let return_nil = return [] let return_true = return true let return_false = return false let return_ok x = return (Ok x) let return_error x = return (Error x) let fail_with msg = to_public_promise {state = Rejected (Failure msg)} let fail_invalid_arg msg = to_public_promise {state = Rejected (Invalid_argument msg)} end include Trivial_promises module Pending_promises : sig (* Internal *) val new_pending : how_to_cancel:how_to_cancel -> ('a, underlying, pending) promise val propagate_cancel_to_several : _ t list -> how_to_cancel (* Initial pending promises (public) *) val wait : unit -> 'a t * 'a u val task : unit -> 'a t * 'a u val add_task_r : 'a u Lwt_sequence.t -> 'a t val add_task_l : 'a u Lwt_sequence.t -> 'a t val protected : 'a t -> 'a t val no_cancel : 'a t -> 'a t end = struct let new_pending ~how_to_cancel = let state = Pending { regular_callbacks = Regular_callback_list_empty; cancel_callbacks = Cancel_callback_list_empty; how_to_cancel; cleanups_deferred = 0; } in {state} let propagate_cancel_to_several ps = (* Using a dirty cast here to avoid rebuilding the list :( Not bothering with the invariants, because [Propagate_cancel_to_several] packs them, and code that matches on [Propagate_cancel_to_several] doesn't care about them anyway. *) let cast_promise_list : 'a t list -> ('a, _, _) promise list = Obj.magic in Propagate_cancel_to_several (cast_promise_list ps) let wait () = let p = new_pending ~how_to_cancel:Not_cancelable in to_public_promise p, to_public_resolver p let task () = let p = new_pending ~how_to_cancel:Cancel_this_promise in to_public_promise p, to_public_resolver p let cast_sequence_node (node : 'a u Lwt_sequence.node) (_actual_content:('a, 'u, 'c) promise) : ('a, 'u, 'c) promise Lwt_sequence.node = Obj.magic node let add_task_r sequence = let p = new_pending ~how_to_cancel:Cancel_this_promise in let node = Lwt_sequence.add_r (to_public_resolver p) sequence in let node = cast_sequence_node node p in let Pending callbacks = p.state in callbacks.cancel_callbacks <- Cancel_callback_list_remove_sequence_node node; to_public_promise p let add_task_l sequence = let p = new_pending ~how_to_cancel:Cancel_this_promise in let node = Lwt_sequence.add_l (to_public_resolver p) sequence in let node = cast_sequence_node node p in let Pending callbacks = p.state in callbacks.cancel_callbacks <- Cancel_callback_list_remove_sequence_node node; to_public_promise p let protected p = let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with | Fulfilled _ -> p | Rejected _ -> p | Pending _ -> let p' = new_pending ~how_to_cancel:Cancel_this_promise in let callback p_result = let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in let p' = underlying p' in (* In this callback, [p'] will either still itself be pending, or it will have become a proxy for a pending promise. The reasoning for this is almost the same as in the comment at [may_now_be_proxy]. The differences are: - [p'] *is* an initial promise, so it *can* get canceled. However, if it does, the [on_cancel] handler installed below will remove this callback. - [p'] never gets passed to [make_into_proxy], the only effect of which is that it cannot be the underlying promise of another (proxy) promise. So, [p'] can only appear at the head of a chain of [Proxy _] links, and it's not necessary to worry about whether the inductive reasoning at [may_now_be_proxy] applies. *) let State_may_have_changed p' = resolve ~allow_deferring:false p' p_result in ignore p' in let remove_the_callback = add_explicitly_removable_callback_and_give_remove_function [p] callback in let Pending p'_callbacks = p'.state in add_cancel_callback p'_callbacks remove_the_callback; to_public_promise p' let no_cancel p = let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with | Fulfilled _ -> p | Rejected _ -> p | Pending p_callbacks -> let p' = new_pending ~how_to_cancel:Not_cancelable in let callback p_result = let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in let p' = underlying p' in (* In this callback, [p'] will either still itself be pending, or it will have become a proxy for a pending promise. The reasoning for this is as in [protected] and [may_now_be_proxy], but even simpler, because [p'] is not cancelable. *) let State_may_have_changed p' = resolve ~allow_deferring:false p' p_result in ignore p' in add_implicitly_removed_callback p_callbacks callback; to_public_promise p' end include Pending_promises module Sequential_composition : sig (* Main interface (public) *) val bind : 'a t -> ('a -> 'b t) -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t external reraise : exn -> 'a = "%reraise" val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t (* Cancel callbacks (public). *) val on_cancel : 'a t -> (unit -> unit) -> unit (* Non-promise callbacks (public) *) val on_success : 'a t -> ('a -> unit) -> unit val on_failure : _ t -> (exn -> unit) -> unit val on_termination : _ t -> (unit -> unit) -> unit val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit (* Backtrace support (internal; for use by the PPX) *) val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t end = struct (* There are five primary sequential composition functions: [bind], [map], [catch], [finalize], and [try_bind]. Of these, [try_bind] is the most general -- all the others can be implemented in terms of it. Lwt conflates concurrency with error propagation. If Lwt did not do this, there would be only two primary functions: [bind] and [map], and, of these two, [bind] is the most general. Since [bind] is the most relevant specifically to concurrency, and is also the most familiar function in Lwt, its implementation serves as a kind of "model" for the rest. It is the most commented, and all the other functions follow a similar pattern to [bind]. Four of the primary functions have [backtrace_*] versions, which are not truly public, and exist to support the PPX. [backtrace_map] does not exist because the PPX does not need it. The remaining four functions in this section attach "lower-level-ish" non-promise-producing callbacks to promises: these are the [on_*] functions. Of these, [on_any] is the most general. If Lwt did not conflate concurrency with error handling, there would only be one: [on_success]. *) (* Makes [~user_provided_promise] into a proxy of [~outer_promise]. After [make_into_proxy], these two promise references "behave identically." Note that this is not symmetric: [user_provided_promise] always becomes the proxy. [make_into_proxy] is called only by [bind] and similar functions in this module. This means that: - the only way for a promise to become a proxy is by being returned from the callback given by the user to [bind], or a similar function, and - the only way for a promise to become underlying for a promise other than itself is to be the outer promise originally returned to the user from [bind], or a similar function. These two facts are important for reasoning about how and which promises can become proxies, underlying, etc.; in particular, it is used in the argument in [may_now_be_proxy] for correct predictions about state changes. [~outer_promise] is always a pending promise when [make_into_proxy] is called; for the explanation, see [may_now_be_proxy] (though the caller of [make_into_proxy] always calls [underlying] first to pass the underlying pending promise to [make_into_proxy]). The reasons proxying is used, instead of adding a callback to [~user_provided_promise] to resolve [~outer_promise] when the former becomes resolved probably are: - Promises have more behaviors than resolution. One would have to add a cancellation handler to [~outer_promise] to propagate the cancellation back to [~user_provided_promise], for example. It may be easier to just think of them as the same promise. - If using callbacks, resolving [~user_provided_promise] would not immediately resolve [~outer_promise]. Another callback added to [~user_provided_promise] might see [~user_provided_promise] resolved, but [~outer_promise] still pending, depending on the order in which callbacks are run. *) let make_into_proxy (type c) ~(outer_promise : ('a, underlying, pending) promise) ~(user_provided_promise : ('a, _, c) promise) : ('a, underlying, c) state_changed = (* Using [p'] as it's the name used inside [bind], etc., for promises with this role -- [p'] is the promise returned by the user's function. *) let p' = underlying user_provided_promise in if identical p' outer_promise then State_may_have_changed p' (* We really want to return [State_may_have_changed outer_promise], but the reference through [p'] has the right type. *) else match p'.state with | Fulfilled _ -> resolve ~allow_deferring:false outer_promise p'.state | Rejected _ -> resolve ~allow_deferring:false outer_promise p'.state | Pending p'_callbacks -> let Pending outer_callbacks = outer_promise.state in merge_callbacks ~from:p'_callbacks ~into:outer_callbacks; outer_callbacks.how_to_cancel <- p'_callbacks.how_to_cancel; let State_may_have_changed p' = set_promise_state p' (Proxy outer_promise) in ignore p'; State_may_have_changed outer_promise (* The state hasn't actually changed, but we still have to wrap [outer_promise] for type checking. *) (* The state of [p'] may instead have changed -- it may have become a proxy. However, callers of [make_into_proxy] don't know if [user_provided_promise] was a proxy or not (that's why we call underlying on it at the top of this function, to get [p']). We can therefore take a dangerous shortcut and not bother returning a new reference to [user_provided_promise] for shadowing. *) (* Maintainer's note: a lot of the code below can probably be deduplicated in some way, especially if assuming Flambda. *) let bind p f = let Internal p = to_internal_promise p in let p = underlying p in (* In case [Lwt.bind] needs to defer the call to [f], this function will be called to create: 1. The promise, [p''], that must be returned to the caller immediately. 2. The callback that resolves [p'']. [Lwt.bind] defers the call to [f] in two circumstances: 1. The promise [p] is pending. 2. The promise [p] is fulfilled, but the current callback call nesting depth is such that the call to [f] must go into the callback queue, in order to avoid stack overflow. Mechanism (2) is currently disabled. It may be used in an alternative Lwt API. Functions other than [Lwt.bind] have analogous deferral behavior. *) let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in (* The result promise is a fresh pending promise. Initially, trying to cancel this fresh pending promise [p''] will propagate the cancellation attempt to [p] (backwards through the promise dependency graph). If/when [p] is fulfilled, Lwt will call the user's callback [f] below, which will provide a new promise [p'], and [p'] will become a proxy of [p'']. At that point, trying to cancel [p''] will be equivalent to trying to cancel [p'], so the behavior will depend on how the user obtained [p']. *) let saved_storage = !current_storage in let callback p_result = match p_result with | Fulfilled v -> current_storage := saved_storage; let p' = try f v with exn when Exception_filter.run exn -> fail exn in let Internal p' = to_internal_promise p' in (* Run the user's function [f]. *) let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in (* [p''] was an underlying promise when it was created above, but it may have become a proxy by the time this code is being executed. However, it is still either an underlying pending promise, or a proxy for a pending promise. Therefore, [may_now_be_proxy] produces a reference with the right type variables. We immediately get [p'']'s current underlying promise. *) let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' (* Make the outer promise [p''] behaviorally identical to the promise [p'] returned by [f] by making [p'] into a proxy of [p'']. *) | Rejected _ as p_result -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p_result in ignore p'' in (to_public_promise p'', callback) in match p.state with | Fulfilled v -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> f v) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Rejected _ as result -> to_public_promise {state = result} | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback; p'' let backtrace_bind add_loc p f = let Internal p = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in let saved_storage = !current_storage in let callback p_result = match p_result with | Fulfilled v -> current_storage := saved_storage; let p' = try f v with exn when Exception_filter.run exn -> fail (add_loc exn) in let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' | Rejected exn -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' (Rejected (add_loc exn)) in ignore p'' in (to_public_promise p'', callback) in match p.state with | Fulfilled v -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> f v) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Rejected exn -> to_public_promise {state = Rejected (add_loc exn)} | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback; p'' let map f p = let Internal p = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in let saved_storage = !current_storage in let callback p_result = match p_result with | Fulfilled v -> current_storage := saved_storage; let p''_result = try Fulfilled (f v) with exn when Exception_filter.run exn -> Rejected exn in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p''_result in ignore p'' | Rejected _ as p_result -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p_result in ignore p'' in (to_public_promise p'', callback) in match p.state with | Fulfilled v -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> to_public_promise {state = try Fulfilled (f v) with exn when Exception_filter.run exn -> Rejected exn}) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Rejected _ as result -> to_public_promise {state = result} | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback; p'' external reraise : exn -> 'a = "%reraise" let catch f h = let p = try f () with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in let saved_storage = !current_storage in let callback p_result = match p_result with | Fulfilled _ as p_result -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p_result in ignore p'' | Rejected exn -> current_storage := saved_storage; let p' = try h exn with exn when Exception_filter.run exn -> fail exn in let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' in (to_public_promise p'', callback) in match p.state with | Fulfilled _ -> to_public_promise p | Rejected exn -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> h exn) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback; p'' let backtrace_catch add_loc f h = let p = try f () with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in let saved_storage = !current_storage in let callback p_result = match p_result with | Fulfilled _ as p_result -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p_result in ignore p'' | Rejected exn -> current_storage := saved_storage; let p' = try h exn with exn when Exception_filter.run exn -> fail (add_loc exn) in let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' in (to_public_promise p'', callback) in match p.state with | Fulfilled _ -> to_public_promise p | Rejected exn -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> h (add_loc exn)) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback; p'' let try_bind f f' h = let p = try f () with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in let saved_storage = !current_storage in let callback p_result = match p_result with | Fulfilled v -> current_storage := saved_storage; let p' = try f' v with exn when Exception_filter.run exn -> fail exn in let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' | Rejected exn -> current_storage := saved_storage; let p' = try h exn with exn when Exception_filter.run exn -> fail exn in let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' in (to_public_promise p'', callback) in match p.state with | Fulfilled v -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> f' v) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Rejected exn -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> h exn) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback; p'' let backtrace_try_bind add_loc f f' h = let p = try f () with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in let p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in let saved_storage = !current_storage in let callback p_result = match p_result with | Fulfilled v -> current_storage := saved_storage; let p' = try f' v with exn when Exception_filter.run exn -> fail (add_loc exn) in let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' | Rejected exn -> current_storage := saved_storage; let p' = try h exn with exn when Exception_filter.run exn -> fail (add_loc exn) in let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' in (to_public_promise p'', callback) in match p.state with | Fulfilled v -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> f' v) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Rejected exn -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> h (add_loc exn)) ~if_deferred:(fun () -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in (p'', callback, p.state)) | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback; p'' let finalize f f' = try_bind f (fun x -> bind (f' ()) (fun () -> return x)) (fun e -> bind (f' ()) (fun () -> fail e)) let backtrace_finalize add_loc f f' = backtrace_try_bind add_loc f (fun x -> bind (f' ()) (fun () -> return x)) (fun e -> bind (f' ()) (fun () -> fail (add_loc e))) let on_cancel p f = let Internal p = to_internal_promise p in let p = underlying p in match p.state with | Rejected Canceled -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> handle_with_async_exception_hook f ()) ~if_deferred:(fun () -> ((), (fun _ -> handle_with_async_exception_hook f ()), Fulfilled ())) | Rejected _ -> () | Fulfilled _ -> () | Pending callbacks -> add_cancel_callback callbacks f let on_success p f = let Internal p = to_internal_promise p in let p = underlying p in let callback_if_deferred () = let saved_storage = !current_storage in fun result -> match result with | Fulfilled v -> current_storage := saved_storage; handle_with_async_exception_hook f v | Rejected _ -> () in match p.state with | Fulfilled v -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> handle_with_async_exception_hook f v) ~if_deferred:(fun () -> let callback = callback_if_deferred () in ((), callback, p.state)) | Rejected _ -> () | Pending p_callbacks -> let callback = callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback let on_failure p f = let Internal p = to_internal_promise p in let p = underlying p in let callback_if_deferred () = let saved_storage = !current_storage in fun result -> match result with | Fulfilled _ -> () | Rejected exn -> current_storage := saved_storage; handle_with_async_exception_hook f exn in match p.state with | Fulfilled _ -> () | Rejected exn -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> handle_with_async_exception_hook f exn) ~if_deferred:(fun () -> let callback = callback_if_deferred () in ((), callback, p.state)) | Pending p_callbacks -> let callback = callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback let on_termination p f = let Internal p = to_internal_promise p in let p = underlying p in let callback_if_deferred () = let saved_storage = !current_storage in fun _result -> current_storage := saved_storage; handle_with_async_exception_hook f () in match p.state with | Fulfilled _ -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> handle_with_async_exception_hook f ()) ~if_deferred:(fun () -> let callback = callback_if_deferred () in ((), callback, p.state)) | Rejected _ -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> handle_with_async_exception_hook f ()) ~if_deferred:(fun () -> let callback = callback_if_deferred () in ((), callback, p.state)) | Pending p_callbacks -> let callback = callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback let on_any p f g = let Internal p = to_internal_promise p in let p = underlying p in let callback_if_deferred () = let saved_storage = !current_storage in fun result -> match result with | Fulfilled v -> current_storage := saved_storage; handle_with_async_exception_hook f v | Rejected exn -> current_storage := saved_storage; handle_with_async_exception_hook g exn in match p.state with | Fulfilled v -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> handle_with_async_exception_hook f v) ~if_deferred:(fun () -> let callback = callback_if_deferred () in ((), callback, p.state)) | Rejected exn -> run_callback_or_defer_it ~run_immediately_and_ensure_tail_call:true ~callback:(fun () -> handle_with_async_exception_hook g exn) ~if_deferred:(fun () -> let callback = callback_if_deferred () in ((), callback, p.state)) | Pending p_callbacks -> let callback = callback_if_deferred () in add_implicitly_removed_callback p_callbacks callback end include Sequential_composition (* This belongs with the [protected] and such, but it depends on primitives from [Sequential_composition]. *) let wrap_in_cancelable p = let Internal p_internal = to_internal_promise p in let p_underlying = underlying p_internal in match p_underlying.state with | Fulfilled _ -> p | Rejected _ -> p | Pending _ -> let p', r = task () in on_cancel p' (fun () -> cancel p); on_any p (wakeup r) (wakeup_exn r); p' module Concurrent_composition : sig val dont_wait : (unit -> _ t) -> (exn -> unit) -> unit val async : (unit -> _ t) -> unit val ignore_result : _ t -> unit val both : 'a t -> 'b t -> ('a * 'b) t val join : unit t list -> unit t val all : ('a t) list -> ('a list) t val choose : 'a t list -> 'a t val pick : 'a t list -> 'a t val nchoose : 'a t list -> 'a list t val npick : 'a t list -> 'a list t val nchoose_split : 'a t list -> ('a list * 'a t list) t end = struct external reraise : exn -> 'a = "%reraise" let dont_wait f h = let p = try f () with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled _ -> () | Rejected exn -> h exn | Pending p_callbacks -> let callback result = match result with | Fulfilled _ -> () | Rejected exn -> h exn in add_implicitly_removed_callback p_callbacks callback let async f = let p = try f () with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled _ -> () | Rejected exn -> !async_exception_hook exn | Pending p_callbacks -> let callback result = match result with | Fulfilled _ -> () | Rejected exn -> !async_exception_hook exn in add_implicitly_removed_callback p_callbacks callback let ignore_result p = let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled _ -> () | Rejected exn -> reraise exn | Pending p_callbacks -> let callback result = match result with | Fulfilled _ -> () | Rejected exn -> !async_exception_hook exn in add_implicitly_removed_callback p_callbacks callback let join ps = let p' = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in let number_pending_in_ps = ref 0 in let join_result = ref (Fulfilled ()) in (* Callback attached to each promise in [ps] that is still pending at the time [join] is called. *) let callback new_result = let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in begin match new_result with | Fulfilled () -> () | Rejected _ -> (* For the first promise in [ps] to be rejected, set the result of the [join] to rejected with the same exception.. *) match !join_result with | Fulfilled () -> join_result := new_result | Rejected _ -> () end; (* In all cases, decrement the number of promises still pending, and resolve the [join] once all promises resolve. *) number_pending_in_ps := !number_pending_in_ps - 1; if !number_pending_in_ps = 0 then begin let p' = underlying p' in let State_may_have_changed p' = resolve ~allow_deferring:false (underlying p') !join_result in ignore p' end in (* Attach the above callback. Simultaneously count how many pending promises there are in [ps] (initially). If that number is zero, the [join] must resolve immediately. *) let rec attach_callback_or_resolve_immediately ps = match ps with | [] -> if !number_pending_in_ps = 0 then to_public_promise {state = !join_result} else to_public_promise p' | p::ps -> let Internal p = to_internal_promise p in match (underlying p).state with | Pending p_callbacks -> number_pending_in_ps := !number_pending_in_ps + 1; add_implicitly_removed_callback p_callbacks callback; attach_callback_or_resolve_immediately ps | Rejected _ as p_result -> (* As in the callback above, but for already-resolved promises in [ps]: reject the [join] with the same exception as in the first rejected promise found. [join] still waits for any pending promises before actually resolving, though. *) begin match !join_result with | Fulfilled () -> join_result := p_result; | Rejected _ -> () end; attach_callback_or_resolve_immediately ps | Fulfilled () -> attach_callback_or_resolve_immediately ps in attach_callback_or_resolve_immediately ps (* this is 3 words, smaller than the 2 times 2 words a pair of references would take. *) type ('a,'b) pair = { mutable x1: 'a option; mutable x2: 'b option; } let both p1 p2 = let pair = {x1 = None; x2 = None} in let p1' = bind p1 (fun v -> pair.x1 <- Some v; return_unit) in let p2' = bind p2 (fun v -> pair.x2 <- Some v; return_unit) in join [p1'; p2'] |> map (fun () -> match pair.x1, pair.x2 with | Some v1, Some v2 -> v1, v2 | _ -> assert false) let all ps = match ps with | [] -> return_nil | [x] -> map (fun y -> [y]) x | [x; y] -> map (fun (x, y) -> [x; y]) (both x y) | _ -> let vs = Array.make (List.length ps) None in ps |> List.mapi (fun index p -> bind p (fun v -> vs.(index) <- Some v; return_unit)) |> join |> map (fun () -> let rec to_list_unopt i acc = if i < 0 then acc else match Array.unsafe_get vs i with | None -> assert false | Some x -> to_list_unopt (i - 1) (x::acc) in to_list_unopt (Array.length vs - 1) []) (* Maintainer's note: the next few functions are helpers for [choose] and [pick]. Perhaps they should be factored into some kind of generic [choose]/[pick] implementation, which may actually be optimal anyway with Flambda. *) let count_resolved_promises_in (ps : 'a t list) = let rec count_and_gather_rejected total rejected ps = match ps with | [] -> Error (total, rejected) | p :: ps -> let Internal q = to_internal_promise p in match (underlying q).state with | Fulfilled _ -> count_and_gather_rejected total rejected ps | Rejected _ -> count_and_gather_rejected (total + 1) (p :: rejected) ps | Pending _ -> count_and_gather_rejected total rejected ps in let rec count_fulfilled total ps = match ps with | [] -> Ok total | p :: ps -> let Internal q = to_internal_promise p in match (underlying q).state with | Fulfilled _ -> count_fulfilled (total + 1) ps | Rejected _ -> count_and_gather_rejected 1 [p] ps | Pending _ -> count_fulfilled total ps in count_fulfilled 0 ps (* Evaluates to the [n]th promise in [ps], among only those promises in [ps] that are resolved. The caller is expected to ensure that there are at least [n] resolved promises in [ps]. *) let rec nth_resolved (ps : 'a t list) (n : int) : 'a t = match ps with | [] -> assert false | p::ps -> let Internal p' = to_internal_promise p in match (underlying p').state with | Pending _ -> nth_resolved ps n | Fulfilled _ -> if n <= 0 then p else nth_resolved ps (n - 1) | Rejected _ -> if n <= 0 then p else nth_resolved ps (n - 1) (* Like [nth_resolved], but cancels all pending promises found while traversing [ps]. *) let rec nth_resolved_and_cancel_pending (ps : 'a t list) (n : int) : 'a t = match ps with | [] -> assert false | p::ps -> let Internal p' = to_internal_promise p in match (underlying p').state with | Pending _ -> cancel p; nth_resolved_and_cancel_pending ps n | Fulfilled _ -> if n <= 0 then (List.iter cancel ps; p) else nth_resolved_and_cancel_pending ps (n - 1) | Rejected _ -> if n <= 0 then (List.iter cancel ps; p) else nth_resolved_and_cancel_pending ps (n - 1) (* The PRNG state is initialized with a constant to make non-IO-based programs deterministic. *) (* Maintainer's note: is this necessary? *) let prng = lazy (Random.State.make [||]) let choose ps = if ps = [] then invalid_arg "Lwt.choose [] would return a promise that is pending forever"; match count_resolved_promises_in ps with | Ok 0 -> let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in let callback result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in let p = underlying p in let State_may_have_changed p = resolve ~allow_deferring:false p result in ignore p in add_explicitly_removable_callback_to_each_of ps callback; to_public_promise p | Ok 1 -> nth_resolved ps 0 | Ok n -> nth_resolved ps (Random.State.int (Lazy.force prng) n) | Error (n, ps) -> nth_resolved ps (Random.State.int (Lazy.force prng) n) let pick ps = if ps = [] then invalid_arg "Lwt.pick [] would return a promise that is pending forever"; match count_resolved_promises_in ps with | Ok 0 -> let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in let callback result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in List.iter cancel ps; let p = underlying p in let State_may_have_changed p = resolve ~allow_deferring:false p result in ignore p in add_explicitly_removable_callback_to_each_of ps callback; to_public_promise p | Ok 1 -> nth_resolved_and_cancel_pending ps 0 | Ok n -> nth_resolved_and_cancel_pending ps (Random.State.int (Lazy.force prng) n) | Error (n, qs) -> List.iter cancel ps; nth_resolved qs (Random.State.int (Lazy.force prng) n) (* If [nchoose ps] or [npick ps] found all promises in [ps] pending, the callback added to each promise in [ps] eventually calls this function. The function collects promises in [ps] that have become fulfilled, or finds one promise in [ps] that has been rejected. It then returns the desired state of the final promise: either the list of results collected, or the exception found. *) let rec collect_fulfilled_promises_after_pending (results : 'a list) (ps : 'a t list) : ('a list resolved_state) = match ps with | [] -> Fulfilled (List.rev results) | p::ps -> let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled v -> collect_fulfilled_promises_after_pending (v::results) ps | Rejected _ as result -> result | Pending _ -> collect_fulfilled_promises_after_pending results ps let nchoose ps = (* If at least one promise in [ps] is found fulfilled, this function is called to find all such promises. *) if ps = [] then invalid_arg "Lwt.nchoose [] would return a promise that is pending forever"; let rec collect_already_fulfilled_promises_or_find_rejected acc ps = match ps with | [] -> return (List.rev acc) | p::ps -> let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled v -> collect_already_fulfilled_promises_or_find_rejected (v::acc) ps | Rejected _ as result -> to_public_promise {state = result} | Pending _ -> collect_already_fulfilled_promises_or_find_rejected acc ps in (* Looks for already-resolved promises in [ps]. If none are fulfilled or rejected, adds a callback to all promises in [ps] (all of which are pending). *) let rec check_for_already_resolved_promises ps' = match ps' with | [] -> let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in let callback _result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in let p = underlying p in let result = collect_fulfilled_promises_after_pending [] ps in let State_may_have_changed p = resolve ~allow_deferring:false p result in ignore p in add_explicitly_removable_callback_to_each_of ps callback; to_public_promise p | p::ps -> let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled v -> collect_already_fulfilled_promises_or_find_rejected [v] ps | Rejected _ as result -> to_public_promise {state = result} | Pending _ -> check_for_already_resolved_promises ps in let p = check_for_already_resolved_promises ps in p (* See [nchoose]. This function differs only in having additional calls to [cancel]. *) let npick ps = if ps = [] then invalid_arg "Lwt.npick [] would return a promise that is pending forever"; let rec collect_already_fulfilled_promises_or_find_rejected acc ps' = match ps' with | [] -> List.iter cancel ps; return (List.rev acc) | p::ps' -> let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled v -> collect_already_fulfilled_promises_or_find_rejected (v::acc) ps' | Rejected _ as result -> List.iter cancel ps; to_public_promise {state = result} | Pending _ -> collect_already_fulfilled_promises_or_find_rejected acc ps' in let rec check_for_already_resolved_promises ps' = match ps' with | [] -> let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in let callback _result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in let p = underlying p in let result = collect_fulfilled_promises_after_pending [] ps in List.iter cancel ps; let State_may_have_changed p = resolve ~allow_deferring:false p result in ignore p in add_explicitly_removable_callback_to_each_of ps callback; to_public_promise p | p::ps' -> let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled v -> collect_already_fulfilled_promises_or_find_rejected [v] ps' | Rejected _ as result -> List.iter cancel ps; to_public_promise {state = result} | Pending _ -> check_for_already_resolved_promises ps' in let p = check_for_already_resolved_promises ps in p (* Same general pattern as [npick] and [nchoose]. *) let nchoose_split ps = if ps = [] then invalid_arg "Lwt.nchoose_split [] would return a promise that is pending forever"; let rec finish (to_resolve : ('a list * 'a t list, underlying, pending) promise) (fulfilled : 'a list) (pending : 'a t list) (ps : 'a t list) : ('a list * 'a t list, underlying, resolved) state_changed = match ps with | [] -> resolve ~allow_deferring:false to_resolve (Fulfilled (List.rev fulfilled, List.rev pending)) | p::ps -> let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with | Fulfilled v -> finish to_resolve (v::fulfilled) pending ps | Rejected _ as result -> resolve ~allow_deferring:false to_resolve result | Pending _ -> finish to_resolve fulfilled (p::pending) ps in let rec collect_already_resolved_promises results pending ps = match ps with | [] -> (* Maintainer's note: should the pending promise list also be reversed? It is reversed in finish. *) return (List.rev results, pending) | p::ps -> let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with | Fulfilled v -> collect_already_resolved_promises (v::results) pending ps | Rejected _ as result -> to_public_promise {state = result} | Pending _ -> collect_already_resolved_promises results (p::pending) ps in let rec check_for_already_resolved_promises pending_acc ps' = match ps' with | [] -> let p = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in let callback _result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in let p = underlying p in let State_may_have_changed p = finish p [] [] ps in ignore p in add_explicitly_removable_callback_to_each_of ps callback; to_public_promise p | p::ps' -> let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with | Fulfilled v -> collect_already_resolved_promises [v] pending_acc ps' | Rejected _ as result -> to_public_promise {state = result} | Pending _ -> check_for_already_resolved_promises (p::pending_acc) ps' in let p = check_for_already_resolved_promises [] ps in p end include Concurrent_composition module Miscellaneous : sig (* Promise state query *) type 'a state = | Return of 'a | Fail of exn | Sleep val state : 'a t -> 'a state val is_sleeping : 'a t -> bool val debug_state_is : 'a state -> 'a t -> bool t (* Function lifters *) val apply : ('a -> 'b t) -> 'a -> 'b t val wrap : (unit -> 'b) -> 'b t val wrap1 : ('a1 -> 'b) -> ('a1 -> 'b t) val wrap2 : ('a1 -> 'a2 -> 'b) -> ('a1 -> 'a2 -> 'b t) val wrap3 : ('a1 -> 'a2 -> 'a3 -> 'b) -> ('a1 -> 'a2 -> 'a3 -> 'b t) val wrap4 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'b) -> ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'b t) val wrap5 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'b) -> ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'b t) val wrap6 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'b) -> ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'b t) val wrap7 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'b) -> ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'b t) (* Paused promises *) val pause : unit -> unit t val wakeup_paused : unit -> unit val paused_count : unit -> int val register_pause_notifier : (int -> unit) -> unit val abandon_paused : unit -> unit (* Internal interface for other modules in Lwt *) val poll : 'a t -> 'a option end = struct type 'a state = | Return of 'a | Fail of exn | Sleep external reraise : exn -> 'a = "%reraise" let state p = let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled v -> Return v | Rejected exn -> Fail exn | Pending _ -> Sleep let debug_state_is expected_state p = return (state p = expected_state) let is_sleeping p = let Internal p = to_internal_promise p in match (underlying p).state with | Fulfilled _ -> false | Rejected _ -> false | Pending _ -> true let poll p = let Internal p = to_internal_promise p in match (underlying p).state with | Rejected e -> reraise e | Fulfilled v -> Some v | Pending _ -> None let apply f x = try f x with exn when Exception_filter.run exn -> fail exn let wrap f = try return (f ()) with exn when Exception_filter.run exn -> fail exn let wrap1 f x1 = try return (f x1) with exn when Exception_filter.run exn -> fail exn let wrap2 f x1 x2 = try return (f x1 x2) with exn when Exception_filter.run exn -> fail exn let wrap3 f x1 x2 x3 = try return (f x1 x2 x3) with exn when Exception_filter.run exn -> fail exn let wrap4 f x1 x2 x3 x4 = try return (f x1 x2 x3 x4) with exn when Exception_filter.run exn -> fail exn let wrap5 f x1 x2 x3 x4 x5 = try return (f x1 x2 x3 x4 x5) with exn when Exception_filter.run exn -> fail exn let wrap6 f x1 x2 x3 x4 x5 x6 = try return (f x1 x2 x3 x4 x5 x6) with exn when Exception_filter.run exn -> fail exn let wrap7 f x1 x2 x3 x4 x5 x6 x7 = try return (f x1 x2 x3 x4 x5 x6 x7) with exn when Exception_filter.run exn -> fail exn let pause_hook = ref ignore let paused = Lwt_sequence.create () let paused_count = ref 0 let pause () = let p = add_task_r paused in incr paused_count; !pause_hook !paused_count; p let wakeup_paused () = if Lwt_sequence.is_empty paused then paused_count := 0 else begin let tmp = Lwt_sequence.create () in Lwt_sequence.transfer_r paused tmp; paused_count := 0; Lwt_sequence.iter_l (fun r -> wakeup r ()) tmp end let register_pause_notifier f = pause_hook := f let abandon_paused () = Lwt_sequence.clear paused; paused_count := 0 let paused_count () = !paused_count end include Miscellaneous module Let_syntax = struct module Let_syntax = struct let return = return let map t ~f = map f t let bind t ~f = bind t f let both = both module Open_on_rhs = struct end end end module Infix = struct let (>>=) = bind let (=<<) f p = bind p f let (>|=) p f = map f p let (=|<) = map let (<&>) p p' = join [p; p'] let () p p' = choose [p; p'] include Let_syntax end include ( Infix : module type of Infix with module Let_syntax := Let_syntax.Let_syntax ) module Syntax = struct let (let*) = bind let (and*) = both let (let+) x f = map f x let (and+) = both end lwt-5.9.1/src/core/lwt.mli000066400000000000000000002256551476253734400154220ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Asynchronous programming with promises. A {b promise} is a placeholder for a single value which might take a long time to compute. Speaking roughly, a promise is a [ref] that can be filled in later. To make that precise, here is how promises differ from [ref]s: - A promise might not have a value yet. A promise in this state is called a {e pending} promise. - Writing a value into a promise is called {e resolving} it. A promise with a value is called a {e resolved} promise. - Each promise can be resolved only once. After a promise has a value, the promise is immutable. - It's possible to attach {b callbacks} to a promise. They will run when the promise has a value, i.e. is resolved. If the promise is already resolved when a callback is attached, the callback is run (almost) right away. If the promise is pending, the callback is put into a list and waits. So, promises are optional, write-once references, and when they don't yet have a value, they store a list of callbacks that are waiting for the value. The waiting callbacks make promises a natural data type for asynchronous programming. For example, you can ask Lwt to [read] a file. Lwt immediately returns you only a {e promise} for the data. You can neglect this promise for a while. You can do some other computation, request more I/O, etc. At some point, you might decide to attach a callback to the [read] promise, maybe several callbacks. In the meantime, the [read] operation is running in the background. Once it finishes, Lwt {e resolves} the [read] promise by putting the data into it. Lwt then runs the callbacks you attached. One of those might take the data, and ask Lwt to [write] it to STDOUT. Lwt gives you a promise for that, too, and the process repeats. Lwt has a small amount of syntactic sugar to make this look as natural as possible: {[ let () = Lwt_main.run begin let%lwt data = Lwt_io.(read_line stdin) in let%lwt () = Lwt_io.printl data in Lwt.return () end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix echo.ml && ./a.out *) ]} This is all explained in the next sections: - {!3_Quickstart} links these concepts to actual functions in Lwt – the most fundamental ones. - {!3_Tutorial} shows how to write examples like the above, and how concurrency happens. - {!3_Executionmodel} clarifies control flow when using Lwt. - {!3_GuidetotherestofLwt} shows how {e everything} else in Lwt fits into this framework. After that is the {{!2_Fundamentals} reference proper}, which goes into {e painful} levels of detail on every single type and value in this module, [Lwt]. Please be safe, and read only what you need from it :) Happy asynchronous programming! {3:3_Quickstart Quick start} {e All} of Lwt is variations on: - {b Promises} of type ['a ]{!Lwt.t} are placeholders for values of type ['a]. - {!Lwt.bind} attaches {b callbacks} to promises. When a promise gets a value, its callbacks are called. - Separate {b resolvers} of type ['a ]{!Lwt.u} are used to write values into promises, through {!Lwt.wakeup_later}. - Promises and resolvers are created in pairs using {!Lwt.wait}. Lwt I/O functions call {!Lwt.wait} internally, but return only the promise. - {!Lwt_main.run} is used to wait on one “top-level” promise. When that promise gets a value, the program terminates. {3:3_Tutorial Tutorial} Let's read from STDIN. The first version is written using ordinary values from the OCaml standard library. This makes the program block until the user enters a line: {[ let () = let line : string = read_line () in print_endline "Now unblocked!"; ignore line (* ocamlfind opt -linkpkg code.ml && ./a.out *) ]} If we use a promise instead, execution continues immediately: {[ let () = let line_promise : string Lwt.t = Lwt_io.(read_line stdin) in print_endline "Execution just continues..."; ignore line_promise (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} Indeed, this program is a little {e too} asynchronous – it exits right away! Let's force it to wait for [line_promise] at the end by calling {!Lwt_main.run}: {[ let () = let line_promise : string Lwt.t = Lwt_io.(read_line stdin) in print_endline "Execution just continues..."; let line : string = Lwt_main.run line_promise in ignore line (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} {!Lwt_main.run} should only be called once, on one promise, at the top level of your program. Most of the time, waiting for promises is done using [let%lwt]. That is the recommended syntactic sugar for {!Lwt.bind}, and is pronounced “bind”: {[ let () = let p : unit Lwt.t = let%lwt line_1 = Lwt_io.(read_line stdin) in let%lwt line_2 = Lwt_io.(read_line stdin) in Lwt_io.printf "%s and %s\n" line_1 line_2 in Lwt_main.run p (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} The way that works is everything in scope after the “[in]” in “[let%lwt x =] ... [in] ...” goes into a callback, and “[x]” is that callback's argument. So, we could have been very explicit, and written the code like this: {[ let () = let p : unit Lwt.t = let line_1_promise : string Lwt.t = Lwt_io.(read_line stdin) in Lwt.bind line_1_promise (fun (line_1 : string) -> let line_2_promise : string Lwt.t = Lwt_io.(read_line stdin) in Lwt.bind line_2_promise (fun (line_2 : string) -> Lwt_io.printf "%s and %s\n" line_1 line_2)) in Lwt_main.run p (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} But, as you can see, this is verbose, and the indentation gets a bit crazy. So, we will always use [let%lwt]. The code above reads two lines in sequence, because we ask Lwt to wait for [line_1], before calling the second {!Lwt_io.read_line} in the callback, to start the second I/O. We could also run I/O {e concurrently}. All we have to do is not start the second I/O in a callback of the first. Because it doesn't make sense to read two lines from STDIN concurrently, let's start two waits instead: {[ let () = Lwt_main.run begin let three_seconds : unit Lwt.t = Lwt_unix.sleep 3. in let five_seconds : unit Lwt.t = Lwt_unix.sleep 5. in let%lwt () = three_seconds in let%lwt () = Lwt_io.printl "3 seconds passed" in let%lwt () = five_seconds in Lwt_io.printl "Only 2 more seconds passed" end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} This program takes about five seconds to run. We are still new to [let%lwt], so let's desugar it: {[ let () = Lwt_main.run begin let three_seconds : unit Lwt.t = Lwt_unix.sleep 3. in let five_seconds : unit Lwt.t = Lwt_unix.sleep 5. in (* Both waits have already been started at this point! *) Lwt.bind three_seconds (fun () -> (* This is 3 seconds later. *) Lwt.bind (Lwt_io.printl "3 seconds passed") (fun () -> Lwt.bind five_seconds (fun () -> (* Only 2 seconds were left in the 5-second wait, so this callback runs 2 seconds after the first callback. *) Lwt_io.printl "Only 2 more seconds passed"))) end (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} And that's it! Concurrency in Lwt is simply a matter of whether you start an operation in the callback of another one or not. As a convenience, Lwt provides a few {{!2_Concurrency} helpers} for common concurrency patterns. {3:3_Executionmodel Execution model} It's important to understand that promises are a pure-OCaml data type. They don't do any fancy scheduling or I/O. They are just lists of callbacks (if pending), or containers for one value (if resolved). The interesting function is {!Lwt_main.run}. It's a wrapper around {{: https://man7.org/linux/man-pages/man2/select.2.html} [select(2)]}, {{: https://man7.org/linux/man-pages/man7/epoll.7.html} [epoll(7)]}, {{: https://man.freebsd.org/cgi/man.cgi?query=kqueue&sektion=2} [kqueue(2)]}, or whatever asynchronous I/O API your system provides. On browsers, the work of {!Lwt_main.run} is done by the surrounding JavaScript engine, so you don't call {!Lwt_main.run} from inside your program. But the execution model is still the same, and the description below applies! To avoid writing out “underlying asynchronous I/O API,” we'll assume, in this section, that the API is [select(2)]. That's just for the sake of abbreviation. It doesn't actually matter, for most purposes, what the underlying I/O API is. Let's use the program from the tutorial that reads two lines as an example. Here it is, again, in its desugared form: {[ let () = let p : unit Lwt.t = let line_1_promise : string Lwt.t = Lwt_io.(read_line stdin) in Lwt.bind line_1_promise (fun (line_1 : string) -> let line_2_promise : string Lwt.t = Lwt_io.(read_line stdin) in Lwt.bind line_2_promise (fun (line_2 : string) -> Lwt_io.printf "%s and %s\n" line_1 line_2)) in Lwt_main.run p (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} {!Lwt_main.run} is your program's main I/O loop. You pass it a single promise, and it: + Uses [select(2)] to put your process to sleep until the next I/O completes. + That next I/O happens to be the one that reads [line_1]. {!Lwt_main.run} knows that I/O is supposed to resolve [line_1_promise], so it puts [line_1] into the promise and resolves it. + Resolving is an ordinary OCaml operation. It causes all the callbacks of [line_1_promise] to run, one after another. Each callback is also ordinary OCaml code. In our case, there is only one callback, but in general, there might be several, and they might also resolve additional promises. So, promise resolution triggers a “cascade” of callbacks. Eventually, however, we should run out of callbacks, and control will return to {!Lwt_main.run}. + In our example, our one callback registers a second I/O with {!Lwt_main.run} – the one that will read [line_2]. There are no callbacks left to run after that, so control returns to {!Lwt_main.run}. + {!Lwt_main.run} goes back to sleep again by calling [select(2)], now waiting for the second I/O that we just registered. The loop repeats itself from step 1. This has two major implications, one good and one bad. Let's start with the bad one. {b (1)} If one of your callbacks enters an infinite loop, calls an Lwt-unfriendly blocking I/O, or just runs for a really long time, it won't return control to {!Lwt_main.run} anytime soon. That means {!Lwt_main.run} won't get a chance to resolve any other Lwt I/O promises, even if the underlying I/O operations complete. In case your callback is just using the CPU for a really long time, you can insert a few calls to {!Lwt.pause} into it, and resume your computation in callbacks of [pause]. This is basically the same as {!Lwt_unix.sleep}[ 0.] – it's a promise that will be resolved by {!Lwt_main.run} {e after} any other I/O resolutions that are already in its queue. {b (2)} The good implication is that all your callbacks run in a single thread. This means that in most situations, you don't have to worry about locks, synchronization, etc. Anything that is in the same callback is guaranteed to run without interruption. Lwt programs are often {e much} easier to write and refactor, than equivalent programs written with threads – but both are concurrent! {3:3_GuidetotherestofLwt Guide to the rest of Lwt} This module [Lwt] is the pure-OCaml definition of promises and callback-calling. It has a few extras on top of what's described above: - {!2_Rejection}. Lwt promises can actually be resolved in two ways: {e fulfilled} with a value, or {e rejected} with an exception. There is nothing conceptually special about rejection – it's just that you can ask for callbacks to run only on fulfillment, only on rejection, etc. - {!2_Cancellation}. This is a special case of rejection, specifically with exception {!Lwt.Canceled}. It has extra helpers in the Lwt API. - {{!2_Concurrency} Concurrency helpers}. All of these could be implemented on top of {!Lwt.bind}. As we saw, Lwt concurrency requires only deciding whether to run something inside a callback, or outside it. These functions just implement common patterns, and make intent explicit. - Miscellaneous {{!2_Convenience} helpers}, and {{!2_Deprecated} deprecated} APIs. The next layer above module [Lwt] is the pure-OCaml Lwt “core” library, which provides some promise-friendly patterns, like streams and mvars. This consists of the modules {!Lwt_list}, {!Lwt_stream}, {!Lwt_result}, {!Lwt_mutex}, {!Lwt_condition}, {!Lwt_mvar}, {!Lwt_pool}, and {!Lwt_switch}. Above that is the Lwt Unix binding, where I/O begins. This includes the module {!Lwt_main}, including the all-important {!Lwt_main.run}. The rest of the Unix binding consists of functions, each one of which... - ...starts a background I/O operation, - creates a promise for it and gives it to you, - registers with {!Lwt_main.run}, so if you attach callbacks to the promise, they will be called when the I/O operation completes. The functions are grouped into modules: - {!Lwt_unix} for Unix system calls. - {!Lwt_bytes} for Unix system calls on bigarrays. - {!Lwt_io} for [Stdlib]-like high-level channels, TCP servers, etc. - {!Lwt_process} for managing subprocesses. - {!Lwt_preemptive} for spawning system threads. - Miscellaneous modules {!Lwt_gc}, {!Lwt_engine}, {!Lwt_throttle}, {!Lwt_timeout}, {!Lwt_sys}. Warning! Introductory material ends and detailed reference begins! *) (** {2:2_Fundamentals Fundamentals} *) (** {3 Promises} *) type +'a t (** Promises for values of type ['a]. A {b promise} is a memory cell that is always in one of three {b states}: - {e fulfilled}, and containing one value of type ['a], - {e rejected}, and containing one exception, or - {e pending}, in which case it may become fulfilled or rejected later. A {e resolved} promise is one that is either fulfilled or rejected, i.e. not pending. Once a promise is resolved, its content cannot change. So, promises are {e write-once references}. The only possible state changes are (1) from pending to fulfilled and (2) from pending to rejected. Promises are typically “read” by attaching {b callbacks} to them. The most basic functions for that are {!Lwt.bind}, which attaches a callback that is called when a promise becomes fulfilled, and {!Lwt.catch}, for rejection. Promise variables of this type, ['a Lwt.t], are actually {b read-only} in Lwt. Separate {e resolvers} of type ['a ]{!Lwt.u} are used to write to them. Promises and their resolvers are created together by calling {!Lwt.wait}. There is one exception to this: most promises can be {e canceled} by calling {!Lwt.cancel}, without going through a resolver. *) type -'a u (** Resolvers for promises of type ['a ]{!Lwt.t}. Each resolver can be thought of as the {b write end} of one promise. It can be passed to {!Lwt.wakeup_later}, {!Lwt.wakeup_later_exn}, or {!Lwt.wakeup_later_result} to resolve that promise. *) val wait : unit -> ('a t * 'a u) (** Creates a new pending {{!t} promise}, paired with its {{!u} resolver}. It is rare to use this function directly. Many helpers in Lwt, and Lwt-aware libraries, call it internally, and return only the promise. You then chain the promises together using {!Lwt.bind}. However, it is important to understand [Lwt.wait] as the fundamental promise “constructor.” All other functions that evaluate to a promise can be, or are, eventually implemented in terms of it. *) (** {3 Resolving} *) val wakeup_later : 'a u -> 'a -> unit (** [Lwt.wakeup_later r v] {e fulfills}, with value [v], the {e pending} {{!t} promise} associated with {{!u} resolver} [r]. This triggers callbacks attached to the promise. If the promise is not pending, [Lwt.wakeup_later] raises {!Stdlib.Invalid_argument}, unless the promise is {{!Lwt.cancel} canceled}. If the promise is canceled, [Lwt.wakeup_later] has no effect. If your program has multiple threads, it is important to make sure that [Lwt.wakeup_later] (and any similar function) is only called from the main thread. [Lwt.wakeup_later] can trigger callbacks attached to promises by the program, and these assume they are running in the main thread. If you need to communicate from a worker thread to the main thread running Lwt, see {!Lwt_preemptive} or {!Lwt_unix.send_notification}. *) val wakeup_later_exn : _ u -> exn -> unit (** [Lwt.wakeup_later_exn r exn] is like {!Lwt.wakeup_later}, except, if the associated {{!t} promise} is {e pending}, it is {e rejected} with [exn]. *) val return : 'a -> 'a t (** [Lwt.return v] creates a new {{!t} promise} that is {e already fulfilled} with value [v]. This is needed to satisfy the type system in some cases. For example, in a [match] expression where one case evaluates to a promise, the other cases have to evaluate to promises as well: {[ match need_input with | true -> Lwt_io.(read_line stdin) (* Has type string Lwt.t... *) | false -> Lwt.return "" (* ...so wrap empty string in a promise. *) ]} Another typical usage is in {{!Lwt.bind} [let%lwt]}. The expression after the “[in]” has to evaluate to a promise. So, if you compute an ordinary value instead, you have to wrap it: {[ let%lwt line = Lwt_io.(read_line stdin) in Lwt.return (line ^ ".") ]} *) val fail : exn -> _ t (** [Lwt.fail exn] is like {!Lwt.return}, except the new {{!t} promise} that is {e already rejected} with [exn]. Whenever possible, it is recommended to use [raise exn] instead, as [raise] captures a backtrace, while [Lwt.fail] does not. If you call [raise exn] in a callback that is expected by Lwt to return a promise, Lwt will automatically wrap [exn] in a rejected promise, but the backtrace will have been recorded by the OCaml runtime. For example, [bind]'s second argument is a callback which returns a promise. And so it is recommended to use [raise] in the body of that callback. This applies to the aliases of [bind] as well: [( >>= )] and [( let* )]. Use [Lwt.fail] only when you specifically want to create a rejected promise, to pass to another function, or store in a data structure. *) (** {3 Callbacks} *) val bind : 'a t -> ('a -> 'b t) -> 'b t (** [Lwt.bind p_1 f] makes it so that [f] will run when [p_1] is {{!t} {e fulfilled}}. When [p_1] is fulfilled with value [v_1], the callback [f] is called with that same value [v_1]. Eventually, after perhaps starting some I/O or other computation, [f] returns promise [p_2]. [Lwt.bind] itself returns immediately. It only attaches the callback [f] to [p_1] – it does not wait for [p_2]. {e What} [Lwt.bind] returns is yet a third promise, [p_3]. Roughly speaking, fulfillment of [p_3] represents both [p_1] and [p_2] becoming fulfilled, one after the other. A minimal example of this is an echo program: {[ let () = let p_3 = Lwt.bind Lwt_io.(read_line stdin) (fun line -> Lwt_io.printl line) in Lwt_main.run p_3 (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} Rejection of [p_1] and [p_2], and raising an exception in [f], are all forwarded to rejection of [p_3]. {b Precise behavior} [Lwt.bind] returns a promise [p_3] immediately. [p_3] starts out pending, and is resolved as follows: - The first condition to wait for is that [p_1] becomes resolved. It does not matter whether [p_1] is already resolved when [Lwt.bind] is called, or becomes resolved later – the rest of the behavior is the same. - If and when [p_1] becomes resolved, it will, by definition, be either fulfilled or rejected. - If [p_1] is rejected, [p_3] is rejected with the same exception. - If [p_1] is fulfilled, with value [v], [f] is applied to [v]. - [f] may finish by returning the promise [p_2], or raising an exception. - If [f] raises an exception, [p_3] is rejected with that exception. - Finally, the remaining case is when [f] returns [p_2]. From that point on, [p_3] is effectively made into a reference to [p_2]. This means they have the same state, undergo the same state changes, and performing any operation on one is equivalent to performing it on the other. {b Syntactic sugar} [Lwt.bind] is almost never written directly, because sequences of [Lwt.bind] result in growing indentation and many parentheses: {[ let () = Lwt_main.run begin Lwt.bind Lwt_io.(read_line stdin) (fun line -> Lwt.bind (Lwt_unix.sleep 1.) (fun () -> Lwt_io.printf "One second ago, you entered %s\n" line)) end (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} The recommended way to write [Lwt.bind] is using the [let%lwt] syntactic sugar: {[ let () = Lwt_main.run begin let%lwt line = Lwt_io.(read_line stdin) in let%lwt () = Lwt_unix.sleep 1. in Lwt_io.printf "One second ago, you entered %s\n" line end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} This uses the Lwt {{: Ppx_lwt.html} PPX} (preprocessor). Note that we had to add package [lwt_ppx] to the command line for building this program. We will do that throughout this manual. Another way to write [Lwt.bind], that you may encounter while reading code, is with the [>>=] operator: {[ open Lwt.Infix let () = Lwt_main.run begin Lwt_io.(read_line stdin) >>= fun line -> Lwt_unix.sleep 1. >>= fun () -> Lwt_io.printf "One second ago, you entered %s\n" line end (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} The [>>=] operator comes from the module {!Lwt.Infix}, which is why we opened it at the beginning of the program. See also {!Lwt.map}. *) (** {2:2_Rejection Rejection} *) external reraise : exn -> 'a = "%reraise" (** [reraise e] raises the exception [e]. Unlike [raise e], [reraise e] preserves the existing exception backtrace and even adds a "Re-raised at" entry with the call location. This function is intended to be used in the exception handlers of [Lwt.catch] and [Lwt.try_bind]. It is also used in the code produced by Lwt_ppx. *) val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t (** [Lwt.catch f h] applies [f ()], which returns a promise, and then makes it so that [h] (“handler”) will run when that promise is {{!t} {e rejected}}. {[ let () = Lwt_main.run begin Lwt.catch (fun () -> raise Exit) (function | Exit -> Lwt_io.printl "Got Stdlib.Exit" | exn -> Lwt.reraise exn) end (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} Despite the above code, the recommended way to write [Lwt.catch] is using the [try%lwt] syntactic sugar from the {{: Ppx_lwt.html} PPX}. Here is an equivalent example: {[ let () = Lwt_main.run begin try%lwt raise Exit with Exit -> Lwt_io.printl "Got Stdlb.Exit" end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} A particular advantage of the PPX syntax is that it is not necessary to artificially insert a catch-all [exn -> reraise exn] case. Like in the core language's [try] expression, the catch-all case is implied in [try%lwt]. [Lwt.catch] is a counterpart to {!Lwt.bind} – {!Lwt.bind} is for fulfillment, and {!Lwt.catch} is for rejection. As with {!Lwt.bind}, three promises are involved: - [p_1], the promise returned from applying [f ()]. - [p_2], the promise returned from applying [h exn]. - [p_3], the promise returned by [Lwt.catch] itself. The remainder is (1) a precise description of how [p_3] is resolved, and (2) a warning about accidentally using ordinary [try] for exception handling in asynchronous code. {b (1)} [Lwt.catch] first applies [f ()]. It then returns [p_3] immediately. [p_3] starts out pending. It is resolved as follows: - If [f ()] returned a promise [p_1], and [p_1] becomes fulfilled, [p_3] is fulfilled with the same value. - [p_1] can instead become rejected. There is one other possibility: [f ()] itself raised an exception, instead of returning a promise. The behavior of [Lwt.catch] is the same whether [f ()] raised an exception, or returned a promise that is later rejected with an exception. Let's call the exception [exn]. - [h exn] is applied. - [h exn] may return a promise, or might itself raise an exception. The first case is the interesting one, but the exception case is simple, so we cover the exception case first. - If [h exn] raises another exception [exn'], [p_3] is rejected with [exn']. - If [h exn] instead returns the promise [p_2], [p_3] is effectively made into a reference to [p_2]. This means [p_3] and [p_2] have the same state, undergo the same state changes, and performing any operation one is equivalent to performing it on the other. *) val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t (** [Lwt.finalize f c] applies [f ()], which returns a promise, and then makes it so [c] (“cleanup”) will run when that promise is {{!t} {e resolved}}. In other words, [c] runs no matter whether promise [f ()] is fulfilled or rejected. As the names suggest, [Lwt.finalize] corresponds to the [finally] construct found in many programming languages, and [c] is typically used for cleaning up resources: {[ let () = Lwt_main.run begin let%lwt file = Lwt_io.(open_file ~mode:Input "code.ml") in Lwt.finalize (fun () -> let%lwt content = Lwt_io.read file in Lwt_io.print content) (fun () -> Lwt_io.close file) end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} As with {!Lwt.bind} and {!Lwt.catch}, there is a syntactic sugar for [Lwt.finalize], though it is not as often used: {[ let () = Lwt_main.run begin let%lwt file = Lwt_io.(open_file ~mode:Input "code.ml") in begin let%lwt content = Lwt_io.read file in Lwt_io.print content end [%lwt.finally Lwt_io.close file] end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} Also as with {!Lwt.bind} and {!Lwt.catch}, three promises are involved: - [p_1], the promise returned from applying [f ()]. - [p_2], the promise returned from applying [c ()]. - [p_3], the promise returned by [Lwt.finalize] itself. [p_3] is returned immediately. It starts out pending, and is resolved as follows: - [f ()] is applied. If it finishes, it will either return a promise [p_1], or raise an exception. - If [f ()] raises an exception, [p_1] is created artificially as a promise rejected with that exception. So, no matter how [f ()] finishes, there is a promise [p_1] representing the outcome. - After [p_1] is resolved (fulfilled or rejected), [c ()] is applied. This is meant to be the cleanup code. - If [c ()] finishes, it will also either return a promise, [p_2], or raise an exception. - If [c ()] raises an exception, [p_2] is created artificially as a promise rejected with that exception. Again, no matter how [c ()] finishes, there is a promise [p_2] representing the outcome of cleanup. - If [p_2] is fulfilled, [p_3] is resolved the same way [p_1] had been resolved. In other words, [p_1] is forwarded to [p_3] when cleanup is successful. - If [p_2] is rejected, [p_3] is rejected with the same exception. In other words, [p_2] is forwarded to [p_3] when cleanup is unsuccessful. Note this means that if {e both} the protected code and the cleanup fail, the cleanup exception has precedence. *) val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t (** [Lwt.try_bind f g h] applies [f ()], and then makes it so that: - [g] will run when promise [f ()] is {{!t} {e fulfilled}}, - [h] will run when promise [f ()] is {{!t} {e rejected}}. [Lwt.try_bind] is a generalized {!Lwt.finalize}. The difference is that [Lwt.try_bind] runs different callbacks depending on {e how} [f ()] is resolved. This has two main implications: - The cleanup functions [g] and [h] each “know” whether [f ()] was fulfilled or rejected. - The cleanup functions [g] and [h] are passed the value [f ()] was fulfilled with, and, respectively, the exception [f ()] was rejected with. As with {!Lwt.catch}, it is recommended to use {!reraise} in the catch-all case of the exception handler: {[ let () = Lwt_main.run begin Lwt.try_bind (fun () -> raise Exit) (fun () -> Lwt_io.printl "Got Success") (function | Exit -> Lwt_io.printl "Got Stdlib.Exit" | exn -> Lwt.reraise exn) end (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} The rest is a detailed description of the promises involved. As with {!Lwt.finalize} and the several preceding functions, three promises are involved. - [p_1] is the promise returned from applying [f ()]. - [p_2] is the promise returned from applying [h] or [g], depending on which one is chosen. - [p_3] is the promise returned by [Lwt.try_bind] itself. [Lwt.try_bind] returns [p_3] immediately. [p_3] starts out pending, and is resolved as follows: - [f ()] is applied. If it finishes, it either returns [p_1], or raises an exception. - If [f ()] raises an exception, [p_1] is created artificially as a promise rejected with that exception. So, no matter how [f ()] finishes, there is a promise [p_1] representing the outcome. - If [p_1] is fulfilled, [g] is applied to the value [p_1] is fulfilled with. - If [p_1] is rejected, [h] is applied to the exception [p_1] is rejected with. - So, in either case, a callback is applied. The rest of the procedure is the same no matter which callback was chosen, so we will refer to it as “the callback.” - If the callback finishes, it either returns [p_2], or raises an exception. - If the callback raises an exception, [p_3] is rejected with that exception. - If the callback returns [p_2], [p_3] is effectively made into an reference to [p_2]. They have the same state, including any state changes, and performing any operation on one is equivalent to performing it on the other. *) val dont_wait : (unit -> unit t) -> (exn -> unit) -> unit (** [Lwt.dont_wait f handler] applies [f ()], which returns a promise, and then makes it so that if the promise is {{!t} {e rejected}}, the exception is passed to [handler]. In addition, if [f ()] raises an exception, it is also passed to [handler]. As the name implies, [dont_wait (fun () -> ) handler] is a way to evaluate the expression [] (which typically has asynchronous side-effects) {e without waiting} for the resolution of the promise [] evaluates to. [dont_wait] is meant as an alternative to {!async} with a local, explicit, predictable exception handler. Note that [dont_wait f h] causes [f ()] to be evaluated immediately. Consequently, the non-yielding/non-pausing prefix of the body of [f] is evaluated immediately. *) val async : (unit -> unit t) -> unit (** [Lwt.async f] applies [f ()], which returns a promise, and then makes it so that if the promise is {{!t} {e rejected}}, the exception is passed to [!]{!Lwt.async_exception_hook}. In addition, if [f ()] raises an exception, it is also passed to [!]{!Lwt.async_exception_hook}. [!]{!Lwt.async_exception_hook} typically prints an error message and terminates the program. If you need a similar behaviour with a different exception handler, you can use {!Lwt.dont_wait}. [Lwt.async] is misleadingly named. Itself, it has nothing to do with asynchronous execution. It's actually a safety function for making Lwt programs more debuggable. For example, take this program, which prints messages in a loop, while waiting for one line of user input: {[ let () = let rec show_nag () : _ Lwt.t = let%lwt () = Lwt_io.printl "Please enter a line" in let%lwt () = Lwt_unix.sleep 1. in show_nag () in ignore (show_nag ()); (* Bad – see note for (1)! *) Lwt_main.run begin let%lwt line = Lwt_io.(read_line stdin) in Lwt_io.printl line end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} If one of the I/O operations in [show_nag] were to fail, the promise representing the whole loop would get rejected. However, since we are ignoring that promise at {b (1)}, we never find out about the rejection. If this failure and resulting rejection represents a bug in the program, we have a harder time finding out about the bug. A safer version differs only in using [Lwt.async] instead of [Stdlib.ignore]: {[ let () = let rec show_nag () : _ Lwt.t = let%lwt () = Lwt_io.printl "Please enter a line" in let%lwt () = Lwt_unix.sleep 1. in show_nag () in Lwt.async (fun () -> show_nag ()); Lwt_main.run begin let%lwt line = Lwt_io.(read_line stdin) in Lwt_io.printl line end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} In this version, if I/O in [show_nag] fails with an exception, the exception is printed by [Lwt.async], and then the program exits. The general rule for when to use [Lwt.async] is: - Promises which are {e not} passed {e to} {!Lwt.bind}, {!Lwt.catch}, {!Lwt.join}, etc., are {b top-level} promises. - One top-level promise is passed to {!Lwt_main.run}, as can be seen in most examples in this manual. - Every other top-level promise should be wrapped in [Lwt.async]. *) val async_exception_hook : (exn -> unit) ref (** Reference to a function, to be called on an "unhandled" exception. This reference is used by {!Lwt.async}, {!Lwt.on_cancel}, {!Lwt.on_success}, {!Lwt.on_failure}, {!Lwt.on_termination}, {!Lwt.on_any}, {!Lwt_react.of_stream}, and the deprecated {!Lwt.ignore_result}. The initial, default implementation prints the exception, then terminates the process with non-zero exit status, as if the exception had reached the top level of the program: {[ let () = Lwt.async (fun () -> raise Exit) (* ocamlfind opt -linkpkg -package lwt code.ml && ./a.out *) ]} produces in the output: {v Fatal error: exception Stdlib.Exit v} If you are writing an application, you are welcome to reassign the reference, and replace the function with something more appropriate for your needs. If you are writing a library, you should leave this reference alone. Its behavior should be determined by the application. *) (** {2:2_Concurrency Concurrency} *) (** {3 Multiple wait} *) val both : 'a t -> 'b t -> ('a * 'b) t (** [Lwt.both p_1 p_2] returns a promise that is pending until {e both} promises [p_1] and [p_2] become {{!t} {e resolved}}. {[ let () = let p_1 = let%lwt () = Lwt_unix.sleep 3. in Lwt_io.printl "Three seconds elapsed" in let p_2 = let%lwt () = Lwt_unix.sleep 5. in Lwt_io.printl "Five seconds elapsed" in let p_3 = Lwt.both p_1 p_2 in Lwt_main.run p_3 (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} If both [p_1] and [p_2] become fulfilled, [Lwt.both p_1 p_2] is also fulfilled, with the pair of their final values. Otherwise, if at least one of the two promises becomes rejected, [Lwt.both p_1 p_2] is rejected with the same exception as one such promise, chosen arbitrarily. Note that this occurs only after both promises are resolved, not immediately when the first promise is rejected. @since 4.2.0 *) val join : (unit t) list -> unit t (** [Lwt.join ps] returns a promise that is pending until {e all} promises in the list [ps] become {{!t} {e resolved}}. {[ let () = let p_1 = let%lwt () = Lwt_unix.sleep 3. in Lwt_io.printl "Three seconds elapsed" in let p_2 = let%lwt () = Lwt_unix.sleep 5. in Lwt_io.printl "Five seconds elapsed" in let p_3 = Lwt.join [p_1; p_2] in Lwt_main.run p_3 (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} If all of the promises in [ps] become fulfilled, [Lwt.join ps] is also fulfilled. Otherwise, if at least one promise in [ps] becomes rejected, [Lwt.join ps] is rejected with the same exception as one such promise, chosen arbitrarily. Note that this occurs only after all the promises are resolved, not immediately when the first promise is rejected. *) val all : ('a t) list -> ('a list) t (** [Lwt.all ps] is like {!Lwt.join}[ ps]: it waits for all promises in the list [ps] to become {{!t} {e resolved}}. It then resolves the returned promise with the list of all resulting values. Note that if any of the promises in [ps] is rejected, the returned promise is also rejected. This means that none of the values will be available, even if some of the promises in [ps] were already resolved when one of them is rejected. For more fine-grained handling of rejection, structure the program with {!Lwt_stream} or {!Lwt_list}, handle rejections explicitly, or use {!Lwt.join} and collect values manually. @since 5.1.0 *) (** {3 Racing} *) val pick : ('a t) list -> 'a t (** [Lwt.pick ps] returns a promise that is pending until {e one} promise in the list [ps] becomes {{!t} {e resolved}}. When at least one promise in [ps] is resolved, [Lwt.pick] tries to cancel all other promises that are still pending, using {!Lwt.cancel}. {[ let () = let echo = let%lwt line = Lwt_io.(read_line stdin) in Lwt_io.printl line in let timeout = Lwt_unix.sleep 5. in Lwt_main.run (Lwt.pick [echo; timeout]) (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} If the first promise in [ps] to become resolved is fulfilled, the result promise [p] is also fulfilled, with the same value. Likewise, if the first promise in [ps] to become resolved is rejected, [p] is rejected with the same exception. If [ps] has no promises (if it is the empty list), [Lwt.pick ps] raises [Stdlib.Invalid_argument _]. It's possible for multiple promises in [ps] to become resolved simultaneously. This happens most often when some promises [ps] are already resolved at the time [Lwt.pick] is called. In that case, if at least one of the promises is rejected, the result promise [p] is rejected with the same exception as one such promise, chosen arbitrarily. If all promises are fulfilled, [p] is fulfilled with the value of one of the promises, also chosen arbitrarily. The remaining functions in this section are variations on [Lwt.pick]. *) val choose : ('a t) list -> 'a t (** [Lwt.choose ps] is the same as {!Lwt.pick}[ ps], except that it does not try to cancel pending promises in [ps]. *) val npick : ('a t) list -> ('a list) t (** [Lwt.npick ps] is similar to {!Lwt.pick}[ ps], the difference being that when multiple promises in [ps] are fulfilled simultaneously (and none are rejected), the result promise is fulfilled with the {e list} of values the promises were fulfilled with. When at least one promise is rejected, [Lwt.npick] still rejects the result promise with the same exception. *) val nchoose : ('a t) list -> ('a list) t (** [Lwt.nchoose ps] is the same as {!Lwt.npick}[ ps], except that it does not try to cancel pending promises in [ps]. *) val nchoose_split : ('a t) list -> ('a list * ('a t) list) t (** [Lwt.nchoose_split ps] is the same as {!Lwt.nchoose}[ ps], except that when multiple promises in [ps] are fulfilled simultaneously (and none are rejected), the result promise is fulfilled with {e both} the list of values of the fulfilled promises, and the list of promises that are still pending. *) (** {2:2_Cancellation Cancellation} Note: cancelation has proved difficult to understand, explain, and maintain, so use of these functions is discouraged in new code. See {{:https://github.com/ocsigen/lwt/issues/283#issuecomment-518014539} ocsigen/lwt#283}. *) exception Canceled (** Canceled promises are those rejected with this exception, [Lwt.Canceled]. See {!Lwt.cancel}. *) val task : unit -> ('a t * 'a u) (** [Lwt.task] is the same as {!Lwt.wait}, except the resulting promise [p] is {{!Lwt.cancel} cancelable}. This is significant, because it means promises created by [Lwt.task] can be resolved (specifically, rejected) by canceling them directly, in addition to being resolved through their paired resolvers. In contrast, promises returned by {!Lwt.wait} can only be resolved through their resolvers. *) val cancel : _ t -> unit (** [Lwt.cancel p] attempts to {e cancel} the pending promise [p], without needing access to its resolver. It is recommended to avoid [Lwt.cancel], and handle cancelation by tracking the needed extra state explicitly within your library or application. A {b canceled} promise is one that has been rejected with exception {!Lwt.Canceled}. There are straightforward ways to make promises canceled. One could create a promise that {e starts out} canceled, with {!Lwt.fail}[ Lwt.Canceled]. It's also possible to {e make} a promise canceled through its resolver, by calling {!Lwt.wakeup_later_exn}[ r Lwt.Canceled]. This function, [Lwt.cancel], provides another method, which can cancel pending promises {e without} going through their resolvers – it acts directly on promises. Like any other promise rejection, the canceled state of a promise is propagated “forwards” by {!Lwt.bind}, {!Lwt.join}, etc., as described in the documentation of those functions. {b Cancellation} is a separate phase, triggered only by {!Lwt.cancel}, that searches {e backwards}, strating from [p], for promises to reject with {!Lwt.Canceled}. Once those promises are found, they are canceled, and then ordinary, forwards rejection propagation takes over. All of this will be made precise, but first let's have an example: {[ let () = let p = let%lwt () = Lwt_unix.sleep 5. in Lwt_io.printl "Slept five seconds" in Lwt.cancel p; Lwt_main.run p (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} At the time [Lwt.cancel] is called, [p] “depends” on the [sleep] promise (the [printl] is not yet called, so its promise hasn't been created). So, {!Lwt.cancel} recursively tries to cancel the [sleep] promise. That is an example of the backwards search. The [sleep] promise is a pending promise that doesn't depend on anything, so backwards search stops at it. The state of the [sleep] promise is set to {e rejected} with {!Lwt.Canceled}. {!Lwt.bind} then propagates the rejection forwards to [p], so [p] also becomes canceled. Eventually, this rejection reaches {!Lwt_main.run}, which raises the {!Lwt.Canceled} as an ordinary exception. The [sleep] does not complete, and the [printl] is never started. Promises, like the [sleep] promise above, that can be rejected by [Lwt.cancel] are {b cancelable}. Most promises in Lwt are either cancelable, or depend on cancelable promises. The functions {!Lwt.wait} and {!Lwt.no_cancel} create promises that are {e not} cancelable. The rest is a detailed description of how the [Lwt.cancel] backwards search works. - If [p] is already resolved, [Lwt.cancel] does nothing. - If [p] was created by {!Lwt.wait} or {!Lwt.no_cancel}, [Lwt.cancel] does nothing. - If [p] was created by {!Lwt.task} or {!Lwt.protected}, [Lwt.cancel] rejects it with [Lwt.Canceled]. This rejection then propagates normally through any Lwt calls that depend on [p]. Most I/O promises are internally created by calling {!Lwt.task}. - Suppose [p_3] was returned by {!Lwt.bind}, {!Lwt.map}, {!Lwt.catch}, {!Lwt.finalize}, or {!Lwt.try_bind}. Then, see those functions for the naming of the other promises involved. If [p_3] is pending, then either [p_1] is pending, or [p_2] is pending. [Lwt.cancel p_3] then tries recursively to cancel whichever of these two is still pending. If that succeeds, [p_3] {e may} be canceled later by the normal propagation of rejection. - Suppose [p] was returned by {!Lwt.join}, {!Lwt.pick}, or similar function, which was applied to the promise list [ps]. {!Lwt.cancel} then recursively tries to cancel each promise in [ps]. If one of those cancellations succeeds, [p] {e may} be canceled later by the normal propagation of rejection. *) val on_cancel : _ t -> (unit -> unit) -> unit (** [Lwt.on_cancel p f] makes it so that [f] will run when [p] becomes {{: #EXCEPTIONCanceled} {e canceled}}. Callbacks scheduled with [on_cancel] are guaranteed to run before any other callbacks that are triggered by rejection, such as those added by {!Lwt.catch}. Note that this does not interact directly with the {e cancellation} mechanism, the backwards search described in {!Lwt.cancel}. For example, manually rejecting a promise with {!Lwt.Canceled} is sufficient to trigger [f]. [f] should not raise exceptions. If it does, they are passed to [!]{!Lwt.async_exception_hook}, which terminates the process by default. *) val protected : 'a t -> 'a t (** [Lwt.protected p] creates a {{!Lwt.cancel} cancelable} promise [p']. The original state of [p'] is the same as the state of [p] at the time of the call. The state of [p'] can change in one of two ways: a. if [p] changes state (i.e., is resolved), then [p'] eventually changes state to match [p]'s, and b. during cancellation, if the backwards search described in {!Lwt.cancel} reaches [p'] then it changes state to rejected [Canceled] and the search stops. As a consequence of the b. case, [Lwt.cancel (protected p)] does not cancel [p]. The promise [p] can still be canceled either directly (through [Lwt.cancel p]) or being reached by the backwards cancellation search via another path. [Lwt.protected] only prevents cancellation of [p] through [p']. *) val no_cancel : 'a t -> 'a t (** [Lwt.no_cancel p] creates a non-{{!Lwt.cancel}cancelable} promise [p']. The original state of [p'] is the same as [p] at the time of the call. If the state of [p] changes, then the state of [p'] eventually changes too to match [p]'s. Note that even though [p'] is non-{{!Lwt.cancel}cancelable}, it can still become canceled if [p] is canceled. [Lwt.no_cancel] only prevents cancellation of [p] and [p'] through [p']. *) val wrap_in_cancelable : 'a t -> 'a t (** [Lwt.wrap_in_cancelable p] creates a {{!Lwt.cancel} cancelable} promise [p']. The original state of [p'] is the same as [p]. The state of [p'] can change in one of two ways: a. if [p] changes state (i.e., is resolved), then [p'] eventually changes state to match [p]'s, and b. during cancellation, if the backwards search described in {!Lwt.cancel} reaches [p'] then it changes state to rejected [Canceled] and the search continues to [p]. *) (** {3 Cancellation tweaks} The primitives [protected], [no_cancel], and [wrap_in_cancelable] give you some level of control over the cancellation mechanism of Lwt. Note that promises passed as arguments to either of these three functions are unchanged. The functions return new promises with a specific cancellation behaviour. The three behaviour of all three functions are summarised in the following table. {[ +----------------------------+--------------------+--------------------+ | setup - action | cancel p | cancel p' | +----------------------------+--------------------+--------------------+ | p is cancelable | p is canceled | p is not canceled | | p' = protected p | p' is canceled | p' is canceled | +----------------------------+--------------------+--------------------+ | p is not cancelable | p is not canceled | p is not canceled | | p' = protected p | p' is not canceled | p' is canceled | +----------------------------+--------------------+--------------------+ | p is cancelable | p is canceled | p is not canceled | | p' = no_cancel p | p' is canceled | p' is not canceled | +----------------------------+--------------------+--------------------+ | p is not cancelable | p is not canceled | p is not canceled | | p' = no_cancel p | p' is not canceled | p' is not canceled | +----------------------------+--------------------+--------------------+ | p is cancelable | p is canceled | p is canceled | | p' = wrap_in_cancelable p | p' is canceled | p' is canceled | +----------------------------+--------------------+--------------------+ | p is not cancelable | p is not canceled | p is not canceled | | p' = wrap_in_cancelable p | p' is not canceled | p' is canceled | +----------------------------+--------------------+--------------------+ ]} *) (** {2:2_Convenience Convenience} *) (** {3 Callback helpers} *) val map : ('a -> 'b) -> 'a t -> 'b t (** [Lwt.map f p_1] is similar to {!Lwt.bind}[ p_1 f], but [f] is not expected to return a promise. This function is more convenient than {!Lwt.bind} when [f] inherently does not return a promise. An example is [Stdlib.int_of_string]: {[ let read_int : unit -> int Lwt.t = fun () -> Lwt.map int_of_string Lwt_io.(read_line stdin) let () = Lwt_main.run begin let%lwt number = read_int () in Lwt_io.printf "%i\n" number end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} By comparison, the {!Lwt.bind} version is more awkward: {[ let read_int : unit -> int Lwt.t = fun () -> Lwt.bind Lwt_io.(read_line stdin) (fun line -> Lwt.return (int_of_string line)) ]} As with {!Lwt.bind}, sequences of calls to [Lwt.map] result in excessive indentation and parentheses. The recommended syntactic sugar for avoiding this is the {{!Lwt.Infix.(>|=)} [>|=]} operator, which comes from module [Lwt.Infix]: {[ open Lwt.Infix let read_int : unit -> int Lwt.t = fun () -> Lwt_io.(read_line stdin) >|= int_of_string ]} The detailed operation follows. For consistency with the promises in {!Lwt.bind}, the {e two} promises involved are named [p_1] and [p_3]: - [p_1] is the promise passed to [Lwt.map]. - [p_3] is the promise returned by [Lwt.map]. [Lwt.map] returns a promise [p_3]. [p_3] starts out pending. It is resolved as follows: - [p_1] may be, or become, resolved. In that case, by definition, it will become fulfilled or rejected. Fulfillment is the interesting case, but the behavior on rejection is simpler, so we focus on rejection first. - When [p_1] becomes rejected, [p_3] is rejected with the same exception. - When [p_1] instead becomes fulfilled, call the value it is fulfilled with [v]. - [f v] is applied. If this finishes, it may either return another value, or raise an exception. - If [f v] returns another value [v'], [p_3] is fulfilled with [v']. - If [f v] raises exception [exn], [p_3] is rejected with [exn]. *) val on_success : 'a t -> ('a -> unit) -> unit (** [Lwt.on_success p f] makes it so that [f] will run when [p] is {{!t} {e fulfilled}}. It is similar to {!Lwt.bind}, except no new promises are created. [f] is a plain, arbitrary function attached to [p], to perform some side effect. If [f] raises an exception, it is passed to [!]{!Lwt.async_exception_hook}. By default, this will terminate the process. *) val on_failure : _ t -> (exn -> unit) -> unit (** [Lwt.on_failure p f] makes it so that [f] will run when [p] is {{!t} {e rejected}}. It is similar to {!Lwt.catch}, except no new promises are created. If [f] raises an exception, it is passed to [!]{!Lwt.async_exception_hook}. By default, this will terminate the process. *) val on_termination : _ t -> (unit -> unit) -> unit (** [Lwt.on_termination p f] makes it so that [f] will run when [p] is {{!t} {e resolved}} – that is, fulfilled {e or} rejected. It is similar to {!Lwt.finalize}, except no new promises are created. If [f] raises an exception, it is passed to [!]{!Lwt.async_exception_hook}. By default, this will terminate the process. *) val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit (** [Lwt.on_any p f g] makes it so that: - [f] will run when [p] is {{!t} {e fulfilled}}, - [g] will run when [p] is, alternatively, {{!t} {e rejected}}. It is similar to {!Lwt.try_bind}, except no new promises are created. If [f] or [g] raise an exception, the exception is passed to [!]{!Lwt.async_exception_hook}. By default, this will terminate the process. *) (** {3 Infix operators} *) (** This module provides several infix operators for making programming with Lwt more convenient. To use it, open [Lwt.Infix]. Of the operators declared in this module, only [>|=] is recommended for new code. The only other commonly-used operator is [>>=]. *) module Infix : sig val (>>=) : 'a t -> ('a -> 'b t) -> 'b t (** [p >>= f] is the same as {!Lwt.bind}[ p f]. It requires [Lwt.Infix] to be opened in scope: {[ open Lwt.Infix let () = Lwt_main.run (Lwt_io.(read_line stdin) >>= Lwt_io.printl) (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} It is recommended to use the PPX [let%lwt] syntax instead. This operator is the next-best choice. It is frequently found while reading existing Lwt code. *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t (** [p >|= f] is the same as {!Lwt.map}[ f p]. It requires [Lwt.Infix] to be opened in scope. {[ open Lwt.Infix let () = Lwt_main.run (Lwt_io.(read_line stdin) >|= ignore) (* ocamlfind opt -linkpkg -thread -package lwt.unix code.ml && ./a.out *) ]} *) val (<&>) : unit t -> unit t -> unit t (** [p1 <&> p2] is the same as {!Lwt.join}[ [p1; p2]]. It requires [Lwt.Infix] to be opened in scope. Unlike with {!Lwt.bind} and {!Lwt.map}, there are no problems with explicit {!Lwt.join} syntax, so using this operator is not recommended. *) val () : 'a t -> 'a t -> 'a t (** [p1 p2] is the same as {!Lwt.choose}[ [p1; p2]]. It requires [Lwt.Infix] to be opened in scope. Unlike with {!Lwt.bind} and {!Lwt.map}, there are no problems with explicit {!Lwt.choose} syntax, so using this operator is not recommended. Furthermore, most users actually need {!Lwt.pick} instead of {!Lwt.choose}. *) val (=<<) : ('a -> 'b t) -> 'a t -> 'b t (** [f =<< p] is the same as {!Lwt.bind}[ p f]. It requires [Lwt.Infix] to be opened in scope. This operator is obscure and its use is discouraged. It is the same as [p >>= f]. *) val (=|<) : ('a -> 'b) -> 'a t -> 'b t (** [f =|< p] is the same as {!Lwt.map}[ f p]. It requires [Lwt.Infix] to be opened in scope. This operator is obscure and its use is discouraged. It is the same as [p >|= f]. *) (** This module provides support for {{:https://github.com/janestreet/ppx_let} ppx_let}. @since 4.2.0 *) module Let_syntax : sig val return : 'a -> 'a t (** See {!Lwt.return}. *) val map : 'a t -> f:('a -> 'b) -> 'b t (** See {!Lwt.map}. *) val bind : 'a t -> f:('a -> 'b t) -> 'b t (** See {!Lwt.bind}. *) val both : 'a t -> 'b t -> ('a * 'b) t (** See {!Lwt.both}. *) module Open_on_rhs : sig end end end module Let_syntax : sig module Let_syntax : sig val return : 'a -> 'a t (** See {!Lwt.return}. *) val map : 'a t -> f:('a -> 'b) -> 'b t (** See {!Lwt.map}. *) val bind : 'a t -> f:('a -> 'b t) -> 'b t (** See {!Lwt.bind}. *) val both : 'a t -> 'b t -> ('a * 'b) t (** See {!Lwt.both}. *) module Open_on_rhs : sig end end end (** {3 Let syntax} *) module Syntax : sig (** {1 Monadic syntax} *) val (let*) : 'a t -> ('a -> 'b t) -> 'b t (** Syntax for {!bind}. *) val (and*) : 'a t -> 'b t -> ('a * 'b) t (** Syntax for {!both}. *) (** {1 Applicative syntax} *) val (let+) : 'a t -> ('a -> 'b) -> 'b t (** Syntax for {!map}. *) val (and+) : 'a t -> 'b t -> ('a * 'b) t (** Syntax for {!both}. *) end (** {3 Pre-allocated promises} *) val return_unit : unit t (** [Lwt.return_unit] is defined as {!Lwt.return}[ ()], but this definition is evaluated only once, during initialization of module [Lwt], at the beginning of your program. This means the promise is allocated only once. By contrast, each time {!Lwt.return}[ ()] is evaluated, it allocates a new promise. It is recommended to use [Lwt.return_unit] only where you know the allocations caused by an instance of {!Lwt.return}[ ()] are a performance bottleneck. Generally, the cost of I/O tends to dominate the cost of {!Lwt.return}[ ()] anyway. In future Lwt, we hope to perform this optimization, of using a single, pre-allocated promise, automatically, wherever {!Lwt.return}[ ()] is written. *) val return_none : (_ option) t (** [Lwt.return_none] is like {!Lwt.return_unit}, but for {!Lwt.return}[ None]. *) val return_nil : (_ list) t (** [Lwt.return_nil] is like {!Lwt.return_unit}, but for {!Lwt.return}[ []]. *) val return_true : bool t (** [Lwt.return_true] is like {!Lwt.return_unit}, but for {!Lwt.return}[ true]. *) val return_false : bool t (** [Lwt.return_false] is like {!Lwt.return_unit}, but for {!Lwt.return}[ false]. *) (** {3 Trivial promises} *) val return_some : 'a -> ('a option) t (** Counterpart to {!Lwt.return_none}. However, unlike {!Lwt.return_none}, this function performs no {{: #VALreturn_unit} optimization}. This is because it takes an argument, so it cannot be evaluated at initialization time, at which time the argument is not yet available. *) val return_ok : 'a -> (('a, _) result) t (** Like {!Lwt.return_some}, this function performs no optimization. @since Lwt 2.6.0 *) val return_error : 'e -> ((_, 'e) result) t (** Like {!Lwt.return_some}, this function performs no optimization. @since Lwt 2.6.0 *) val fail_with : string -> _ t (** [Lwt.fail_with s] is an abbreviation for {[ Lwt.fail (Stdlib.Failure s) ]} In most cases, it is better to use [failwith s] from the standard library. See {!Lwt.fail} for an explanation. *) val fail_invalid_arg : string -> _ t (** [Lwt.invalid_arg s] is an abbreviation for {[ Lwt.fail (Stdlib.Invalid_argument s) ]} In most cases, it is better to use [invalid_arg s] from the standard library. See {!Lwt.fail} for an explanation. *) (** {3 Result type} *) (** A resolved promise of type ['a ]{!Lwt.t} is either fulfilled with a value of type ['a], or rejected with an exception. This corresponds to the cases of a [('a, exn)]{!Stdlib.result}: fulfilled corresponds to [Ok of 'a], and rejected corresponds to [Error of exn]. For Lwt programming with [result] where the [Error] constructor can carry arbitrary error types, see module {!Lwt_result}. *) val of_result : ('a, exn) result -> 'a t (** [Lwt.of_result r] converts an r to a resolved promise. - If [r] is [Ok v], [Lwt.of_result r] is [Lwt.return v], i.e. a promise fulfilled with [v]. - If [r] is [Error exn], [Lwt.of_result r] is [Lwt.fail exn], i.e. a promise rejected with [exn]. *) val wakeup_later_result : 'a u -> ('a, exn) result -> unit (** [Lwt.wakeup_later_result r result] resolves the pending promise [p] associated to resolver [r], according to [result]: - If [result] is [Ok v], [p] is fulfilled with [v]. - If [result] is [Error exn], [p] is rejected with [exn]. If [p] is not pending, [Lwt.wakeup_later_result] raises [Stdlib.Invalid_argument _], except if [p] is {{!Lwt.cancel} canceled}. If [p] is canceled, [Lwt.wakeup_later_result] has no effect. *) (** {3 State query} *) type 'a state = | Return of 'a | Fail of exn | Sleep val state : 'a t -> 'a state (** [Lwt.state p] evaluates to the current state of promise [p]: - If [p] is {{!t} fulfilled} with value [v], the result is [Lwt.Return v]. - If [p] is {{!t} rejected} with exception [exn], the result is [Lwt.Fail exn]. - If [p] is {{!t} pending}, the result is [Lwt.Sleep]. The constructor names are historical holdovers. *) (** {2:2_Deprecated Deprecated} *) (** {3 Implicit callback arguments} Using this mechanism is discouraged, because it is non-syntactic, and because it manipulates hidden state in module [Lwt]. It is recommended instead to pass additional values explicitly in tuples, or maintain explicit associative maps for them. *) type 'a key (** Keys into the implicit callback argument map, for implicit arguments of type ['a option]. The keys are abstract, but they are basically integers that are all distinct from each other. See {!Lwt.with_value}. *) val new_key : unit -> 'a key (** Creates a fresh implicit callback argument key. The key is distinct from any other key created by the current process. The value [None] of type ['a option] is immediately associated with the key. See {!Lwt.with_value}. *) val get : 'a key -> 'a option (** Retrieves the value currently associated with the given implicit callback argument key. See {!Lwt.with_value}. *) val with_value : 'a key -> 'a option -> (unit -> 'b) -> 'b (** [Lwt.with_value k v f] sets [k] to [v] in Lwt's internal implicit callback argument map, then runs [f ()], then restores the previous value associated with [k]. Lwt maintains a single, global map, that can be used to “pass” extra arguments to callbacks: {[ let () = let k : string Lwt.key = Lwt.new_key () in let say_hello () = match Lwt.get k with | None -> assert false | Some s -> Lwt_io.printl s in Lwt_main.run begin Lwt.with_value k (Some "Hello world!") begin fun () -> Lwt.bind (Lwt_unix.sleep 1.) (fun () -> say_hello ()) end end (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} Note that the string [Hello world!] was passed to [say_hello] through the key [k]. Meanwhile, the only {e explicit} argument of the callback [say_hello] is [()]. The way this works is functions like {!Lwt.bind} take a {b snapshot} of the implicit argument map. Later, right before the callback is run, the map is {e restored} to that snapshot. In other words, the map has the same state inside the callback as it did at the time the callback was registered. To be more precise: - [Lwt.with_value] associates [Some "Hello world!"] with [k], and runs the function passed to it. - This function contains the {!Lwt.bind}. - OCaml's eager evaluation means the arguments are evaluated first. In particular, the [Lwt_unix.sleep 1.] promise is created. - {!Lwt.bind} then attaches the callback in its second argument, the one which calls [say_hello], to that [sleep] promise. - {!Lwt.bind} also takes a snapshot of the current state of the implicit argument map, and pairs the callback with that snapshot. - The callback will not run for another second or so, when the [sleep] promise will be resolved. - Instead, {!Lwt.bind} returns its result promise [p_3]. This causes [Lwt.with_value] to also return [p_3], first restoring [k] to be associated with [None]. - {!Lwt_main.run} gets the pending [p_3], and blocks the whole process, with [k] associated with [None]. - One second later, the [sleep] I/O completes, resolving the [sleep] promise. - This triggers the [say_hello] callback. Right before the callback is called, the implicit argument map is restored to its snapshot, so [k] is associated with [Some "Hello world!"]. - After the callback completes, Lwt again restores [k] to be associated with [None]. The Lwt functions that take snapshots of the implicit callback argument map are exactly those which attach callbacks to promises: {!Lwt.bind} and its variants [>>=] and [let%lwt], {!Lwt.map} and its variant [>|=], {!Lwt.catch} and its variant [try%lwt], {!Lwt.finalize} and its variant [%lwt.finally], {!Lwt.try_bind}, {!Lwt.on_success}, {!Lwt.on_failure}, {!Lwt.on_termination}, and {!Lwt.on_any}. [Lwt.with_value] should only be called in the main thread, i.e. do not call it inside {!Lwt_preemptive.detach}. *) (** {3 Immediate resolving} *) val wakeup : 'a u -> 'a -> unit (** [Lwt.wakeup r v] is like {!Lwt.wakeup_later}[ r v], except it guarantees that callbacks associated with [r] will be called immediately, deeper on the current stack. In contrast, {!Lwt.wakeup_later} {e may} call callbacks immediately, or may queue them for execution on a shallower stack – though still before the next time Lwt blocks the process on I/O. Using this function is discouraged, because calling it in a loop can exhaust the stack. The loop might be difficult to detect or predict, due to combined mutually-recursive calls between multiple modules and libraries. Also, trying to use this function to guarantee the timing of callback calls for synchronization purposes is discouraged. This synchronization effect is obscure to readers. It is better to use explicit promises, or {!Lwt_mutex}, {!Lwt_condition}, and/or {!Lwt_mvar}. *) val wakeup_exn : _ u -> exn -> unit (** [Lwt.wakeup_exn r exn] is like {!Lwt.wakeup_later_exn}[ r exn], but has the same problems as {!Lwt.wakeup}. *) val wakeup_result : 'a u -> ('a, exn) result -> unit (** [Lwt.wakeup_result r result] is like {!Lwt.wakeup_later_result}[ r result], but has the same problems as {!Lwt.wakeup}. *) (** {3 Linked lists of promises} *) [@@@ocaml.warning "-3"] val add_task_r : ('a u) Lwt_sequence.t -> 'a t [@@ocaml.deprecated " Deprecated because Lwt_sequence is an implementation detail of Lwt. See https://github.com/ocsigen/lwt/issues/361"] (** [Lwt.add_task_r sequence] is equivalent to {[ let p, r = Lwt.task () in let node = Lwt_sequence.add_r r sequence in Lwt.on_cancel p (fun () -> Lwt_sequence.remove node); p ]} @deprecated Use of this function is discouraged for two reasons: - {!Lwt_sequence} should not be used outside Lwt. - This function only exists because it performs a minor internal optimization, which may be removed. *) val add_task_l : ('a u) Lwt_sequence.t -> 'a t [@@ocaml.deprecated " Deprecated because Lwt_sequence is an implementation detail of Lwt. See https://github.com/ocsigen/lwt/issues/361"] (** Like {!Lwt.add_task_r}, but the equivalent code calls {!Lwt_sequence.add_l} instead. @deprecated See [add_task_r]. *) [@@@ocaml.warning "+3"] (** {3 Yielding} *) val pause : unit -> unit t (** [Lwt.pause ()] creates a pending promise that is fulfilled after Lwt finishes calling all currently ready callbacks, i.e. it is fulfilled on the next “tick.” Putting the rest of your computation into a callback of [Lwt.pause ()] creates a “yield” that gives other callbacks a chance to run first. For example, to break up a long-running computation, allowing I/O to be handled between chunks: {[ let () = let rec handle_io () = let%lwt () = Lwt_io.printl "Handling I/O" in let%lwt () = Lwt_unix.sleep 0.1 in handle_io () in let rec compute n = if n = 0 then Lwt.return () else let%lwt () = if n mod 1_000_000 = 0 then Lwt.pause () else Lwt.return () in compute (n - 1) in Lwt.async handle_io; Lwt_main.run (compute 100_000_000) (* ocamlfind opt -linkpkg -thread -package lwt_ppx,lwt.unix code.ml && ./a.out *) ]} If you replace the call to [Lwt.pause] by [Lwt.return] in the program above, ["Handling I/O"] is printed only once. With [Lwt.pause], it is printed several times, depending on the speed of your machine. An alternative way to handle long-running computations is to detach them to preemptive threads using {!Lwt_preemptive}. *) (**/**) val wakeup_paused : unit -> unit (** [Lwt.wakeup_paused ()] fulfills all promises created with {!Lwt.pause} since the last time [Lwt.wakeup_paused] was called, or since the process was started. This function is intended for internal use by Lwt. *) val paused_count : unit -> int (** Returns the number of promises that would be fulfilled by calling [Lwt.wakeup_paused] right now. This function is intended for internal use by Lwt. *) val register_pause_notifier : (int -> unit) -> unit (** [Lwt.register_pause_notifier f] causes [f] to be called every time {!Lwt.pause} is called. The result of [Lwt.paused_count ()] is passed to [f]. Only one such function can be registered at a time. There is only a single internal reference cell available for this purpose. This function is intended for internal use by Lwt. *) val abandon_paused : unit -> unit (** Causes promises created with {!Lwt.pause} to remain forever pending. See {!Lwt_main.abandon_yielded_and_paused} before {!Lwt_main.yield} is phased out. This function is intended for internal use by Lwt. *) (**/**) (** {3 Function lifters} *) val wrap : (unit -> 'a) -> 'a t (** [Lwt.wrap f] applies [f ()]. If [f ()] returns a value [v], [Lwt.wrap] returns {!Lwt.return}[ v]. If [f ()] raises an exception exn, [Lwt.wrap] returns {!Lwt.fail}[ exn]. *) val wrap1 : ('a -> 'b) -> ('a -> 'b t) val wrap2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c t) val wrap3 : ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> 'd t) val wrap4 : ('a -> 'b -> 'c -> 'd -> 'e) -> ('a -> 'b -> 'c -> 'd -> 'e t) val wrap5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f t) val wrap6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g t) val wrap7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h t) (** As a “prototype,” [Lwt_wrap1 f] creates a promise-valued function [g]: {[ let g v = try let v' = f v in Lwt.return v' with exn -> Lwt.fail exn ]} The remainder of the functions work analogously – they just work on [f] with larger numbers of arguments. Note that there is an important difference to {!Lwt.wrap}. These functions don't run [f], nor create the final promise, immediately. In contrast, {!Lwt.wrap} runs its argument [f] eagerly. To get a suspended function instead of the eager execution of {!Lwt.wrap}, use [Lwt.wrap1]. *) (** {3 Unscoped infix operators} Use the operators in module {!Lwt.Infix} instead. Using these instances of the operators directly requires opening module [Lwt], which brings an excessive number of other names into scope. *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t val () : 'a t -> 'a t -> 'a t val (<&>) : unit t -> unit t -> unit t val (=<<) : ('a -> 'b t) -> 'a t -> 'b t val (=|<) : ('a -> 'b) -> 'a t -> 'b t (** {3 Miscellaneous} *) val is_sleeping : _ t -> bool (** [Lwt.is_sleeping p] is equivalent to {!val:Lwt.state}[ p = Lwt.Sleep]. *) val ignore_result : _ t -> unit (** An obsolete variant of {!Lwt.async}. [Lwt.ignore_result p] behaves as follows: - If [p] is already fulfilled, [Lwt.ignore_result p] does nothing. - If [p] is already rejected with [exn], [Lwt.ignore_result p] raises [exn] immediately. - If [p] is pending, [Lwt.ignore_result p] does nothing, but if [p] becomes rejected later, the exception is passed to [!]{!Lwt.async_exception_hook}. Use of this function is discouraged for two reasons: - The behavior is different depending on whether [p] is rejected now or later. - The name is misleading, and has led to users thinking this function is analogous to {!Stdlib.ignore}, i.e. that it waits for [p] to become resolved, completing any associated side effects along the way. In fact, the function that does {e that} is ordinary {!Lwt.bind}. *) (** {4 Runtime exception filters} Depending on the kind of programs that you write, you may need to treat exceptions thrown by the OCaml runtime (namely [Out_of_memory] and [Stack_overflow]) differently than all the other exceptions. This is because (a) these exceptions are not reproducible (in that they are thrown at different points of your program depending on the machine that your program runs on) and (b) recovering from these errors may be impossible. The helpers below allow you to change the way that Lwt handles the two OCaml runtime exceptions [Out_of_memory] and [Stack_overflow]. *) module Exception_filter: sig (** An [Exception_filter.t] is a value which indicates to Lwt what exceptions to catch and what exceptions to let bubble up all the way out of the main loop immediately. *) type t (** [handle_all] is the default filter. With it the all the exceptions (including [Out_of_memory] and [Stack_overflow]) can be handled: caught and transformed into rejected promises. *) val handle_all : t (** [handle_all_except_runtime] is a filter which lets the OCaml runtime exceptions ([Out_of_memory] and [Stack_overflow]) go through all the Lwt abstractions and bubble all the way out of the call to [Lwt_main.run]. Note that if you set this handler, then the runtime exceptions leave the Lwt internal state inconsistent. For this reason, you will not be able to call [Lwt_main.run] again after such an exception has escaped [Lwt_main.run]. *) val handle_all_except_runtime : t (** [set] sets the given exception filter globally. You should call this function at most once during the start of your program, before the first call to [Lwt_main.run]. *) val set : t -> unit (**/**) val run : exn -> bool end (**/**) val poll : 'a t -> 'a option val apply : ('a -> 'b t) -> 'a -> 'b t val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t val abandon_wakeups : unit -> unit val debug_state_is : 'a state -> 'a t -> bool t lwt-5.9.1/src/core/lwt_condition.ml000066400000000000000000000053621476253734400173060ustar00rootroot00000000000000(* OCaml promise library * https://ocsigen.org/lwt * Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] type 'a t = 'a Lwt.u Lwt_sequence.t let create = Lwt_sequence.create let wait ?mutex cvar = let waiter = (Lwt.add_task_r [@ocaml.warning "-3"]) cvar in let () = match mutex with | Some m -> Lwt_mutex.unlock m | None -> () in Lwt.finalize (fun () -> waiter) (fun () -> match mutex with | Some m -> Lwt_mutex.lock m | None -> Lwt.return_unit) let signal cvar arg = try Lwt.wakeup_later (Lwt_sequence.take_l cvar) arg with Lwt_sequence.Empty -> () let broadcast cvar arg = let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in Lwt_sequence.iter_node_l Lwt_sequence.remove cvar; List.iter (fun wakener -> Lwt.wakeup_later wakener arg) wakeners let broadcast_exn cvar exn = let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in Lwt_sequence.iter_node_l Lwt_sequence.remove cvar; List.iter (fun wakener -> Lwt.wakeup_later_exn wakener exn) wakeners lwt-5.9.1/src/core/lwt_condition.mli000066400000000000000000000060041476253734400174510ustar00rootroot00000000000000(* OCaml promise library * https://ocsigen.org/lwt * Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (** Conditions *) (** Condition variables to synchronize between threads. *) type 'a t (** Condition variable type. The type parameter denotes the type of value propagated from notifier to waiter. *) val create : unit -> 'a t (** [create ()] creates a new condition variable. *) val wait : ?mutex:Lwt_mutex.t -> 'a t -> 'a Lwt.t (** [wait mutex condvar] will cause the current thread to block, awaiting notification for a condition variable, [condvar]. If provided, the [mutex] must have been previously locked (within the scope of [Lwt_mutex.with_lock], for example) and is temporarily unlocked until the condition is notified. Upon notification, [mutex] is re-locked before [wait] returns and the thread's activity is resumed. When the awaited condition is notified, the value parameter passed to [signal] is returned. *) val signal : 'a t -> 'a -> unit (** [signal condvar value] notifies that a condition is ready. A single waiting thread will be awoken and will receive the notification value which will be returned from [wait]. Note that condition notification is not "sticky", i.e. if there is no waiter when [signal] is called, the notification will be missed and the value discarded. *) val broadcast : 'a t -> 'a -> unit (** [broadcast condvar value] notifies all waiting threads. Each will be awoken in turn and will receive the same notification value. *) val broadcast_exn : 'a t -> exn -> unit (** [broadcast_exn condvar exn] fails all waiting threads with exception [exn]. @since 2.6.0 *) lwt-5.9.1/src/core/lwt_list.ml000066400000000000000000000114011476253734400162620ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* A survey and measurements of more optimized implementations can be found at: https://jsthomas.github.io/map-comparison.html See discussion in https://github.com/ocsigen/lwt/pull/347. *) let tail_recursive_map f l = List.rev (List.rev_map f l) let tail_recursive_mapi_rev f l = let rec inner acc i = function | [] -> acc | hd::tl -> (inner [@ocaml.tailcall]) ((f i hd)::acc) (i + 1) tl in inner [] 0 l open Lwt.Infix let rec iter_s f l = match l with | [] -> Lwt.return_unit | x :: l -> Lwt.apply f x >>= fun () -> iter_s f l let iter_p f l = let ts = List.rev_map (Lwt.apply f) l in Lwt.join ts let rec iteri_s i f l = match l with | [] -> Lwt.return_unit | x :: l -> Lwt.apply (f i) x >>= fun () -> iteri_s (i + 1) f l let iteri_s f l = iteri_s 0 f l let iteri_p f l = let f' i = Lwt.apply (f i) in let ts = tail_recursive_mapi_rev f' l in Lwt.join ts let map_s f l = let rec inner acc = function | [] -> List.rev acc |> Lwt.return | hd::tl -> Lwt.apply f hd >>= fun r -> (inner [@ocaml.tailcall]) (r::acc) tl in inner [] l let rec _collect_rev acc = function | [] -> Lwt.return acc | t::ts -> t >>= fun i -> (_collect_rev [@ocaml.tailcall]) (i::acc) ts let map_p f l = let ts = List.rev_map (Lwt.apply f) l in _collect_rev [] ts let filter_map_s f l = let rec inner acc = function | [] -> List.rev acc |> Lwt.return | hd::tl -> Lwt.apply f hd >>= function | Some v -> (inner [@ocaml.tailcall]) (v::acc) tl | None -> (inner [@ocaml.tailcall]) acc tl in inner [] l let filter_map_p f l = let rec _collect_optional_rev acc = function | [] -> Lwt.return acc | t::ts -> t >>= function | Some v -> (_collect_optional_rev [@ocaml.tailcall]) (v::acc) ts | None -> (_collect_optional_rev [@ocaml.tailcall]) acc ts in let ts = List.rev_map (Lwt.apply f) l in _collect_optional_rev [] ts let mapi_s f l = let rec inner acc i = function | [] -> List.rev acc |> Lwt.return | hd::tl -> Lwt.apply (f i) hd >>= fun v -> (inner [@ocaml.tailcall]) (v::acc) (i+1) tl in inner [] 0 l let mapi_p f l = let f' i = Lwt.apply (f i) in let ts = tail_recursive_mapi_rev f' l in _collect_rev [] ts let rec rev_map_append_s acc f l = match l with | [] -> Lwt.return acc | x :: l -> Lwt.apply f x >>= fun x -> rev_map_append_s (x :: acc) f l let rev_map_s f l = rev_map_append_s [] f l let rec rev_map_append_p acc f l = match l with | [] -> acc | x :: l -> rev_map_append_p (Lwt.apply f x >>= fun x -> acc >|= fun l -> x :: l) f l let rev_map_p f l = rev_map_append_p Lwt.return_nil f l let rec fold_left_s f acc l = match l with | [] -> Lwt.return acc | x :: l -> Lwt.apply (f acc) x >>= fun acc -> (fold_left_s [@ocaml.tailcall]) f acc l let fold_right_s f l acc = let rec inner f a = function | [] -> Lwt.return a | hd::tl -> (Lwt.apply (f hd) a) >>= fun a' -> (inner [@ocaml.tailcall]) f a' tl in inner f acc (List.rev l) let rec for_all_s f l = match l with | [] -> Lwt.return_true | x :: l -> Lwt.apply f x >>= function | true -> (for_all_s [@ocaml.tailcall]) f l | false -> Lwt.return_false let for_all_p f l = map_p f l >>= fun bl -> List.for_all (fun x -> x) bl |> Lwt.return let rec exists_s f l = match l with | [] -> Lwt.return_false | x :: l -> Lwt.apply f x >>= function | true -> Lwt.return_true | false -> (exists_s [@ocaml.tailcall]) f l let exists_p f l = map_p f l >>= fun bl -> List.exists (fun x -> x) bl |> Lwt.return let rec find_s f l = match l with | [] -> Lwt.fail Not_found | x :: l -> Lwt.apply f x >>= function | true -> Lwt.return x | false -> (find_s [@ocaml.tailcall]) f l let _optionalize f x = f x >>= fun b -> if b then Lwt.return (Some x) else Lwt.return_none let filter_s f l = filter_map_s (_optionalize f) l let filter_p f l = filter_map_p (_optionalize f) l let partition_s f l = let rec inner acc1 acc2 = function | [] -> Lwt.return (List.rev acc1, List.rev acc2) | hd::tl -> Lwt.apply f hd >>= fun b -> if b then inner (hd::acc1) acc2 tl else inner acc1 (hd::acc2) tl in inner [] [] l let partition_p f l = let g x = Lwt.apply f x >>= fun b -> Lwt.return (b, x) in map_p g l >>= fun tl -> let group1 = tail_recursive_map snd @@ List.filter fst tl in let group2 = tail_recursive_map snd @@ List.filter (fun x -> not @@ fst x) tl in Lwt.return (group1, group2) lwt-5.9.1/src/core/lwt_list.mli000066400000000000000000000034321476253734400164400ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** List helpers *) (** Note: this module use the same naming convention as {!Lwt_stream}. *) (** {2 List iterators} *) val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t val iteri_s : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t (** {2 List scanning} *) val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t (** {2 List searching} *) val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a Lwt.t val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t val filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t lwt-5.9.1/src/core/lwt_mutex.ml000066400000000000000000000025271476253734400164620ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] open Lwt.Infix type t = { mutable locked : bool; waiters : unit Lwt.u Lwt_sequence.t } let create () = { locked = false; waiters = Lwt_sequence.create () } let lock m = if m.locked then (Lwt.add_task_r [@ocaml.warning "-3"]) m.waiters else begin m.locked <- true; Lwt.return_unit end let unlock m = if m.locked then begin if Lwt_sequence.is_empty m.waiters then m.locked <- false else (* We do not use [Lwt.wakeup] here to avoid a stack overflow when unlocking a lot of threads. *) Lwt.wakeup_later (Lwt_sequence.take_l m.waiters) () end let with_lock m f = lock m >>= fun () -> Lwt.finalize f (fun () -> unlock m; Lwt.return_unit) let is_locked m = m.locked let is_empty m = Lwt_sequence.is_empty m.waiters lwt-5.9.1/src/core/lwt_mutex.mli000066400000000000000000000030071476253734400166250ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Cooperative locks for mutual exclusion *) type t (** Type of Lwt mutexes *) val create : unit -> t (** [create ()] creates a new mutex, which is initially unlocked *) val lock : t -> unit Lwt.t (** [lock mutex] lockcs the mutex, that is: - if the mutex is unlocked, then it is marked as locked and {!lock} returns immediately - if it is locked, then {!lock} waits for all threads waiting on the mutex to terminate, then it resumes when the last one unlocks the mutex Note: threads are woken up in the same order they try to lock the mutex *) val unlock : t -> unit (** [unlock mutex] unlock the mutex if no threads is waiting on it. Otherwise it will eventually removes the first one and resumes it. *) val is_locked : t -> bool (** [locked mutex] returns whether [mutex] is currently locked *) val is_empty : t -> bool (** [is_empty mutex] returns [true] if they are no thread waiting on the mutex, and [false] otherwise *) val with_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t (** [with_lock lock f] is used to lock a mutex within a block scope. The function [f ()] is called with the mutex locked, and its result is returned from the call to [with_lock]. If an exception is raised from f, the mutex is also unlocked before the scope of [with_lock] is exited. *) lwt-5.9.1/src/core/lwt_mvar.ml000066400000000000000000000066011476253734400162620ustar00rootroot00000000000000(* OCaml promise library * https://ocsigen.org/lwt * Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (* This code is adapted from https://web.archive.org/web/20101001215425/http://eigenclass.org:80/hiki/lightweight-threads-with-lwt. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] type 'a t = { mutable mvar_contents : 'a option; (* Current contents *) writers : ('a * unit Lwt.u) Lwt_sequence.t; (* Threads waiting to put a value *) readers : 'a Lwt.u Lwt_sequence.t; (* Threads waiting for a value *) } let create_empty () = { mvar_contents = None; writers = Lwt_sequence.create (); readers = Lwt_sequence.create () } let create v = { mvar_contents = Some v; writers = Lwt_sequence.create (); readers = Lwt_sequence.create () } let put mvar v = match mvar.mvar_contents with | None -> begin match Lwt_sequence.take_opt_l mvar.readers with | None -> mvar.mvar_contents <- Some v | Some w -> Lwt.wakeup_later w v end; Lwt.return_unit | Some _ -> let (res, w) = Lwt.task () in let node = Lwt_sequence.add_r (v, w) mvar.writers in Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); res let next_writer mvar = match Lwt_sequence.take_opt_l mvar.writers with | Some(v', w) -> mvar.mvar_contents <- Some v'; Lwt.wakeup_later w () | None -> mvar.mvar_contents <- None let take_available mvar = match mvar.mvar_contents with | Some v -> next_writer mvar; Some v | None -> None let take mvar = match take_available mvar with | Some v -> Lwt.return v | None -> (Lwt.add_task_r [@ocaml.warning "-3"]) mvar.readers let is_empty mvar = match mvar.mvar_contents with | Some _ -> false | None -> true lwt-5.9.1/src/core/lwt_mvar.mli000066400000000000000000000053771476253734400164440ustar00rootroot00000000000000(* OCaml promise library * https://ocsigen.org/lwt * Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (** Mailbox variables *) (** “Mailbox” variables implement a synchronising variable, used for communication between concurrent threads. *) type 'a t (** The type of a mailbox variable. Mailbox variables are used to communicate values between threads in a synchronous way. The type parameter specifies the type of the value propagated from [put] to [take]. *) val create : 'a -> 'a t (** [create v] creates a new mailbox variable containing value [v]. *) val create_empty : unit -> 'a t (** [create ()] creates a new empty mailbox variable. *) val put : 'a t -> 'a -> unit Lwt.t (** [put mvar value] puts a value into a mailbox variable. This value will remain in the mailbox until [take] is called to remove it. If the mailbox is not empty, the current thread will block until it is emptied. *) val take : 'a t -> 'a Lwt.t (** [take mvar] will take any currently available value from the mailbox variable. If no value is currently available, the current thread will block, awaiting a value to be [put] by another thread. *) val take_available : 'a t -> 'a option (** [take_available mvar] immediately takes the value from [mvar] without blocking, returning [None] if the mailbox is empty. @since 3.2.0 *) val is_empty : 'a t -> bool (** [is_empty mvar] indicates if [put mvar] can be called without blocking. @since 3.2.0 *) lwt-5.9.1/src/core/lwt_pool.ml000066400000000000000000000122011476253734400162570ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] open Lwt.Infix type 'a t = { create : unit -> 'a Lwt.t; (* Create a new pool member. *) check : 'a -> (bool -> unit) -> unit; (* Check validity of a pool member when use resulted in failed promise. *) validate : 'a -> bool Lwt.t; (* Validate an existing free pool member before use. *) dispose : 'a -> unit Lwt.t; (* Dispose of a pool member. *) cleared : bool ref ref; (* Have the current pool elements been cleared out? *) max : int; (* Size of the pool. *) mutable count : int; (* Number of elements in the pool. *) list : 'a Queue.t; (* Available pool members. *) waiters : 'a Lwt.u Lwt_sequence.t; (* Promise resolvers waiting for a free member. *) } let create m ?(validate = fun _ -> Lwt.return_true) ?(check = fun _ f -> f true) ?(dispose = fun _ -> Lwt.return_unit) create = { max = m; create = create; validate = validate; check = check; dispose = dispose; cleared = ref (ref false); count = 0; list = Queue.create (); waiters = Lwt_sequence.create () } (* Create a pool member. *) let create_member p = Lwt.catch (fun () -> (* Must be done before p.create to prevent other resolvers from creating new members if the limit is reached. *) p.count <- p.count + 1; p.create ()) (fun exn -> (* Creation failed, so don't increment count. *) p.count <- p.count - 1; Lwt.fail exn) (* Release a pool member. *) let release p c = match Lwt_sequence.take_opt_l p.waiters with | Some wakener -> (* A promise resolver is waiting, give it the pool member. *) Lwt.wakeup_later wakener c | None -> (* No one is waiting, queue it. *) Queue.push c p.list (* Dispose of a pool member. *) let dispose p c = p.dispose c >>= fun () -> p.count <- p.count - 1; Lwt.return_unit (* Create a new member when one is thrown away. *) let replace_disposed p = match Lwt_sequence.take_opt_l p.waiters with | None -> (* No one is waiting, do not create a new member to avoid losing an error if creation fails. *) () | Some wakener -> Lwt.on_any (Lwt.apply p.create ()) (fun c -> Lwt.wakeup_later wakener c) (fun exn -> (* Creation failed, notify the waiter of the failure. *) Lwt.wakeup_later_exn wakener exn) (* Verify a member is still valid before using it. *) let validate_and_return p c = Lwt.try_bind (fun () -> p.validate c) (function | true -> Lwt.return c | false -> (* Remove this member and create a new one. *) dispose p c >>= fun () -> create_member p) (fun e -> (* Validation failed: create a new member if at least one resolver is waiting. *) dispose p c >>= fun () -> replace_disposed p; Lwt.reraise e) (* Acquire a pool member. *) let acquire p = if Queue.is_empty p.list then (* No more available member. *) if p.count < p.max then (* Limit not reached: create a new one. *) create_member p else (* Limit reached: wait for a free one. *) (Lwt.add_task_r [@ocaml.warning "-3"]) p.waiters >>= validate_and_return p else (* Take the first free member and validate it. *) let c = Queue.take p.list in validate_and_return p c (* Release a member when use resulted in failed promise if the member is still valid. *) let check_and_release p c cleared = let ok = ref false in p.check c (fun result -> ok := result); if cleared || not !ok then ( (* Element is not ok or the pool was cleared - dispose of it *) dispose p c ) else ( (* Element is ok - release it back to the pool *) release p c; Lwt.return_unit ) let use p f = acquire p >>= fun c -> (* Capture the current cleared state so we can see if it changes while this element is in use *) let cleared = !(p.cleared) in let promise = Lwt.catch (fun () -> f c) (fun e -> check_and_release p c !cleared >>= fun () -> Lwt.fail e) in promise >>= fun _ -> if !cleared then ( (* p was cleared while promise was resolving - dispose of this element *) dispose p c >>= fun () -> promise ) else ( release p c; promise ) let clear p = let elements = Queue.fold (fun l element -> element :: l) [] p.list in Queue.clear p.list; (* Indicate to any currently in-use elements that we cleared the pool *) let old_cleared = !(p.cleared) in old_cleared := true; p.cleared := ref false; Lwt_list.iter_s (dispose p) elements let wait_queue_length p = Lwt_sequence.length p.waiters lwt-5.9.1/src/core/lwt_pool.mli000066400000000000000000000100131476253734400164270ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** External resource pools. This module provides an abstraction for managing collections of resources. One example use case is for managing a pool of database connections, where instead of establishing a new connection each time you need one (which is expensive), you can keep a pool of opened connections and reuse ones that are free. It also provides the capability of: - specifying the maximum number of resources that the pool can manage simultaneously, - checking whether a resource is still valid before/after use, and - performing cleanup logic before dropping a resource. The following example illustrates how it is used with an imaginary [Db] module: {[ let uri = "postgresql://localhost:5432" (* Create a database connection pool with max size of 10. *) let pool = Lwt_pool.create 10 ~dispose:(fun connection -> Db.close connection |> Lwt.return) (fun () -> Db.connect uri |> Lwt.return) (* Use the pool in queries. *) let create_user name = Lwt_pool.use pool (fun connection -> connection |> Db.insert "users" [("name", name)] |> Lwt.return ) ]} Note that this is {e not} intended to keep a pool of system threads. If you want to have such pool, consider using {!Lwt_preemptive}. *) type 'a t (** A pool containing elements of type ['a]. *) val create : int -> ?validate : ('a -> bool Lwt.t) -> ?check : ('a -> (bool -> unit) -> unit) -> ?dispose : ('a -> unit Lwt.t) -> (unit -> 'a Lwt.t) -> 'a t (** [create n ?check ?validate ?dispose f] creates a new pool with at most [n] elements. [f] is used to create a new pool element. Elements are created on demand and re-used until disposed of. @param validate is called each time a pool element is accessed by {!use}, before the element is provided to {!use}'s callback. If [validate element] resolves to [true] the element is considered valid and is passed to the callback for use as-is. If [validate element] resolves to [false] the tested pool element is passed to [dispose] then dropped, with a new one is created to take [element]'s place in the pool. [validate] is available since Lwt 3.2.0. @param check is called after the resolution of {!use}'s callback when the resolution is a failed promise. [check element is_ok] must call [is_ok] exactly once with [true] if [element] is still valid and [false] otherwise. If [check] calls [is_ok false] then [dispose] will be run on [element] and the element will not be returned to the pool. @param dispose is used as described above and by {!clear} to dispose of all elements in a pool. [dispose] is {b not} guaranteed to be called on the elements in a pool when the pool is garbage collected. {!clear} should be used if the elements of the pool need to be explicitly disposed of. *) val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t (** [use p f] requests one free element of the pool [p] and gives it to the function [f]. The element is put back into the pool after the promise created by [f] completes. In the case that [p] is exhausted and the maximum number of elements is reached, [use] will wait until one becomes free. *) val clear : 'a t -> unit Lwt.t (** [clear p] will clear all elements in [p], calling the [dispose] function associated with [p] on each of the cleared elements. Any elements from [p] which are currently in use will be disposed of once they are released. The next call to [use p] after [clear p] guarantees a freshly created pool element. Disposals are performed sequentially in an undefined order. @since 3.2.0 *) val wait_queue_length : _ t -> int (** [wait_queue_length p] returns the number of {!use} requests currently waiting for an element of the pool [p] to become available. @since 3.2.0 *) lwt-5.9.1/src/core/lwt_pqueue.ml000066400000000000000000000045031476253734400166200ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) module type OrderedType = sig type t val compare: t -> t -> int end module type S = sig type elt type t val empty: t val is_empty: t -> bool val add: elt -> t -> t val union: t -> t -> t val find_min: t -> elt val lookup_min: t -> elt option val remove_min: t -> t val size: t -> int end module Make(Ord: OrderedType) : (S with type elt = Ord.t) = struct type elt = Ord.t type t = tree list and tree = Node of elt * int * tree list let root (Node (x, _, _)) = x let rank (Node (_, r, _)) = r let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) = let c = Ord.compare x1 x2 in if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2) let rec ins t = function [] -> [t] | (t'::_) as ts when rank t < rank t' -> t::ts | t'::ts -> ins (link t t') ts let empty = [] let is_empty ts = ts = [] let add x ts = ins (Node (x, 0, [])) ts let rec union ts ts' = match ts, ts' with ([], _) -> ts' | (_, []) -> ts | (t1::ts1, t2::ts2) -> if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2) else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2 else ins (link t1 t2) (union ts1 ts2) let rec find_min = function [] -> raise Not_found | [t] -> root t | t::ts -> let x = find_min ts in let c = Ord.compare (root t) x in if c < 0 then root t else x let rec lookup_min = function | [] -> None | [t] -> Some (root t) | t::ts -> match lookup_min ts with | None -> None | Some x as result -> let c = Ord.compare (root t) x in if c < 0 then Some (root t) else result let rec get_min = function [] -> assert false | [t] -> (t, []) | t::ts -> let (t', ts') = get_min ts in let c = Ord.compare (root t) (root t') in if c < 0 then (t, ts) else (t', t::ts') let remove_min = function [] -> raise Not_found | ts -> let (Node (_, _, c), ts) = get_min ts in union (List.rev c) ts let rec size l = let sizetree (Node (_,_,tl)) = 1 + size tl in List.fold_left (fun s t -> s + sizetree t) 0 l end lwt-5.9.1/src/core/lwt_pqueue.mli000066400000000000000000000053331476253734400167730ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Functional priority queues (deprecated). A priority queue maintains, in the abstract sense, a set of elements in order, and supports fast lookup and removal of the first (“minimum”) element. This is used in Lwt for organizing threads that are waiting for timeouts. The priority queues in this module preserve “duplicates”: elements that compare equal in their order. @deprecated This module is an internal implementation detail of Lwt, and may be removed from the API at some point in the future. For alternatives, see, for example: {{: https://usr.lmf.cnrs.fr/~jcf/software.en.html#heap} Heaps} by Jean-Cristophe Filliatre, {{: https://simon.cedeela.fr/~simon/software/containers/CCHeap.html} containers}, {{: https://ocaml-batteries-team.github.io/batteries-included/hdoc2/BatHeap.html} Batteries}, or {{:https://github.com/pqwy/psq} psq}. *) [@@@ocaml.deprecated " This module is an implementation detail of Lwt. See https://ocsigen.org/lwt/latest/api/Lwt_pqueue"] (** Signature pairing an element type with an ordering function. *) module type OrderedType = sig type t val compare: t -> t -> int end (** Signature of priority queues. *) module type S = sig type elt (** Type of elements contained in the priority queue. *) type t (** Type of priority queues. *) val empty: t (** The empty priority queue. Contains no elements. *) val is_empty: t -> bool (** [is_empty q] evaluates to [true] iff [q] is empty. *) val add: elt -> t -> t (** [add e q] evaluates to a new priority queue, which contains all the elements of [q], and the additional element [e]. *) val union: t -> t -> t (** [union q q'] evaluates to a new priority queue, which contains all the elements of both [q] and [q']. *) val find_min: t -> elt (** [find_min q] evaluates to the minimum element of [q] if it is not empty, and raises [Not_found] otherwise. *) val lookup_min: t -> elt option (** [lookup_min q] evaluates to [Some e], where [e] is the minimum element of [q], if [q] is not empty, and evaluates to [None] otherwise. *) val remove_min: t -> t (** [remove_min q] evaluates to a new priority queue, which contains all the elements of [q] except for its minimum element. Raises [Not_found] if [q] is empty. *) val size: t -> int (** [size q] evaluates to the number of elements in [q]. *) end (** Generates priority queue types from ordered types. *) module Make(Ord: OrderedType) : S with type elt = Ord.t lwt-5.9.1/src/core/lwt_result.ml000066400000000000000000000046431476253734400166370ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Module [Lwt_result]: explicit error handling *) open Result type (+'a, +'b) t = ('a, 'b) Result.t Lwt.t let return x = Lwt.return (Ok x) let fail e = Lwt.return (Error e) let lift = Lwt.return let ok x = Lwt.map (fun y -> Ok y) x let error x = Lwt.map (fun y -> Error y) x let map f e = Lwt.map (function | Error e -> Error e | Ok x -> Ok (f x)) e let map_error f e = Lwt.map (function | Error e -> Error (f e) | Ok x -> Ok x) e let map_err f e = map_error f e let catch e = Lwt.catch (fun () -> ok (e ())) fail let get_exn e = Lwt.bind e (function | Ok x -> Lwt.return x | Error e -> Lwt.fail e) let bind e f = Lwt.bind e (function | Error e -> Lwt.return (Error e) | Ok x -> f x) let bind_error e f = Lwt.bind e (function | Error e -> f e | Ok x -> Lwt.return (Ok x)) let bind_lwt e f = Lwt.bind e (function | Ok x -> ok (f x) | Error e -> fail e) let bind_result e f = Lwt.map (function | Error e -> Error e | Ok x -> f x) e let bind_lwt_error e f = Lwt.bind e (function | Error e -> Lwt.bind (f e) fail | Ok x -> return x) let bind_lwt_err e f = bind_lwt_error e f let both a b = let s = ref None in let set_once e = match !s with | None -> s:= Some e | Some _ -> () in let (a,b) = map_error set_once a,map_error set_once b in let some_assert = function | None -> assert false | Some e -> Error e in Lwt.map (function | Ok x, Ok y -> Ok (x,y) | Error _, Ok _ | Ok _,Error _ | Error _, Error _ -> some_assert !s) (Lwt.both a b) let iter f r = Lwt.bind r (function | Ok x -> f x | Error _ -> Lwt.return_unit) let iter_error f r = Lwt.bind r (function | Error e -> f e | Ok _ -> Lwt.return_unit) module Infix = struct let (>>=) = bind let (>|=) e f = map f e end module Let_syntax = struct module Let_syntax = struct let return = return let map t ~f = map f t let bind t ~f = bind t f let both = both module Open_on_rhs = struct end end end module Syntax = struct let (let*) = bind let (and*) = both let (let+) x f = map f x let (and+) = both end include Infix lwt-5.9.1/src/core/lwt_result.mli000066400000000000000000000071101476253734400170000ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Explicit error handling @since 2.6.0 *) (** This module provides helpers for values of type [('a, 'b) result Lwt.t]. The module is experimental and may change in the future. *) type (+'a, +'b) t = ('a, 'b) result Lwt.t val return : 'a -> ('a, _) t val fail : 'b -> (_, 'b) t val lift : ('a, 'b) result -> ('a, 'b) t val ok : 'a Lwt.t -> ('a, _) t val error : 'b Lwt.t -> (_, 'b) t (** @since 5.6.0 *) val catch : (unit -> 'a Lwt.t) -> ('a, exn) t (** [catch x] behaves like [return y] if [x ()] evaluates to [y], and like [fail e] if [x ()] raises [e] *) val get_exn : ('a, exn) t -> 'a Lwt.t (** [get_exn] is the opposite of {!catch}: it unwraps the result type, returning the value in case of success, calls {!Lwt.fail} in case of error. *) val map : ('a -> 'b) -> ('a,'e) t -> ('b,'e) t val map_error : ('e1 -> 'e2) -> ('a,'e1) t -> ('a,'e2) t (** @since 5.6.0 *) val bind : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t val bind_error : ('a,'e1) t -> ('e1 -> ('a,'e2) t) -> ('a,'e2) t (** @since 5.6.0 *) val bind_lwt : ('a,'e) t -> ('a -> 'b Lwt.t) -> ('b,'e) t val bind_lwt_error : ('a,'e1) t -> ('e1 -> 'e2 Lwt.t) -> ('a,'e2) t (** @since 5.6.0 *) val bind_result : ('a,'e) t -> ('a -> ('b,'e) result) -> ('b,'e) t val both : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t (** [Lwt.both p_1 p_2] returns a promise that is pending until {e both} promises [p_1] and [p_2] become {e resolved}. If only [p_1] is [Error e], the promise is resolved with [Error e], If only [p_2] is [Error e], the promise is resolved with [Error e], If both [p_1] and [p_2] resolve with [Error _], the promise is resolved with the error that occurred first. *) val iter : ('a -> unit Lwt.t) -> ('a, 'e) t -> unit Lwt.t (** [iter f r] is [f v] if [r] is a promise resolved with [Ok v], and {!Lwt.return_unit} otherwise. @since Lwt 5.6.0 *) val iter_error : ('e -> unit Lwt.t) -> ('a, 'e) t -> unit Lwt.t (** [iter_error f r] is [f v] if [r] is a promise resolved with [Error v], and {!Lwt.return_unit} otherwise. @since Lwt 5.6.0 *) module Infix : sig val (>|=) : ('a,'e) t -> ('a -> 'b) -> ('b,'e) t val (>>=) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t end module Let_syntax : sig module Let_syntax : sig val return : 'a -> ('a, _) t (** See {!Lwt_result.return}. *) val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t (** See {!Lwt_result.map}. *) val bind : ('a, 'e) t -> f:('a -> ('b, 'e) t) -> ('b, 'e) t (** See {!Lwt_result.bind}. *) val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t (** See {!Lwt_result.both}. *) module Open_on_rhs : sig end end end (** {3 Let syntax} *) module Syntax : sig (** {1 Monadic syntax} *) val (let*) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t (** Syntax for {!bind}. *) val (and*) : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t (** Syntax for {!both}. *) (** {1 Applicative syntax} *) val (let+) : ('a,'e) t -> ('a -> 'b) -> ('b, 'e) t (** Syntax for {!map}. *) val (and+) : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t (** Syntax for {!both}. *) end include module type of Infix (** {3 Deprecated} *) val map_err : ('e1 -> 'e2) -> ('a,'e1) t -> ('a,'e2) t [@@deprecated "Alias to map_error"] (** @deprecated Alias to [map_error] since 5.6.0. *) val bind_lwt_err : ('a,'e1) t -> ('e1 -> 'e2 Lwt.t) -> ('a,'e2) t [@@deprecated "Alias to bind_lwt_error"] (** @deprecated Alias to [bind_lwt_error] since 5.6.0. *) lwt-5.9.1/src/core/lwt_seq.ml000066400000000000000000000201521476253734400161020ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Syntax open Lwt.Infix type +'a node = Nil | Cons of 'a * 'a t and 'a t = unit -> 'a node Lwt.t let return_nil = Lwt.return Nil let empty : 'a t = fun () -> return_nil let return (x : 'a) : 'a t = fun () -> Lwt.return (Cons (x, empty)) let return_lwt (x : 'a Lwt.t) : 'a t = fun () -> let+ x = x in Cons (x, empty) let cons x t () = Lwt.return (Cons (x, t)) let cons_lwt x t () = let+ x = x in Cons (x, t) (* A note on recursing through the seqs: When traversing a seq, the first time we evaluate a suspended node we are on the left of the first bind (>>=). In that case, we use apply to capture exceptions into promise rejection. This is only needed on the first iteration because we are within a callback passed to Lwt on the right-hand side of a bind after that. Throughout this file we use the same code pattern to achieve this: we shadow the recursive traversal function with an identical-but-for-the-apply non-recursive copy. *) let rec append seq1 seq2 () = seq1 () >>= function | Nil -> seq2 () | Cons (x, next) -> Lwt.return (Cons (x, append next seq2)) let append seq1 seq2 () = Lwt.apply seq1 () >>= function | Nil -> seq2 () | Cons (x, next) -> Lwt.return (Cons (x, append next seq2)) let rec map f seq () = seq () >|= function | Nil -> Nil | Cons (x, next) -> let x = f x in Cons (x, map f next) let map f seq () = Lwt.apply seq () >|= function | Nil -> Nil | Cons (x, next) -> let x = f x in Cons (x, map f next) let rec map_s f seq () = seq () >>= function | Nil -> return_nil | Cons (x, next) -> let+ x = f x in Cons (x, map_s f next) let map_s f seq () = Lwt.apply seq () >>= function | Nil -> return_nil | Cons (x, next) -> let+ x = f x in Cons (x, map_s f next) let rec filter_map f seq () = seq () >>= function | Nil -> return_nil | Cons (x, next) -> ( let x = f x in match x with | None -> filter_map f next () | Some y -> Lwt.return (Cons (y, filter_map f next) )) let filter_map f seq () = Lwt.apply seq () >>= function | Nil -> return_nil | Cons (x, next) -> ( let x = f x in match x with | None -> filter_map f next () | Some y -> Lwt.return (Cons (y, filter_map f next) )) let rec filter_map_s f seq () = seq () >>= function | Nil -> return_nil | Cons (x, next) -> ( let* x = f x in match x with | None -> filter_map_s f next () | Some y -> Lwt.return (Cons (y, filter_map_s f next) )) let filter_map_s f seq () = Lwt.apply seq () >>= function | Nil -> return_nil | Cons (x, next) -> ( let* x = f x in match x with | None -> filter_map_s f next () | Some y -> Lwt.return (Cons (y, filter_map_s f next) )) let rec filter f seq () = seq () >>= function | Nil -> return_nil | Cons (x, next) -> let ok = f x in if ok then Lwt.return (Cons (x, filter f next)) else filter f next () let filter f seq () = Lwt.apply seq () >>= function | Nil -> return_nil | Cons (x, next) -> let ok = f x in if ok then Lwt.return (Cons (x, filter f next)) else filter f next () let rec filter_s f seq () = seq () >>= function | Nil -> return_nil | Cons (x, next) -> let* ok = f x in if ok then Lwt.return (Cons (x, filter_s f next)) else filter_s f next () let filter_s f seq () = Lwt.apply seq () >>= function | Nil -> return_nil | Cons (x, next) -> let* ok = f x in if ok then Lwt.return (Cons (x, filter_s f next)) else filter_s f next () let rec flat_map f seq () = seq () >>= function | Nil -> return_nil | Cons (x, next) -> flat_map_app f (f x) next () (* this is [append seq (flat_map f tail)] *) and flat_map_app f seq tail () = seq () >>= function | Nil -> flat_map f tail () | Cons (x, next) -> Lwt.return (Cons (x, flat_map_app f next tail)) let flat_map f seq () = Lwt.apply seq () >>= function | Nil -> return_nil | Cons (x, next) -> flat_map_app f (f x) next () let fold_left f acc seq = let rec aux f acc seq = seq () >>= function | Nil -> Lwt.return acc | Cons (x, next) -> let acc = f acc x in aux f acc next in let aux f acc seq = Lwt.apply seq () >>= function | Nil -> Lwt.return acc | Cons (x, next) -> let acc = f acc x in aux f acc next in aux f acc seq let fold_left_s f acc seq = let rec aux f acc seq = seq () >>= function | Nil -> Lwt.return acc | Cons (x, next) -> let* acc = f acc x in aux f acc next in let aux f acc seq = Lwt.apply seq () >>= function | Nil -> Lwt.return acc | Cons (x, next) -> let* acc = f acc x in aux f acc next in aux f acc seq let iter f seq = let rec aux seq = seq () >>= function | Nil -> Lwt.return_unit | Cons (x, next) -> f x; aux next in let aux seq = Lwt.apply seq () >>= function | Nil -> Lwt.return_unit | Cons (x, next) -> f x; aux next in aux seq let iter_s f seq = let rec aux seq = seq () >>= function | Nil -> Lwt.return_unit | Cons (x, next) -> let* () = f x in aux next in let aux seq = Lwt.apply seq () >>= function | Nil -> Lwt.return_unit | Cons (x, next) -> let* () = f x in aux next in aux seq let iter_p f seq = let rec aux acc seq = seq () >>= function | Nil -> Lwt.join acc | Cons (x, next) -> let p = f x in aux (p::acc) next in let aux acc seq = Lwt.apply seq () >>= function | Nil -> Lwt.join acc | Cons (x, next) -> let p = f x in aux (p::acc) next in aux [] seq let iter_n ?(max_concurrency = 1) f seq = begin if max_concurrency <= 0 then let message = Printf.sprintf "Lwt_seq.iter_n: max_concurrency must be > 0, %d given" max_concurrency in invalid_arg message end; let rec loop running available seq = begin if available > 0 then ( Lwt.return (running, available) ) else ( Lwt.nchoose_split running >>= fun (complete, running) -> Lwt.return (running, available + List.length complete) ) end >>= fun (running, available) -> seq () >>= function | Nil -> Lwt.join running | Cons (elt, seq) -> loop (f elt :: running) (pred available) seq in (* because the recursion is more complicated here, we apply the seq directly at the call-site instead *) loop [] max_concurrency (fun () -> Lwt.apply seq ()) let rec unfold f u () = match f u with | None -> return_nil | Some (x, u') -> Lwt.return (Cons (x, unfold f u')) | exception exc when Lwt.Exception_filter.run exc -> Lwt.reraise exc let rec unfold_lwt f u () = let* x = f u in match x with | None -> return_nil | Some (x, u') -> Lwt.return (Cons (x, unfold_lwt f u')) let unfold_lwt f u () = let* x = Lwt.apply f u in match x with | None -> return_nil | Some (x, u') -> Lwt.return (Cons (x, unfold_lwt f u')) let rec of_list l () = Lwt.return (match l with [] -> Nil | h :: t -> Cons (h, of_list t)) let to_list (seq : 'a t) = let rec aux f seq = Lwt.bind (seq ()) (function | Nil -> Lwt.return (f []) | Cons (h, t) -> aux (fun x -> f (h :: x)) t) in aux (fun x -> x) (Lwt.apply seq) let rec of_seq seq () = match seq () with | Seq.Nil -> return_nil | Seq.Cons (x, next) -> Lwt.return (Cons (x, (of_seq next))) | exception exn when Lwt.Exception_filter.run exn -> Lwt.reraise exn let rec of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () -> match seq () with | Seq.Nil -> return_nil | Seq.Cons (x, next) -> let+ x = x in let next = of_seq_lwt next in Cons (x, next) let of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () -> match seq () with | Seq.Nil -> return_nil | Seq.Cons (x, next) -> let+ x = x in let next = of_seq_lwt next in Cons (x, next) | exception exc when Lwt.Exception_filter.run exc -> Lwt.reraise exc lwt-5.9.1/src/core/lwt_seq.mli000066400000000000000000000145361476253734400162640ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** @since 5.5.0 *) type 'a t = unit -> 'a node Lwt.t (** The type of delayed lists containing elements of type ['a]. Note that the concrete list node ['a node] is delayed under a closure, not a [lazy] block, which means it might be recomputed every time we access it. *) and +'a node = Nil | Cons of 'a * 'a t (** A fully-evaluated list node, either empty or containing an element and a delayed tail. *) val empty : 'a t (** The empty sequence, containing no elements. *) val return : 'a -> 'a t (** The singleton sequence containing only the given element. *) val return_lwt : 'a Lwt.t -> 'a t (** The singleton sequence containing only the given promised element. *) val cons : 'a -> 'a t -> 'a t (** [cons x xs] is the sequence containing the element [x] followed by the sequence [xs] *) val cons_lwt : 'a Lwt.t -> 'a t -> 'a t (** [cons x xs] is the sequence containing the element promised by [x] followed by the sequence [xs] *) val append : 'a t -> 'a t -> 'a t (** [append xs ys] is the sequence [xs] followed by the sequence [ys] *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f seq] returns a new sequence whose elements are the elements of [seq], transformed by [f]. This transformation is lazy, it only applies when the result is traversed. *) val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t (** [map_s f seq] is like [map f seq] but [f] is a function that returns a promise. Note that there is no concurrency between the promises from the underlying sequence [seq] and the promises from applying the function [f]. In other words, the next promise-element of the underlying sequence ([seq]) is only created when the current promise-element of the returned sequence (as mapped by [f]) has resolved. This scheduling is true for all the [_s] functions of this module. *) val filter : ('a -> bool) -> 'a t -> 'a t (** Remove from the sequence the elements that do not satisfy the given predicate. This transformation is lazy, it only applies when the result is traversed. *) val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t (** [filter_s] is like [filter] but the predicate returns a promise. See {!map_s} for additional details about scheduling. *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** Apply the function to every element; if [f x = None] then [x] is dropped; if [f x = Some y] then [y] is returned. This transformation is lazy, it only applies when the result is traversed. *) val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t (** [filter_map_s] is like [filter] but the predicate returns a promise. See {!map_s} for additional details about scheduling. *) val flat_map : ('a -> 'b t) -> 'a t -> 'b t (** Map each element to a subsequence, then return each element of this sub-sequence in turn. This transformation is lazy, it only applies when the result is traversed. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t (** Traverse the sequence from left to right, combining each element with the accumulator using the given function. The traversal happens immediately and will not terminate (i.e., the promise will not resolve) on infinite sequences. *) val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t (** [fold_left_s] is like [fold_left] but the function returns a promise. See {!map_s} for additional details about scheduling. *) val iter : ('a -> unit) -> 'a t -> unit Lwt.t (** Iterate on the sequence, calling the (imperative) function on every element. The sequence's next node is evaluated only once the function has finished processing the current element. More formally: the promise for the [n+1]th node of the sequence is created only once the promise returned by [f] on the [n]th element of the sequence has resolved. The traversal happens immediately and will not terminate (i.e., the promise will not resolve) on infinite sequences. *) val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** [iter_s] is like [iter] but the function returns a promise. See {!map_s} for additional details about scheduling. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** Iterate on the sequence, calling the (imperative) function on every element. The sequence's next node is evaluated as soon as the previous node is resolved. The traversal happens immediately and will not terminate (i.e., the promise will not resolve) on infinite sequences. *) val iter_n : ?max_concurrency:int -> ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** [iter_n ~max_concurrency f s] Iterates on the sequence [s], calling the (imperative) function [f] on every element. The sum total of unresolved promises returned by [f] never exceeds [max_concurrency]. Node suspensions are evaluated only when there is capacity for [f]-promises to be evaluated. Consequently, there might be significantly fewer than [max_concurrency] promises being evaluated concurrently; especially if the node suspensions take longer to evaluate than the [f]-promises. The traversal happens immediately and will not terminate (i.e., the promise will not resolve) on infinite sequences. @param max_concurrency defaults to [1]. @raise Invalid_argument if [max_concurrency < 1]. *) val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t (** Build a sequence from a step function and an initial value. [unfold f u] returns [empty] if the promise [f u] resolves to [None], or [fun () -> Lwt.return (Cons (x, unfold f y))] if the promise [f u] resolves to [Some (x, y)]. *) val unfold_lwt : ('b -> ('a * 'b) option Lwt.t) -> 'b -> 'a t (** [unfold_lwt] is like [unfold] but the step function returns a promise. *) val to_list : 'a t -> 'a list Lwt.t (** Convert a sequence to a list, preserving order. The traversal happens immediately and will not terminate (i.e., the promise will not resolve) on infinite sequences. *) val of_list : 'a list -> 'a t (** Convert a list to a sequence, preserving order. *) val of_seq : 'a Seq.t -> 'a t (** Convert from ['a Stdlib.Seq.t] to ['a Lwt_seq.t]. This transformation is lazy, it only applies when the result is traversed. *) val of_seq_lwt : 'a Lwt.t Seq.t -> 'a t (** Convert from ['a Lwt.t Stdlib.Seq.t] to ['a Lwt_seq.t]. This transformation is lazy, it only applies when the result is traversed. *) lwt-5.9.1/src/core/lwt_sequence.ml000066400000000000000000000116251476253734400171270ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) exception Empty type 'a t = { mutable prev : 'a t; mutable next : 'a t; } type 'a node = { node_prev : 'a t; node_next : 'a t; mutable node_data : 'a; mutable node_active : bool; } external seq_of_node : 'a node -> 'a t = "%identity" external node_of_seq : 'a t -> 'a node = "%identity" (* +-----------------------------------------------------------------+ | Operations on nodes | +-----------------------------------------------------------------+ *) let get node = node.node_data let set node data = node.node_data <- data let remove node = if node.node_active then begin node.node_active <- false; let seq = seq_of_node node in seq.prev.next <- seq.next; seq.next.prev <- seq.prev end (* +-----------------------------------------------------------------+ | Operations on sequences | +-----------------------------------------------------------------+ *) let create () = let rec seq = { prev = seq; next = seq } in seq let clear seq = seq.prev <- seq; seq.next <- seq let is_empty seq = seq.next == seq let length seq = let rec loop curr len = if curr == seq then len else let node = node_of_seq curr in loop node.node_next (len + 1) in loop seq.next 0 let add_l data seq = let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in seq.next.prev <- seq_of_node node; seq.next <- seq_of_node node; node let add_r data seq = let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in seq.prev.next <- seq_of_node node; seq.prev <- seq_of_node node; node let take_l seq = if is_empty seq then raise Empty else begin let node = node_of_seq seq.next in remove node; node.node_data end let take_r seq = if is_empty seq then raise Empty else begin let node = node_of_seq seq.prev in remove node; node.node_data end let take_opt_l seq = if is_empty seq then None else begin let node = node_of_seq seq.next in remove node; Some node.node_data end let take_opt_r seq = if is_empty seq then None else begin let node = node_of_seq seq.prev in remove node; Some node.node_data end let transfer_l s1 s2 = s2.next.prev <- s1.prev; s1.prev.next <- s2.next; s2.next <- s1.next; s1.next.prev <- s2; s1.prev <- s1; s1.next <- s1 let transfer_r s1 s2 = s2.prev.next <- s1.next; s1.next.prev <- s2.prev; s2.prev <- s1.prev; s1.prev.next <- s2; s1.prev <- s1; s1.next <- s1 let iter_l f seq = let rec loop curr = if curr != seq then begin let node = node_of_seq curr in if node.node_active then f node.node_data; loop node.node_next end in loop seq.next let iter_r f seq = let rec loop curr = if curr != seq then begin let node = node_of_seq curr in if node.node_active then f node.node_data; loop node.node_prev end in loop seq.prev let iter_node_l f seq = let rec loop curr = if curr != seq then begin let node = node_of_seq curr in if node.node_active then f node; loop node.node_next end in loop seq.next let iter_node_r f seq = let rec loop curr = if curr != seq then begin let node = node_of_seq curr in if node.node_active then f node; loop node.node_prev end in loop seq.prev let fold_l f seq acc = let rec loop curr acc = if curr == seq then acc else let node = node_of_seq curr in if node.node_active then loop node.node_next (f node.node_data acc) else loop node.node_next acc in loop seq.next acc let fold_r f seq acc = let rec loop curr acc = if curr == seq then acc else let node = node_of_seq curr in if node.node_active then loop node.node_prev (f node.node_data acc) else loop node.node_prev acc in loop seq.prev acc let find_node_l f seq = let rec loop curr = if curr != seq then let node = node_of_seq curr in if node.node_active then if f node.node_data then node else loop node.node_next else loop node.node_next else raise Not_found in loop seq.next let find_node_r f seq = let rec loop curr = if curr != seq then let node = node_of_seq curr in if node.node_active then if f node.node_data then node else loop node.node_prev else loop node.node_prev else raise Not_found in loop seq.prev let find_node_opt_l f seq = try Some (find_node_l f seq) with Not_found -> None let find_node_opt_r f seq = try Some (find_node_r f seq) with Not_found -> None lwt-5.9.1/src/core/lwt_sequence.mli000066400000000000000000000120071476253734400172730ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Mutable sequence of elements (deprecated) *) (** A sequence is an object holding a list of elements which support the following operations: - adding an element to the left or the right in time and space O(1) - taking an element from the left or the right in time and space O(1) - removing a previously added element from a sequence in time and space O(1) - removing an element while the sequence is being transversed. @deprecated This module should be an internal implementation detail of Lwt, and may be removed from the API at some point in the future. Use package {{:https://github.com/mirage/lwt-dllist} [lwt-dllist]} instead. *) [@@@ocaml.deprecated " Use package lwt-dllist. See https://github.com/mirage/lwt-dllist"] type 'a t (** Type of a sequence holding values of type ['a] *) type 'a node (** Type of a node holding one value of type ['a] in a sequence *) (** {2 Operation on nodes} *) val get : 'a node -> 'a (** Returns the contents of a node *) val set : 'a node -> 'a -> unit (** Change the contents of a node *) val remove : 'a node -> unit (** Removes a node from the sequence it is part of. It does nothing if the node has already been removed. *) (** {2 Operations on sequence} *) val create : unit -> 'a t (** [create ()] creates a new empty sequence *) val clear : 'a t -> unit (** Removes all nodes from the given sequence. The nodes are not actually mutated to note their removal. Only the sequence's pointers are updated. *) val is_empty : 'a t -> bool (** Returns [true] iff the given sequence is empty *) val length : 'a t -> int (** Returns the number of elements in the given sequence. This is a O(n) operation where [n] is the number of elements in the sequence. *) val add_l : 'a -> 'a t -> 'a node (** [add_l x s] adds [x] to the left of the sequence [s] *) val add_r : 'a -> 'a t -> 'a node (** [add_r x s] adds [x] to the right of the sequence [s] *) exception Empty (** Exception raised by [take_l] and [take_r] and when the sequence is empty *) val take_l : 'a t -> 'a (** [take_l x s] remove and returns the leftmost element of [s] @raise Empty if the sequence is empty *) val take_r : 'a t -> 'a (** [take_r x s] remove and returns the rightmost element of [s] @raise Empty if the sequence is empty *) val take_opt_l : 'a t -> 'a option (** [take_opt_l x s] remove and returns [Some x] where [x] is the leftmost element of [s] or [None] if [s] is empty *) val take_opt_r : 'a t -> 'a option (** [take_opt_r x s] remove and returns [Some x] where [x] is the rightmost element of [s] or [None] if [s] is empty *) val transfer_l : 'a t -> 'a t -> unit (** [transfer_l s1 s2] removes all elements of [s1] and add them at the left of [s2]. This operation runs in constant time and space. *) val transfer_r : 'a t -> 'a t -> unit (** [transfer_r s1 s2] removes all elements of [s1] and add them at the right of [s2]. This operation runs in constant time and space. *) (** {2 Sequence iterators} *) (** Note: it is OK to remove a node while traversing a sequence *) val iter_l : ('a -> unit) -> 'a t -> unit (** [iter_l f s] applies [f] on all elements of [s] starting from the left *) val iter_r : ('a -> unit) -> 'a t -> unit (** [iter_r f s] applies [f] on all elements of [s] starting from the right *) val iter_node_l : ('a node -> unit) -> 'a t -> unit (** [iter_node_l f s] applies [f] on all nodes of [s] starting from the left *) val iter_node_r : ('a node -> unit) -> 'a t -> unit (** [iter_node_r f s] applies [f] on all nodes of [s] starting from the right *) val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold_l f s] is: {[ fold_l f s x = f en (... (f e2 (f e1 x))) ]} where [e1], [e2], ..., [en] are the elements of [s] *) val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold_r f s] is: {[ fold_r f s x = f e1 (f e2 (... (f en x))) ]} where [e1], [e2], ..., [en] are the elements of [s] *) val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option (** [find_node_opt_l f s] returns [Some x], where [x] is the first node of [s] starting from the left that satisfies [f] or [None] if none exists. *) val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option (** [find_node_opt_r f s] returns [Some x], where [x] is the first node of [s] starting from the right that satisfies [f] or [None] if none exists. *) val find_node_l : ('a -> bool) -> 'a t -> 'a node (** [find_node_l f s] returns the first node of [s] starting from the left that satisfies [f] or raises [Not_found] if none exists. *) val find_node_r : ('a -> bool) -> 'a t -> 'a node (** [find_node_r f s] returns the first node of [s] starting from the right that satisfies [f] or raises [Not_found] if none exists. *) lwt-5.9.1/src/core/lwt_stream.ml000066400000000000000000000661271476253734400166210ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix exception Closed exception Full exception Empty (* A node in a queue of pending data. *) type 'a node = { mutable next : 'a node; (* Next node in the queue. For the last node it points to itself. *) mutable data : 'a option; (* Data of this node. For the last node it is always [None]. *) } (* Note: a queue for an exhausted stream is represented by a node containing [None] followed by a node with itself as next and [None] as data. *) let new_node () = let rec node = { next = node; data = None } in node (* Type of a stream source using a function to create new elements. *) type 'a from = { from_create : unit -> 'a option Lwt.t; (* Function used to create new elements. *) mutable from_thread : unit Lwt.t; (* Thread which: - wait for the thread returned by the last call to [from_next], - add the next element to the end of the queue. If it is a sleeping thread, then it must be used instead of creating a new one with [from_create]. *) } (* Type of a stream source for push streams. *) type push = { mutable push_signal : unit Lwt.t; (* Thread signaled when a new element is added to the stream. *) mutable push_waiting : bool; (* Is a thread waiting on [push_signal] ? *) mutable push_external : Obj.t [@ocaml.warning "-69"]; (* Reference to an external source. *) } (* Type of a stream source for bounded-push streams. *) type 'a push_bounded = { mutable pushb_signal : unit Lwt.t; (* Thread signaled when a new element is added to the stream. *) mutable pushb_waiting : bool; (* Is a thread waiting on [pushb_signal] ? *) mutable pushb_size : int; (* Size of the queue. *) mutable pushb_count : int; (* Current length of the queue. *) mutable pushb_pending : 'a option; (* The next element to push if a thread blocked on push. We store it here to be sure it will be the first element to be added when space becomes available. *) mutable pushb_push_waiter : unit Lwt.t; mutable pushb_push_wakener : unit Lwt.u; (* Thread blocked on push. *) mutable pushb_external : Obj.t [@ocaml.warning "-69"]; (* Reference to an external source. *) } (* Source of a stream. *) type 'a source = | From of 'a from | From_direct of (unit -> 'a option) | Push of push | Push_bounded of 'a push_bounded type 'a t = { source : 'a source; (* The source of the stream. *) close : unit Lwt.u; (* A wakener for a thread that sleeps until the stream is closed. *) closed : unit Lwt.t; (* A waiter for a thread that sleeps until the stream is closed. *) mutable node : 'a node; (* Pointer to first pending element, or to [last] if there is no pending element. *) last : 'a node ref; (* Node marking the end of the queue of pending elements. *) } class type ['a] bounded_push = object method size : int method resize : int -> unit method push : 'a -> unit Lwt.t method close : unit method count : int method blocked : bool method closed : bool method set_reference : 'a. 'a -> unit end (* The only difference between two clones is the pointer to the first pending element. *) let clone s = (match s.source with | Push_bounded _ -> invalid_arg "Lwt_stream.clone" | From _ | From_direct _ | Push _ -> ()); { source = s.source; close = s.close; closed = s.closed; node = s.node; last = s.last; } let from_source source = let node = new_node () in let closed, close = Lwt.wait () in { source ; close ; closed ; node ; last = ref node } let from f = from_source (From { from_create = f; from_thread = Lwt.return_unit }) let from_direct f = from_source (From_direct f) let closed s = s.closed let is_closed s = not (Lwt.is_sleeping (closed s)) let enqueue' e last = let node = !last and new_last = new_node () in node.data <- e; node.next <- new_last; last := new_last let enqueue e s = enqueue' e s.last let create_with_reference () = (* Create the source for notifications of new elements. *) let source, push_signal_resolver = let push_signal, push_signal_resolver = Lwt.wait () in ({ push_signal; push_waiting = false; push_external = Obj.repr () }, ref push_signal_resolver) in let t = from_source (Push source) in (* [push] should not close over [t] so that it can be garbage collected even * there are still references to [push]. Unpack all the components of [t] * that [push] needs and reference those identifiers instead. *) let close = t.close and closed = t.closed and last = t.last in (* The push function. It does not keep a reference to the stream. *) let push x = if not (Lwt.is_sleeping closed) then raise Closed; (* Push the element at the end of the queue. *) enqueue' x last; (* Send a signal if at least one thread is waiting for a new element. *) if source.push_waiting then begin source.push_waiting <- false; (* Update threads. *) let old_push_signal_resolver = !push_signal_resolver in let new_waiter, new_push_signal_resolver = Lwt.wait () in source.push_signal <- new_waiter; push_signal_resolver := new_push_signal_resolver; (* Signal that a new value has been received. *) Lwt.wakeup_later old_push_signal_resolver () end; (* Do this at the end in case one of the function raise an exception. *) if x = None then Lwt.wakeup close () in (t, push, fun x -> source.push_external <- Obj.repr x) let return a = let stream, push, _ = create_with_reference () in push (Some a); push None; stream let return_lwt a = let source, push, _ = create_with_reference () in Lwt.dont_wait (fun () -> Lwt.bind a (fun x -> push (Some x); push None; Lwt.return_unit)) (fun _exc -> push None); source let of_seq s = let s = ref s in let get () = match !s () with | Seq.Nil -> None | Seq.Cons (elt, s') -> s := s'; Some elt in from_direct get let of_lwt_seq s = let s = ref s in let get () = !s () >|= function | Lwt_seq.Nil -> None | Lwt_seq.Cons (elt, s') -> s := s'; Some elt in from get let create () = let source, push, _ = create_with_reference () in (source, push) let of_iter iter i = let stream, push = create () in iter (fun x -> push (Some x)) i; push None; stream let of_list l = of_iter List.iter l let of_array a = of_iter Array.iter a let of_string s = of_iter String.iter s (* Add the pending element to the queue and notify the blocked pushed. Precondition: info.pushb_pending = Some _ This does not modify info.pushb_count. *) let notify_pusher info last = (* Push the element at the end of the queue. *) enqueue' info.pushb_pending last; (* Clear pending element. *) info.pushb_pending <- None; (* Wakeup the pusher. *) let old_wakener = info.pushb_push_wakener in let waiter, wakener = Lwt.task () in info.pushb_push_waiter <- waiter; info.pushb_push_wakener <- wakener; Lwt.wakeup_later old_wakener () class ['a] bounded_push_impl (info : 'a push_bounded) wakener_cell last close = object val mutable closed = false method size = info.pushb_size method resize size = if size < 0 then invalid_arg "Lwt_stream.bounded_push#resize"; info.pushb_size <- size; if info.pushb_count < info.pushb_size && info.pushb_pending <> None then begin info.pushb_count <- info.pushb_count + 1; notify_pusher info last end method push x = if closed then Lwt.fail Closed else if info.pushb_pending <> None then Lwt.fail Full else if info.pushb_count >= info.pushb_size then begin info.pushb_pending <- Some x; Lwt.catch (fun () -> info.pushb_push_waiter) (fun exn -> match exn with | Lwt.Canceled -> info.pushb_pending <- None; let waiter, wakener = Lwt.task () in info.pushb_push_waiter <- waiter; info.pushb_push_wakener <- wakener; Lwt.reraise exn | _ -> Lwt.reraise exn) end else begin (* Push the element at the end of the queue. *) enqueue' (Some x) last; info.pushb_count <- info.pushb_count + 1; (* Send a signal if at least one thread is waiting for a new element. *) if info.pushb_waiting then begin info.pushb_waiting <- false; (* Update threads. *) let old_wakener = !wakener_cell in let new_waiter, new_wakener = Lwt.wait () in info.pushb_signal <- new_waiter; wakener_cell := new_wakener; (* Signal that a new value has been received. *) Lwt.wakeup_later old_wakener () end; Lwt.return_unit end method close = if not closed then begin closed <- true; let node = !last and new_last = new_node () in node.data <- None; node.next <- new_last; last := new_last; if info.pushb_pending <> None then begin info.pushb_pending <- None; Lwt.wakeup_later_exn info.pushb_push_wakener Closed end; (* Send a signal if at least one thread is waiting for a new element. *) if info.pushb_waiting then begin info.pushb_waiting <- false; let old_wakener = !wakener_cell in (* Signal that a new value has been received. *) Lwt.wakeup_later old_wakener () end; Lwt.wakeup close (); end method count = info.pushb_count method blocked = info.pushb_pending <> None method closed = closed method set_reference : 'a. 'a -> unit = fun x -> info.pushb_external <- Obj.repr x end let create_bounded size = if size < 0 then invalid_arg "Lwt_stream.create_bounded"; (* Create the source for notifications of new elements. *) let info, wakener_cell = let waiter, wakener = Lwt.wait () in let push_waiter, push_wakener = Lwt.task () in ({ pushb_signal = waiter; pushb_waiting = false; pushb_size = size; pushb_count = 0; pushb_pending = None; pushb_push_waiter = push_waiter; pushb_push_wakener = push_wakener; pushb_external = Obj.repr () }, ref wakener) in let t = from_source (Push_bounded info) in (t, new bounded_push_impl info wakener_cell t.last t.close) (* Wait for a new element to be added to the queue of pending element of the stream. *) let feed s = match s.source with | From from -> (* There is already a thread started to create a new element, wait for this one to terminate. *) if Lwt.is_sleeping from.from_thread then Lwt.protected from.from_thread else begin (* Otherwise request a new element. *) let thread = (* The function [from_create] can raise an exception (with [raise], rather than returning a failed promise with [Lwt.fail]). In this case, we have to catch the exception and turn it into a safe failed promise. *) Lwt.catch (fun () -> from.from_create () >>= fun x -> (* Push the element to the end of the queue. *) enqueue x s; if x = None then Lwt.wakeup s.close (); Lwt.return_unit) Lwt.reraise in (* Allow other threads to access this thread. *) from.from_thread <- thread; Lwt.protected thread end | From_direct f -> let x = f () in (* Push the element to the end of the queue. *) enqueue x s; if x = None then Lwt.wakeup s.close (); Lwt.return_unit | Push push -> push.push_waiting <- true; Lwt.protected push.push_signal | Push_bounded push -> push.pushb_waiting <- true; Lwt.protected push.pushb_signal (* Remove [node] from the top of the queue, or do nothing if it was already consumed. Precondition: node.data <> None *) let consume s node = if node == s.node then begin s.node <- node.next; match s.source with | Push_bounded info -> if info.pushb_pending = None then info.pushb_count <- info.pushb_count - 1 else notify_pusher info s.last | From _ | From_direct _ | Push _ -> () end let rec peek_rec s node = if node == !(s.last) then feed s >>= fun () -> peek_rec s node else Lwt.return node.data let peek s = peek_rec s s.node let rec npeek_rec node acc n s = if n <= 0 then Lwt.return (List.rev acc) else if node == !(s.last) then feed s >>= fun () -> npeek_rec node acc n s else match node.data with | Some x -> npeek_rec node.next (x :: acc) (n - 1) s | None -> Lwt.return (List.rev acc) let npeek n s = npeek_rec s.node [] n s let rec get_rec s node = if node == !(s.last) then feed s >>= fun () -> get_rec s node else begin if node.data <> None then consume s node; Lwt.return node.data end let get s = get_rec s s.node let rec get_exn_rec s node = if node == !(s.last) then Lwt.try_bind (fun () -> feed s) (fun () -> get_exn_rec s node) (fun exn -> Lwt.return (Some (Result.Error exn))) else match node.data with | Some value -> consume s node; Lwt.return (Some (Result.Ok value)) | None -> Lwt.return_none let wrap_exn s = from (fun () -> get_exn_rec s s.node) let rec nget_rec node acc n s = if n <= 0 then Lwt.return (List.rev acc) else if node == !(s.last) then feed s >>= fun () -> nget_rec node acc n s else match s.node.data with | Some x -> consume s node; nget_rec node.next (x :: acc) (n - 1) s | None -> Lwt.return (List.rev acc) let nget n s = nget_rec s.node [] n s let rec get_while_rec node acc f s = if node == !(s.last) then feed s >>= fun () -> get_while_rec node acc f s else match node.data with | Some x -> let test = f x in if test then begin consume s node; get_while_rec node.next (x :: acc) f s end else Lwt.return (List.rev acc) | None -> Lwt.return (List.rev acc) let get_while f s = get_while_rec s.node [] f s let rec get_while_s_rec node acc f s = if node == !(s.last) then feed s >>= fun () -> get_while_s_rec node acc f s else match node.data with | Some x -> begin f x >>= function | true -> consume s node; get_while_s_rec node.next (x :: acc) f s | false -> Lwt.return (List.rev acc) end | None -> Lwt.return (List.rev acc) let get_while_s f s = get_while_s_rec s.node [] f s let rec next_rec s node = if node == !(s.last) then feed s >>= fun () -> next_rec s node else match node.data with | Some x -> consume s node; Lwt.return x | None -> Lwt.fail Empty let next s = next_rec s s.node let rec last_new_rec node x s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> last_new_rec node x s | Lwt.Fail exn -> Lwt.fail exn | Lwt.Sleep -> Lwt.return x else match node.data with | Some x -> consume s node; last_new_rec node.next x s | None -> Lwt.return x let last_new s = let node = s.node in if node == !(s.last) then let thread = next s in match Lwt.state thread with | Lwt.Return x -> last_new_rec node x s | Lwt.Fail _ | Lwt.Sleep -> thread else match node.data with | Some x -> consume s node; last_new_rec node.next x s | None -> Lwt.fail Empty let rec to_list_rec node acc s = if node == !(s.last) then feed s >>= fun () -> to_list_rec node acc s else match node.data with | Some x -> consume s node; to_list_rec node.next (x :: acc) s | None -> Lwt.return (List.rev acc) let to_list s = to_list_rec s.node [] s let rec to_string_rec node buf s = if node == !(s.last) then feed s >>= fun () -> to_string_rec node buf s else match node.data with | Some x -> consume s node; Buffer.add_char buf x; to_string_rec node.next buf s | None -> Lwt.return (Buffer.contents buf) let to_string s = to_string_rec s.node (Buffer.create 128) s let junk s = let node = s.node in if node == !(s.last) then begin feed s >>= fun () -> if node.data <> None then consume s node; Lwt.return_unit end else begin if node.data <> None then consume s node; Lwt.return_unit end let rec njunk_rec node n s = if n <= 0 then Lwt.return_unit else if node == !(s.last) then feed s >>= fun () -> njunk_rec node n s else match node.data with | Some _ -> consume s node; njunk_rec node.next (n - 1) s | None -> Lwt.return_unit let njunk n s = njunk_rec s.node n s let rec junk_while_rec node f s = if node == !(s.last) then feed s >>= fun () -> junk_while_rec node f s else match node.data with | Some x -> let test = f x in if test then begin consume s node; junk_while_rec node.next f s end else Lwt.return_unit | None -> Lwt.return_unit let junk_while f s = junk_while_rec s.node f s let rec junk_while_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> junk_while_s_rec node f s else match node.data with | Some x -> begin f x >>= function | true -> consume s node; junk_while_s_rec node.next f s | false -> Lwt.return_unit end | None -> Lwt.return_unit let junk_while_s f s = junk_while_s_rec s.node f s let rec junk_available_rec node s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> junk_available_rec node s | Lwt.Fail exn -> raise exn | Lwt.Sleep -> () else match node.data with | Some _ -> consume s node; junk_available_rec node.next s | None -> () let junk_available s = junk_available_rec s.node s let junk_old s = Lwt.return (junk_available s) let rec get_available_rec node acc s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> get_available_rec node acc s | Lwt.Fail exn -> raise exn | Lwt.Sleep -> List.rev acc else match node.data with | Some x -> consume s node; get_available_rec node.next (x :: acc) s | None -> List.rev acc let get_available s = get_available_rec s.node [] s let rec get_available_up_to_rec node acc n s = if n <= 0 then List.rev acc else if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> get_available_up_to_rec node acc n s | Lwt.Fail exn -> raise exn | Lwt.Sleep -> List.rev acc else match s.node.data with | Some x -> consume s node; get_available_up_to_rec node.next (x :: acc) (n - 1) s | None -> List.rev acc let get_available_up_to n s = get_available_up_to_rec s.node [] n s let rec is_empty s = if s.node == !(s.last) then feed s >>= fun () -> is_empty s else Lwt.return (s.node.data = None) let map f s = from (fun () -> get s >|= function | Some x -> let x = f x in Some x | None -> None) let map_s f s = from (fun () -> get s >>= function | Some x -> f x >|= (fun x -> Some x) | None -> Lwt.return_none) let filter f s = let rec next () = let t = get s in t >>= function | Some x -> let test = f x in if test then t else next () | None -> Lwt.return_none in from next let filter_s f s = let rec next () = let t = get s in t >>= function | Some x -> begin f x >>= function | true -> t | false -> next () end | None -> t in from next let filter_map f s = let rec next () = get s >>= function | Some x -> let x = f x in (match x with | Some _ -> Lwt.return x | None -> next ()) | None -> Lwt.return_none in from next let filter_map_s f s = let rec next () = get s >>= function | Some x -> let t = f x in (t >>= function | Some _ -> t | None -> next ()) | None -> Lwt.return_none in from next let map_list f s = let pendings = ref [] in let rec next () = match !pendings with | [] -> (get s >>= function | Some x -> let l = f x in pendings := l; next () | None -> Lwt.return_none) | x :: l -> pendings := l; Lwt.return (Some x) in from next let map_list_s f s = let pendings = ref [] in let rec next () = match !pendings with | [] -> (get s >>= function | Some x -> f x >>= fun l -> pendings := l; next () | None -> Lwt.return_none) | x :: l -> pendings := l; Lwt.return (Some x) in from next let flatten s = map_list (fun l -> l) s let rec fold_rec node f s acc = if node == !(s.last) then feed s >>= fun () -> fold_rec node f s acc else match node.data with | Some x -> consume s node; let acc = f x acc in fold_rec node.next f s acc | None -> Lwt.return acc let fold f s acc = fold_rec s.node f s acc let rec fold_s_rec node f s acc = if node == !(s.last) then feed s >>= fun () -> fold_s_rec node f s acc else match node.data with | Some x -> consume s node; f x acc >>= fun acc -> fold_s_rec node.next f s acc | None -> Lwt.return acc let fold_s f s acc = fold_s_rec s.node f s acc let rec iter_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_rec node f s else match node.data with | Some x -> consume s node; let () = f x in iter_rec node.next f s | None -> Lwt.return_unit let iter f s = iter_rec s.node f s let rec iter_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_s_rec node f s else match node.data with | Some x -> consume s node; f x >>= fun () -> iter_s_rec node.next f s | None -> Lwt.return_unit let iter_s f s = iter_s_rec s.node f s let rec iter_p_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_p_rec node f s else match node.data with | Some x -> consume s node; let res = f x in let rest = iter_p_rec node.next f s in res >>= fun () -> rest | None -> Lwt.return_unit let iter_p f s = iter_p_rec s.node f s let iter_n ?(max_concurrency = 1) f stream = begin if max_concurrency <= 0 then let message = Printf.sprintf "Lwt_stream.iter_n: max_concurrency must be > 0, %d given" max_concurrency in invalid_arg message end; let rec loop running available = begin if available > 0 then ( Lwt.return (running, available) ) else ( Lwt.nchoose_split running >>= fun (complete, running) -> Lwt.return (running, available + List.length complete) ) end >>= fun (running, available) -> get stream >>= function | None -> Lwt.join running | Some elt -> loop (f elt :: running) (pred available) in loop [] max_concurrency let rec find_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_rec node f s else match node.data with | Some x as opt -> consume s node; let test = f x in if test then Lwt.return opt else find_rec node.next f s | None -> Lwt.return_none let find f s = find_rec s.node f s let rec find_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_s_rec node f s else match node.data with | Some x as opt -> begin consume s node; f x >>= function | true -> Lwt.return opt | false -> find_s_rec node.next f s end | None -> Lwt.return_none let find_s f s = find_s_rec s.node f s let rec find_map_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_map_rec node f s else match node.data with | Some x -> consume s node; let x = f x in if x = None then find_map_rec node.next f s else Lwt.return x | None -> Lwt.return_none let find_map f s = find_map_rec s.node f s let rec find_map_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_map_s_rec node f s else match node.data with | Some x -> consume s node; let t = f x in (t >>= function | None -> find_map_s_rec node.next f s | Some _ -> t) | None -> Lwt.return_none let find_map_s f s = find_map_s_rec s.node f s let combine s1 s2 = let next () = let t1 = get s1 and t2 = get s2 in t1 >>= fun n1 -> t2 >>= fun n2 -> match n1, n2 with | Some x1, Some x2 -> Lwt.return (Some(x1, x2)) | _ -> Lwt.return_none in from next let append s1 s2 = let current_s = ref s1 in let rec next () = let t = get !current_s in t >>= function | Some _ -> t | None -> if !current_s == s2 then Lwt.return_none else begin current_s := s2; next () end in from next let concat s_top = let current_s = ref (from (fun () -> Lwt.return_none)) in let rec next () = let t = get !current_s in t >>= function | Some _ -> t | None -> get s_top >>= function | Some s -> current_s := s; next () | None -> Lwt.return_none in from next let choose streams = let source s = (s, get s >|= fun x -> (s, x)) in let streams = ref (List.map source streams) in let rec next () = match !streams with | [] -> Lwt.return_none | l -> Lwt.choose (List.map snd l) >>= fun (s, x) -> let l = List.remove_assq s l in match x with | Some _ -> streams := source s :: l; Lwt.return x | None -> streams := l; next () in from next let parse s f = (match s.source with | Push_bounded _ -> invalid_arg "Lwt_stream.parse" | From _ | From_direct _ | Push _ -> ()); let node = s.node in Lwt.catch (fun () -> f s) (fun exn -> s.node <- node; Lwt.reraise exn) let hexdump stream = let buf = Buffer.create 80 and num = ref 0 in from begin fun _ -> nget 16 stream >>= function | [] -> Lwt.return_none | l -> Buffer.clear buf; Printf.bprintf buf "%08x| " !num; num := !num + 16; let rec bytes pos = function | [] -> blanks pos | x :: l -> if pos = 8 then Buffer.add_char buf ' '; Printf.bprintf buf "%02x " (Char.code x); bytes (pos + 1) l and blanks pos = if pos < 16 then begin if pos = 8 then Buffer.add_string buf " " else Buffer.add_string buf " "; blanks (pos + 1) end in bytes 0 l; Buffer.add_string buf " |"; List.iter (fun ch -> Buffer.add_char buf (if ch >= '\x20' && ch <= '\x7e' then ch else '.')) l; Buffer.add_char buf '|'; Lwt.return (Some(Buffer.contents buf)) end lwt-5.9.1/src/core/lwt_stream.mli000066400000000000000000000323541476253734400167650ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Data streams *) type 'a t (** A stream holding values of type ['a]. Naming convention: in this module, all functions applying a function to each element of a stream are suffixed by: - [_s] when the function returns a thread and calls are serialised - [_p] when the function returns a thread and calls are parallelised *) (** {2 Construction} *) val from : (unit -> 'a option Lwt.t) -> 'a t (** [from f] creates a stream from the given input function. [f] is called each time more input is needed, and the stream ends when [f] returns [None]. If [f], or the thread produced by [f], raises an exception, that exception is forwarded to the consumer of the stream (for example, a caller of {!get}). Note that this does not end the stream. A subsequent attempt to read from the stream will cause another call to [f], which may succeed with a value. *) val from_direct : (unit -> 'a option) -> 'a t (** [from_direct f] does the same as {!from} but with a function that does not return a thread. It is preferred that this function be used rather than wrapping [f] into a function which returns a thread. The behavior when [f] raises an exception is the same as for {!from}, except that [f] does not produce a thread. *) exception Closed (** Exception raised by the push function of a push-stream when pushing an element after the end of stream ([= None]) has been pushed. *) val create : unit -> 'a t * ('a option -> unit) (** [create ()] returns a new stream and a push function. To notify the stream's consumer of errors, either use a separate communication channel, or use a {!Stdlib.result} stream. There is no way to push an exception into a push-stream. *) val create_with_reference : unit -> 'a t * ('a option -> unit) * ('b -> unit) (** [create_with_reference ()] returns a new stream and a push function. The last function allows a reference to be set to an external source. This prevents the external source from being garbage collected. For example, to convert a reactive event to a stream: {[ let stream, push, set_ref = Lwt_stream.create_with_reference () in set_ref (map_event push event) ]} *) exception Full (** Exception raised by the push function of a bounded push-stream when the stream queue is full and a thread is already waiting to push an element. *) (** Type of sources for bounded push-streams. *) class type ['a] bounded_push = object method size : int (** Size of the stream. *) method resize : int -> unit (** Change the size of the stream queue. Note that the new size can smaller than the current stream queue size. It raises {!Stdlib.Invalid_argument} if [size < 0]. *) method push : 'a -> unit Lwt.t (** Pushes a new element to the stream. If the stream is full then it will block until one element is consumed. If another thread is already blocked on [push], it raises {!Lwt_stream.Full}. *) method close : unit (** Closes the stream. Any thread currently blocked on a call to the [push] method fails with {!Lwt_stream.Closed}. *) method count : int (** Number of elements in the stream queue. *) method blocked : bool (** Is a thread is blocked on a call to the [push] method? *) method closed : bool (** Is the stream closed? *) method set_reference : 'a. 'a -> unit (** Set the reference to an external source. *) end val create_bounded : int -> 'a t * 'a bounded_push (** [create_bounded size] returns a new stream and a bounded push source. The stream can hold a maximum of [size] elements. When this limit is reached, pushing a new element will block until one is consumed. Note that you cannot clone or parse (with {!parse}) a bounded stream. These functions will raise [Invalid_argument] if you try to do so. It raises [Invalid_argument] if [size < 0]. *) val return : 'a -> 'a t (** [return a] creates a stream containing the value [a] and being immediately closed stream (in the sense of {!is_closed}). @since 5.5.0 *) val return_lwt : 'a Lwt.t -> 'a t (** [return_lwt l] creates a stream returning the value that [l] resolves to. The value is pushed into the stream immediately after the promise becomes resolved and the stream is then immediately closed (in the sense of {!is_closed}). If, instead, [l] becomes rejected, then the stream is closed without any elements in it. Attempting to fetch elements from it will raise {!Empty}. @since 5.5.0 *) val of_seq : 'a Seq.t -> 'a t (** [of_seq s] creates a stream returning all elements of [s]. The elements are evaluated from [s] and pushed onto the stream as the stream is consumed. @since 4.2.0 *) val of_lwt_seq : 'a Lwt_seq.t -> 'a t (** [of_lwt_seq s] creates a stream returning all elements of [s]. The elements are evaluated from [s] and pushed onto the stream as the stream is consumed. @since 5.5.0 *) val of_list : 'a list -> 'a t (** [of_list l] creates a stream returning all elements of [l]. The elements are pushed into the stream immediately, resulting in a closed stream (in the sense of {!is_closed}). *) val of_array : 'a array -> 'a t (** [of_array a] creates a stream returning all elements of [a]. The elements are pushed into the stream immediately, resulting in a closed stream (in the sense of {!is_closed}). *) val of_string : string -> char t (** [of_string str] creates a stream returning all characters of [str]. The characters are pushed into the stream immediately, resulting in a closed stream (in the sense of {!is_closed}). *) val clone : 'a t -> 'a t (** [clone st] clone the given stream. Operations on each stream will not affect the other. For example: {[ # let st1 = Lwt_stream.of_list [1; 2; 3];; val st1 : int Lwt_stream.t = # let st2 = Lwt_stream.clone st1;; val st2 : int Lwt_stream.t = # lwt x = Lwt_stream.next st1;; val x : int = 1 # lwt y = Lwt_stream.next st2;; val y : int = 1 ]} It raises [Invalid_argument] if [st] is a bounded push-stream. *) (** {2 Destruction} *) val to_list : 'a t -> 'a list Lwt.t (** Returns the list of elements of the given stream *) val to_string : char t -> string Lwt.t (** Returns the word composed of all characters of the given stream *) (** {2 Data retrieval} *) exception Empty (** Exception raised when trying to retrieve data from an empty stream. *) val peek : 'a t -> 'a option Lwt.t (** [peek st] returns the first element of the stream, if any, without removing it. *) val npeek : int -> 'a t -> 'a list Lwt.t (** [npeek n st] returns at most the first [n] elements of [st], without removing them. *) val get : 'a t -> 'a option Lwt.t (** [get st] removes and returns the first element of the stream, if any. *) val nget : int -> 'a t -> 'a list Lwt.t (** [nget n st] removes and returns at most the first [n] elements of [st]. *) val get_while : ('a -> bool) -> 'a t -> 'a list Lwt.t val get_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a list Lwt.t (** [get_while f st] returns the longest prefix of [st] where all elements satisfy [f]. *) val next : 'a t -> 'a Lwt.t (** [next st] removes and returns the next element of the stream or fails with {!Empty}, if the stream is empty. *) val last_new : 'a t -> 'a Lwt.t (** [last_new st] returns the last element that can be obtained without sleeping, or wait for one if none is available. It fails with {!Empty} if the stream has no more elements. *) val junk : 'a t -> unit Lwt.t (** [junk st] removes the first element of [st]. *) val njunk : int -> 'a t -> unit Lwt.t (** [njunk n st] removes at most the first [n] elements of the stream. *) val junk_while : ('a -> bool) -> 'a t -> unit Lwt.t val junk_while_s : ('a -> bool Lwt.t) -> 'a t -> unit Lwt.t (** [junk_while f st] removes all elements at the beginning of the streams which satisfy [f]. *) val junk_available : 'a t -> unit (** [junk_available st] removes all elements that are ready to be read without yielding from [st]. *) val get_available : 'a t -> 'a list (** [get_available st] returns all available elements of [l] without blocking. *) val get_available_up_to : int -> 'a t -> 'a list (** [get_available_up_to n st] returns up to [n] elements of [l] without blocking. *) val is_empty : 'a t -> bool Lwt.t (** [is_empty st] returns whether the given stream is empty. *) val is_closed : 'a t -> bool (** [is_closed st] returns whether the given stream has been closed. A closed stream is not necessarily empty. It may still contain unread elements. If [is_closed s = true], then all subsequent reads until the end of the stream are guaranteed not to block. @since 2.6.0 *) val closed : 'a t -> unit Lwt.t (** [closed st] returns a thread that will sleep until the stream has been closed. @since 2.6.0 *) (** {3 Deprecated} *) val junk_old : 'a t -> unit Lwt.t [@@deprecated "Use junk_available instead"] (** @deprecated [junk_old st] is [Lwt.return (junk_available st)]. *) (** {2 Stream transversal} *) (** Note: all the following functions are destructive. For example: {[ # let st1 = Lwt_stream.of_list [1; 2; 3];; val st1 : int Lwt_stream.t = # let st2 = Lwt_stream.map string_of_int st1;; val st2 : string Lwt_stream.t = # lwt x = Lwt_stream.next st1;; val x : int = 1 # lwt y = Lwt_stream.next st2;; val y : string = "2" ]} *) val choose : 'a t list -> 'a t (** [choose l] creates an stream from a list of streams. The resulting stream will return elements returned by any stream of [l] in an unspecified order. *) val map : ('a -> 'b) -> 'a t -> 'b t val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t (** [map f st] maps the value returned by [st] with [f] *) val filter : ('a -> bool) -> 'a t -> 'a t val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t (** [filter f st] keeps only values, [x], such that [f x] is [true] *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t (** [filter_map f st] filter and map [st] at the same time *) val map_list : ('a -> 'b list) -> 'a t -> 'b t val map_list_s : ('a -> 'b list Lwt.t) -> 'a t -> 'b t (** [map_list f st] applies [f] on each element of [st] and flattens the lists returned *) val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b Lwt.t val fold_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t (** [fold f s x] fold_like function for streams. *) val iter : ('a -> unit) -> 'a t -> unit Lwt.t val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** [iter f s] iterates over all elements of the stream. *) val iter_n : ?max_concurrency:int -> ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** [iter_n ?max_concurrency f s] iterates over all elements of the stream [s]. Iteration is performed concurrently with up to [max_threads] concurrent instances of [f]. Iteration is {b not} guaranteed to be in order as this function will attempt to always process [max_concurrency] elements from [s] at once. @param max_concurrency defaults to [1]. @raise Invalid_argument if [max_concurrency < 1]. @since 3.3.0 *) val find : ('a -> bool) -> 'a t -> 'a option Lwt.t val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t (** [find f s] find an element in a stream. *) val find_map : ('a -> 'b option) -> 'a t -> 'b option Lwt.t val find_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b option Lwt.t (** [find_map f s] find and map at the same time. *) val combine : 'a t -> 'b t -> ('a * 'b) t (** [combine s1 s2] combines two streams. The stream will end when either stream ends. *) val append : 'a t -> 'a t -> 'a t (** [append s1 s2] returns a stream which returns all elements of [s1], then all elements of [s2] *) val concat : 'a t t -> 'a t (** [concat st] returns the concatenation of all streams of [st]. *) val flatten : 'a list t -> 'a t (** [flatten st = map_list (fun l -> l) st] *) val wrap_exn : 'a t -> ('a, exn) result t (** [wrap_exn s] is a stream [s'] such that each time [s] yields a value [v], [s'] yields [Result.Ok v], and when the source of [s] raises an exception [e], [s'] yields [Result.Error e]. Note that push-streams (as returned by {!create}) never raise exceptions. If the stream source keeps raising the same exception [e] each time the stream is read, [s'] is unbounded. Reading it will produce [Result.Error e] indefinitely. @since 2.7.0 *) (** {2 Parsing} *) val parse : 'a t -> ('a t -> 'b Lwt.t) -> 'b Lwt.t (** [parse st f] parses [st] with [f]. If [f] raise an exception, [st] is restored to its previous state. It raises [Invalid_argument] if [st] is a bounded push-stream. *) (** {2 Misc} *) val hexdump : char t -> string t (** [hexdump byte_stream] returns a stream which is the same as the output of [hexdump -C]. Basically, here is a simple implementation of [hexdump -C]: {[ let () = Lwt_main.run begin Lwt_io.write_lines Lwt_io.stdout (Lwt_stream.hexdump (Lwt_io.read_lines Lwt_io.stdin)) end ]} *) lwt-5.9.1/src/core/lwt_switch.ml000066400000000000000000000024101476253734400166100ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) exception Off type on_switch = { mutable hooks : (unit -> unit Lwt.t) list; } type state = | St_on of on_switch | St_off type t = { mutable state : state } let create () = { state = St_on { hooks = [] } } let is_on switch = match switch.state with | St_on _ -> true | St_off -> false let check = function | Some{ state = St_off } -> raise Off | Some {state = St_on _} | None -> () let add_hook switch hook = match switch with | Some { state = St_on os } -> os.hooks <- hook :: os.hooks | Some { state = St_off } -> raise Off | None -> () let add_hook_or_exec switch hook = match switch with | Some { state = St_on os } -> os.hooks <- hook :: os.hooks; Lwt.return_unit | Some { state = St_off } -> hook () | None -> Lwt.return_unit let turn_off switch = match switch.state with | St_on { hooks = hooks } -> switch.state <- St_off; Lwt.join (List.map (fun hook -> Lwt.apply hook ()) hooks) | St_off -> Lwt.return_unit let with_switch fn = let switch = create () in Lwt.finalize (fun () -> fn switch) (fun () -> turn_off switch) lwt-5.9.1/src/core/lwt_switch.mli000066400000000000000000000056271476253734400167760ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Lwt switches *) (** Switch has two goals: - being able to free multiple resources at the same time, - offer a better alternative than always returning an id to free some resource. For example, consider the following interface: {[ type id val free : id -> unit Lwt.t val f : unit -> id Lwt.t val g : unit -> id Lwt.t val h : unit -> id Lwt.t ]} Now you want to call [f], [g] and [h] in parallel. You can simply do: {[ lwt idf = f () and idg = g () and idh = h () in ... ]} However, one may want to handle possible failures of [f ()], [g ()] and [h ()], and disable all allocated resources if one of these three threads fails. This may be hard since you have to remember which one failed and which one returned correctly. Now if we change the interface a little bit: {[ val f : ?switch : Lwt_switch.t -> unit -> id Lwt.t val g : ?switch : Lwt_switch.t -> unit -> id Lwt.t val h : ?switch : Lwt_switch.t -> unit -> id Lwt.t ]} the code becomes: {[ Lwt_switch.with_switch (fun switch -> lwt idf = f ~switch () and idg = g ~switch () and idh = h ~switch () in ... ) ]} *) type t (** Type of switches. *) val create : unit -> t (** [create ()] creates a new switch. *) val with_switch : (t -> 'a Lwt.t) -> 'a Lwt.t (** [with_switch fn] is [fn switch], where [switch] is a fresh switch that is turned off when the callback thread finishes (whether it succeeds or fails). @since 2.6.0 *) val is_on : t -> bool (** [is_on switch] returns [true] if the switch is currently on, and [false] otherwise. *) val turn_off : t -> unit Lwt.t (** [turn_off switch] turns off the switch. It calls all registered hooks, waits for all of them to terminate, then returns. If one of the hooks failed, it will fail with the exception raised by the hook. If the switch is already off, it does nothing. *) exception Off (** Exception raised when trying to add a hook to a switch that is already off. *) val check : t option -> unit (** [check switch] does nothing if [switch] is [None] or contains an switch that is currently on, and raises {!Off} otherwise. *) val add_hook : t option -> (unit -> unit Lwt.t) -> unit (** [add_hook switch f] registers [f] so it will be called when {!turn_off} is invoked. It does nothing if [switch] is [None]. If [switch] contains an switch that is already off then {!Off} is raised. *) val add_hook_or_exec : t option -> (unit -> unit Lwt.t) -> unit Lwt.t (** [add_hook_or_exec switch f] is the same as {!add_hook} except that if the switch is already off, [f] is called immediately. *) lwt-5.9.1/src/ppx/000077500000000000000000000000001476253734400137515ustar00rootroot00000000000000lwt-5.9.1/src/ppx/dune000066400000000000000000000006741476253734400146360ustar00rootroot00000000000000(* -*- tuareg -*- *) let bisect_ppx = match Sys.getenv "BISECT_ENABLE" with | "yes" -> "bisect_ppx" | _ -> "" | exception _ -> "" let () = Jbuild_plugin.V1.send @@ {| (library (name ppx_lwt) (public_name lwt_ppx) (synopsis "Lwt PPX syntax extension") (modules ppx_lwt) (libraries ppxlib) (ppx_runtime_libraries lwt) (kind ppx_rewriter) (preprocess (pps ppxlib.metaquot|} ^ bisect_ppx ^ {|)) (flags (:standard -w +A-4))) |} lwt-5.9.1/src/ppx/ppx_lwt.ml000066400000000000000000000252431476253734400160060ustar00rootroot00000000000000open! Ppxlib open Ast_builder.Default (** {2 Convenient stuff} *) let with_loc f {txt ; loc } = f ~loc txt (** Test if a case is a catchall. *) let is_catchall case = let rec is_catchall_pat p = match p.ppat_desc with | Ppat_any | Ppat_var _ -> true | Ppat_alias (p, _) | Ppat_constraint (p,_) -> is_catchall_pat p | _ -> false in case.pc_guard = None && is_catchall_pat case.pc_lhs (** Add a wildcard case in there is none. Useful for exception handlers. *) let add_wildcard_case cases = let has_wildcard = List.exists is_catchall cases in if not has_wildcard then cases @ (let loc = Location.none in [case ~lhs:[%pat? exn] ~guard:None ~rhs:[%expr Lwt.reraise exn]]) else cases (** {3 Internal names} *) let lwt_prefix = "__ppx_lwt_" (** {2 Here we go!} *) let default_loc = ref Location.none let sequence = ref true let strict_seq = ref true let used_no_sequence_option = ref false let used_no_strict_sequence_option = ref false let no_sequence_option () = sequence := false; used_no_sequence_option := true let no_strict_sequence_option () = strict_seq := false; used_no_strict_sequence_option := true (** let%lwt related functions *) let gen_name i = lwt_prefix ^ string_of_int i (** [p = x] ≡ [__ppx_lwt_$i = x] *) let gen_bindings l = let aux i binding = { binding with pvb_pat = pvar ~loc:binding.pvb_expr.pexp_loc (gen_name i) } in List.mapi aux l (** [p = x] and e ≡ [Lwt.bind __ppx_lwt_$i (fun p -> e)] *) let gen_binds e_loc l e = let rec aux i bindings = match bindings with | [] -> e | binding :: t -> let name = (* __ppx_lwt_$i, at the position of $x$ *) evar ~loc:binding.pvb_expr.pexp_loc (gen_name i) in let fun_ = let loc = e_loc in [%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])] in let new_exp = let loc = e_loc in [%expr Lwt.backtrace_bind (fun exn -> try Lwt.reraise exn with exn -> exn) [%e name] [%e fun_] ] in { new_exp with pexp_attributes = binding.pvb_attributes } in aux 0 l let lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc = let pat= let loc = ext_loc in [%pat? ()] in let lhs, rhs = mapper#expression lhs, mapper#expression rhs in let loc = exp.pexp_loc in [%expr Lwt.backtrace_bind (fun exn -> try Lwt.reraise exn with exn -> exn) [%e lhs] (fun [%p pat] -> [%e rhs]) ] (** For expressions only *) (* We only expand the first level after a %lwt. After that, we call the mapper to expand sub-expressions. *) let lwt_expression mapper exp attributes ext_loc = default_loc := exp.pexp_loc; let pexp_attributes = attributes @ exp.pexp_attributes in match exp.pexp_desc with (* $e$;%lwt $e'$ ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *) | Pexp_sequence (lhs, rhs) -> Some (lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc) (* [let%lwt $p$ = $e$ in $e'$] ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *) | Pexp_let (Nonrecursive, vbl , e) -> let new_exp = pexp_let ~loc:!default_loc Nonrecursive (gen_bindings vbl) (gen_binds exp.pexp_loc vbl e) in Some (mapper#expression { new_exp with pexp_attributes }) (* [match%lwt $e$ with $c$] ≡ [Lwt.bind $e$ (function $c$)] [match%lwt $e$ with exception $x$ | $c$] ≡ [Lwt.try_bind (fun () -> $e$) (function $c$) (function $x$)] *) | Pexp_match (e, cases) -> let exns, cases = cases |> List.partition ( function | {pc_lhs = [%pat? exception [%p? _]]; _} -> true | _ -> false) in if cases = [] then Location.raise_errorf ~loc:exp.pexp_loc "match%%lwt must contain at least one non-exception pattern." ; let exns = exns |> List.map ( function | {pc_lhs = [%pat? exception [%p? pat]]; _} as case -> { case with pc_lhs = pat } | _ -> assert false) in let exns = add_wildcard_case exns in let new_exp = match exns with | [] -> let loc = !default_loc in [%expr Lwt.bind [%e e] [%e pexp_function ~loc cases]] | _ -> let loc = !default_loc in [%expr Lwt.try_bind (fun () -> [%e e]) [%e pexp_function ~loc cases] [%e pexp_function ~loc exns]] in Some (mapper#expression { new_exp with pexp_attributes }) (* [assert%lwt $e$] ≡ [try Lwt.return (assert $e$) with exn -> Lwt.reraise exn] *) | Pexp_assert e -> let new_exp = let loc = !default_loc in [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.reraise exn] in Some (mapper#expression { new_exp with pexp_attributes }) (* [while%lwt $cond$ do $body$ done] ≡ [let rec __ppx_lwt_loop () = if $cond$ then Lwt.bind $body$ __ppx_lwt_loop else Lwt.return_unit in __ppx_lwt_loop] *) | Pexp_while (cond, body) -> let new_exp = let loc = !default_loc in [%expr let rec __ppx_lwt_loop () = if [%e cond] then Lwt.bind [%e body] __ppx_lwt_loop else Lwt.return_unit in __ppx_lwt_loop () ] in Some (mapper#expression { new_exp with pexp_attributes }) (* [for%lwt $p$ = $start$ (to|downto) $end$ do $body$ done] ≡ [let __ppx_lwt_bound = $end$ in let rec __ppx_lwt_loop $p$ = if $p$ COMP __ppx_lwt_bound then Lwt.return_unit else Lwt.bind $body$ (fun () -> __ppx_lwt_loop ($p$ OP 1)) in __ppx_lwt_loop $start$] *) | Pexp_for ({ppat_desc = Ppat_var p_var; _} as p, start, bound, dir, body) -> let comp, op = let loc = !default_loc in match dir with | Upto -> evar ~loc ">", evar ~loc "+" | Downto -> evar ~loc "<", evar ~loc "-" in let p' = with_loc evar p_var in let exp_bound = let loc = bound.pexp_loc in [%expr __ppx_lwt_bound] in let pat_bound = let loc = bound.pexp_loc in [%pat? __ppx_lwt_bound] in let new_exp = let loc = !default_loc in [%expr let [%p pat_bound] : int = [%e bound] in let rec __ppx_lwt_loop [%p p] = if [%e comp] [%e p'] [%e exp_bound] then Lwt.return_unit else Lwt.bind [%e body] (fun () -> __ppx_lwt_loop ([%e op] [%e p'] 1)) in __ppx_lwt_loop [%e start] ] in Some (mapper#expression { new_exp with pexp_attributes }) (* [try%lwt $e$ with $c$] ≡ [Lwt.catch (fun () -> $e$) (function $c$)] *) | Pexp_try (expr, cases) -> let cases = add_wildcard_case cases in let new_exp = let loc = !default_loc in [%expr Lwt.backtrace_catch (fun exn -> try Lwt.reraise exn with exn -> exn) (fun () -> [%e expr]) [%e pexp_function ~loc cases] ] in Some (mapper#expression { new_exp with pexp_attributes }) (* [if%lwt $c$ then $e1$ else $e2$] ≡ [match%lwt $c$ with true -> $e1$ | false -> $e2$] [if%lwt $c$ then $e1$] ≡ [match%lwt $c$ with true -> $e1$ | false -> Lwt.return_unit] *) | Pexp_ifthenelse (cond, e1, e2) -> let e2 = match e2 with | None -> let loc = !default_loc in [%expr Lwt.return_unit] | Some e -> e in let cases = let loc = !default_loc in [ case ~lhs:[%pat? true] ~guard:None ~rhs:e1 ; case ~lhs:[%pat? false] ~guard:None ~rhs:e2 ; ] in let new_exp = let loc = !default_loc in [%expr Lwt.bind [%e cond] [%e pexp_function ~loc cases]] in Some (mapper#expression { new_exp with pexp_attributes }) | _ -> None let warned = ref false class mapper = object (self) inherit Ast_traverse.map as super method! structure = begin fun structure -> if !warned then super#structure structure else begin warned := true; let structure = super#structure structure in let loc = Location.in_file !Ocaml_common.Location.input_name in let warn_if condition message structure = if condition then (pstr_attribute ~loc (attribute_of_warning loc message))::structure else structure in structure |> warn_if (!used_no_strict_sequence_option) ("-no-strict-sequence is a deprecated Lwt PPX option\n" ^ " See https://github.com/ocsigen/lwt/issues/495") |> warn_if (!used_no_sequence_option) ("-no-sequence is a deprecated Lwt PPX option\n" ^ " See https://github.com/ocsigen/lwt/issues/495") end end method! expression = (fun expr -> match expr with | { pexp_desc= Pexp_extension ( {txt="lwt"; loc= ext_loc}, PStr[{pstr_desc= Pstr_eval (exp, _);_}]); _ }-> begin match lwt_expression self exp expr.pexp_attributes ext_loc with | Some expr' -> expr' | None -> expr end (* [($e$)[%finally $f$]] ≡ [Lwt.finalize (fun () -> $e$) (fun () -> $f$)] *) | [%expr [%e? exp ] [%finally [%e? finally]] ] | [%expr [%e? exp ] [%lwt.finally [%e? finally]] ] -> let new_exp = let loc = !default_loc in [%expr Lwt.backtrace_finalize (fun exn -> try Lwt.reraise exn with exn -> exn) (fun () -> [%e exp]) (fun () -> [%e finally]) ] in super#expression { new_exp with pexp_attributes = expr.pexp_attributes @ exp.pexp_attributes } | [%expr [%finally [%e? _ ]]] | [%expr [%lwt.finally [%e? _ ]]] -> Location.raise_errorf ~loc:expr.pexp_loc "Lwt's finally should be used only with the syntax: \"()[%%finally ...]\"." | _ -> super#expression expr) method! structure_item = (fun stri -> default_loc := stri.pstr_loc; match stri with | [%stri let%lwt [%p? var] = [%e? exp]] -> let warning = estring ~loc:!default_loc ("let%lwt should not be used at the module item level.\n" ^ "Replace let%lwt x = e by let x = Lwt_main.run (e)") in let loc = !default_loc in [%stri let [%p var] = (Lwt_main.run [@ocaml.ppwarning [%e warning]]) [%e super#expression exp]] | x -> super#structure_item x); end let args = [ "-no-sequence", Arg.Unit no_sequence_option, " has no effect (deprecated)"; "-no-strict-sequence", Arg.Unit no_strict_sequence_option, " has no effect (deprecated)"; ] let () = let mapper = new mapper in Driver.register_transformation "ppx_lwt" ~impl:mapper#structure ~intf:mapper#signature ; List.iter (fun (key, spec, doc) -> Driver.add_arg key spec ~doc) args lwt-5.9.1/src/ppx/ppx_lwt.mli000066400000000000000000000047131476253734400161560ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Ppx syntax extension for Lwt *) (** {2 Ppx extensions} This Ppx extension adds various syntactic shortcut for lwt programming. It needs {{:https://github.com/ocaml-ppx/ppx_tools}ppx_tools}. To use it, simply use the ocamlfind package [lwt_ppx]. This extension adds the following syntax: - lwt-binding: {[ let%lwt ch = get_char stdin in code ]} is the same as [bind (get_char stdin) (fun ch -> code)]. Moreover, it supports parallel binding: {[ let%lwt x = do_something1 () and y = do_something2 in code ]} will run [do_something1 ()] and [do_something2 ()], then bind their results to [x] and [y]. It is the same as: {[ let t1 = do_something1 and t2 = do_something2 in bind t1 (fun x -> bind t2 (fun y -> code)) ]} Due to a {{:https://github.com/ocaml/ocaml/issues/7758} bug} in the OCaml parser, if you'd like to put a type constraint on the variable, please write {[ let (foo : int) = do_something in code ]} Not using parentheses will confuse the OCaml parser. - exception catching: {[ try%lwt with ]} For example: {[ try%lwt f x with | Failure msg -> prerr_endline msg; return () ]} is expanded to: {[ catch (fun () -> f x) (function | Failure msg -> prerr_endline msg; return () | exn -> Lwt.reraise exn) ]} Note that the [exn -> Lwt.reraise exn] branch is automatically added when needed. - finalizer: {[ () [%finally ] ]} You can use [[%lwt.finally ...]] instead of [[%finally ...]]. - assertion: {[ assert%lwt ]} - for loop: {[ for%lwt i = to do done ]} and: {[ for%lwt i = downto do done ]} - while loop: {[ while%lwt do done ]} - pattern matching: {[ match%lwt with | -> ... | -> ]} Exception cases are also supported: {[ match%lwt with | exception -> | -> ... | -> ]} - conditional: {[ if%lwt then else ]} and {[ if%lwt then ]} *) class mapper : Ppxlib.Ast_traverse.map lwt-5.9.1/src/react/000077500000000000000000000000001476253734400142405ustar00rootroot00000000000000lwt-5.9.1/src/react/dune000066400000000000000000000005741476253734400151240ustar00rootroot00000000000000(* -*- tuareg -*- *) let preprocess = match Sys.getenv "BISECT_ENABLE" with | "yes" -> "(preprocess (pps bisect_ppx))" | _ -> "" | exception _ -> "" let () = Jbuild_plugin.V1.send @@ {| (library (public_name lwt_react) (synopsis "Reactive programming helpers for Lwt") (wrapped false) (libraries lwt react) |} ^ preprocess ^ {| (flags (:standard -w +A))) |} lwt-5.9.1/src/react/lwt_react.ml000066400000000000000000000345451476253734400165710ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix type 'a event = 'a React.event type 'a signal = 'a React.signal module E = struct include React.E (* +---------------------------------------------------------------+ | Lwt-specific utilities | +---------------------------------------------------------------+ *) let finalise f _ = f () let with_finaliser f event = let r = ref () in Gc.finalise (finalise f) r; map (fun x -> ignore (Sys.opaque_identity r); x) event let next ev = let waiter, wakener = Lwt.task () in let ev = map (fun x -> Lwt.wakeup wakener x) (once ev) in Lwt.on_cancel waiter (fun () -> stop ev); waiter let limit f e = (* Thread which prevents [e] from occurring while it is sleeping *) let limiter = ref Lwt.return_unit in (* The occurrence that is delayed until the limiter returns. *) let delayed = ref None in (* The resulting event. *) let event, push = create () in let iter = fmap (fun x -> if Lwt.is_sleeping !limiter then begin (* The limiter is sleeping, we queue the event for later delivering. *) match !delayed with | Some cell -> (* An occurrence is already queued, replace it. *) cell := x; None | None -> let cell = ref x in delayed := Some cell; Lwt.on_success !limiter (fun () -> if Lwt.is_sleeping !limiter then delayed := None else let x = !cell in delayed := None; limiter := f (); push x); None end else begin (* Set the limiter for future events. *) limiter := f (); (* Send the occurrence now. *) push x; None end) e in select [iter; event] let cancel_thread t () = Lwt.cancel t let from f = let event, push = create () in let rec loop () = f () >>= fun x -> push x; loop () in let t = Lwt.pause () >>= loop in with_finaliser (cancel_thread t) event let to_stream event = let stream, push, set_ref = Lwt_stream.create_with_reference () in set_ref (map (fun x -> push (Some x)) event); stream let of_stream stream = let event, push = create () in let t = Lwt.pause () >>= fun () -> Lwt_stream.iter (fun v -> try push v with exn when Lwt.Exception_filter.run exn -> !Lwt.async_exception_hook exn) stream in with_finaliser (cancel_thread t) event let delay thread = match Lwt.poll thread with | Some e -> e | None -> let event, send = create () in Lwt.on_success thread (fun e -> send e; stop event); switch never event let keeped = ref [] let keep e = keeped := map ignore e :: !keeped (* +---------------------------------------------------------------+ | Event transformations | +---------------------------------------------------------------+ *) let run_p e = let event, push = create () in let iter = fmap (fun t -> Lwt.on_success t (fun v -> push v); None) e in select [iter; event] let run_s e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun t -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> t)) (fun v -> push v); None) e in select [iter; event] let map_p f e = let event, push = create () in let iter = fmap (fun x -> Lwt.on_success (f x) (fun v -> push v); None) e in select [iter; event] let map_s f e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v); None) e in select [iter; event] let app_p ef e = let event, push = create () in let iter = fmap (fun (f, x) -> Lwt.on_success (f x) (fun v -> push v); None) (app (map (fun f x -> (f, x)) ef) e) in select [iter; event] let app_s ef e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun (f, x) -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v); None) (app (map (fun f x -> (f, x)) ef) e) in select [iter; event] let filter_p f e = let event, push = create () in let iter = fmap (fun x -> Lwt.on_success (f x) (function true -> push x | false -> ()); None) e in select [iter; event] let filter_s f e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) e in select [iter; event] let fmap_p f e = let event, push = create () in let iter = fmap (fun x -> Lwt.on_success (f x) (function Some x -> push x | None -> ()); None) e in select [iter; event] let fmap_s f e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) e in select [iter; event] let diff_s f e = let previous = ref None in let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> match !previous with | None -> previous := Some x; None | Some y -> previous := Some x; Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) (fun v -> push v); None) e in select [iter; event] let accum_s ef acc = let acc = ref acc in let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun f -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc)) (fun x -> acc := x; push x); None) ef in select [iter; event] let fold_s f acc e = let acc = ref acc in let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc x)) (fun x -> acc := x; push x); None) e in select [iter; event] let rec rev_fold f acc = function | [] -> Lwt.return acc | x :: l -> rev_fold f acc l >>= fun acc -> f acc x let merge_s f acc el = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun l -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) (fun v -> push v); None) (merge (fun acc x -> x :: acc) [] el) in select [iter; event] end module S = struct include React.S (* +---------------------------------------------------------------+ | Lwt-specific utilities | +---------------------------------------------------------------+ *) let finalise f _ = f () let with_finaliser f signal = let r = ref () in Gc.finalise (finalise f) r; map (fun x -> ignore (Sys.opaque_identity r); x) signal let limit ?eq f s = (* Thread which prevent [s] to changes while it is sleeping *) let limiter = ref (f ()) in (* The occurrence that is delayed until the limiter returns. *) let delayed = ref None in (* The resulting event. *) let event, push = E.create () in let iter = E.fmap (fun x -> if Lwt.is_sleeping !limiter then begin (* The limiter is sleeping, we queue the event for later delivering. *) match !delayed with | Some cell -> (* An occurrence is already queued, replace it. *) cell := x; None | None -> let cell = ref x in delayed := Some cell; Lwt.on_success !limiter (fun () -> if Lwt.is_sleeping !limiter then delayed := None else let x = !cell in delayed := None; limiter := f (); push x); None end else begin (* Set the limiter for future events. *) limiter := f (); (* Send the occurrence now. *) push x; None end) (changes s) in hold ?eq (value s) (E.select [iter; event]) let keeped = ref [] let keep s = keeped := map ignore s :: !keeped (* +---------------------------------------------------------------+ | Signal transformations | +---------------------------------------------------------------+ *) let run_s ?eq s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun t -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> t)) (fun v -> push v); None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> value s) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let map_s ?eq f s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v); None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let app_s ?eq sf s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun (f, x) -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v); None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let filter_s ?eq f i s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in let x = value s in Lwt_mutex.with_lock mutex (fun () -> f x) >>= function | true -> Lwt.return (hold ?eq x (E.select [iter; event])) | false -> Lwt.return (hold ?eq i (E.select [iter; event])) let fmap_s ?eq f i s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= function | Some x -> Lwt.return (hold ?eq x (E.select [iter; event])) | None -> Lwt.return (hold ?eq i (E.select [iter; event])) let diff_s f s = let previous = ref (value s) in let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> let y = !previous in previous := x; Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) (fun v -> push v); None) (changes s) in E.select [iter; event] let sample_s f e s = E.map_s (fun x -> f x (value s)) e let accum_s ?eq ef i = hold ?eq i (E.accum_s ef i) let fold_s ?eq f i e = hold ?eq i (E.fold_s f i e) let rec rev_fold f acc = function | [] -> Lwt.return acc | x :: l -> rev_fold f acc l >>= fun acc -> f acc x let merge_s ?eq f acc sl = let s = merge (fun acc x -> x :: acc) [] sl in let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun l -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) (fun v -> push v); None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let l1_s ?eq f s1 = map_s ?eq f s1 let l2_s ?eq f s1 s2 = (* Some details about the use of [fun _ _ -> false] on https://github.com/ocsigen/lwt/pull/893#pullrequestreview-783083496 *) map_s ?eq (fun (x1, x2) -> f x1 x2) (l2 ~eq:(fun _ _ -> false) (fun x1 x2 -> (x1, x2)) s1 s2) let l3_s ?eq f s1 s2 s3 = map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) (l3 ~eq:(fun _ _ -> false) (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3) let l4_s ?eq f s1 s2 s3 s4 = map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) (l4 ~eq:(fun _ _ -> false) (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4) let l5_s ?eq f s1 s2 s3 s4 s5 = map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) (l5 ~eq:(fun _ _ -> false) (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5) let l6_s ?eq f s1 s2 s3 s4 s5 s6 = map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) (l6 ~eq:(fun _ _ -> false) (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6) (* +---------------------------------------------------------------+ | Monadic interface | +---------------------------------------------------------------+ *) let return = const let bind_s ?eq s f = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v); None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> Lwt.return (switch ?eq (hold ~eq:( == ) x (E.select [iter; event]))) end lwt-5.9.1/src/react/lwt_react.mli000066400000000000000000000165271476253734400167420ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** React utilities *) (** This module is an overlay for the [React] module. You can open it instead of the [React] module in order to get all of [React]'s functions plus Lwt ones. This module is provided by OPAM package [lwt_react]. Link with ocamlfind package [lwt_react]. *) type 'a event = 'a React.event (** Type of events. *) type 'a signal = 'a React.signal (** Type of signals. *) module E : sig include module type of React.E (** {2 Lwt-specific utilities} *) val with_finaliser : (unit -> unit) -> 'a event -> 'a event (** [with_finaliser f e] returns an event [e'] which behave as [e], except that [f] is called when [e'] is garbage collected. *) val next : 'a event -> 'a Lwt.t (** [next e] returns the next occurrence of [e]. Avoid trying to create an “asynchronous loop” by calling [next e] again in a callback attached to the promise returned by [next e]: - The callback is called within the React update step, so calling [next e] within it will return a promise that is fulfilled with the same value as the current occurrence. - If you instead arrange for the React update step to end (for example, by calling [Lwt.pause ()] within the callback), multiple React update steps may occur before the callback calls [next e] again, so some occurrences can be effectively “lost.” To robustly asynchronously process occurrences of [e] in a loop, use [to_stream e], and repeatedly call {!Lwt_stream.next} on the resulting stream. *) val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event (** [limit f e] limits the rate of [e] with [f]. For example, to limit the rate of an event to 1 per second you can use: [limit (fun () -> Lwt_unix.sleep 1.0) event]. *) val from : (unit -> 'a Lwt.t) -> 'a event (** [from f] creates an event which occurs each time [f ()] returns a value. If [f] raises an exception, the event is just stopped. *) val to_stream : 'a event -> 'a Lwt_stream.t (** Creates a stream holding all values occurring on the given event *) val of_stream : 'a Lwt_stream.t -> 'a event (** [of_stream stream] creates an event which occurs each time a value is available on the stream. If updating the event causes an exception at any point during the update step, the exception is passed to [!]{!Lwt.async_exception_hook}, which terminates the process by default. *) val delay : 'a event Lwt.t -> 'a event (** [delay promise] is an event which does not occur until [promise] resolves. Then it behaves as the event returned by [promise]. *) val keep : 'a event -> unit (** [keep e] keeps a reference to [e] so it will never be garbage collected. *) (** {2 Threaded versions of React transformation functions} *) (** The following functions behave as their [React] counterpart, except that they take functions that may yield. As usual the [_s] suffix is used when calls are serialized, and the [_p] suffix is used when they are not. Note that [*_p] functions may not preserve event order. *) val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event val run_s : 'a Lwt.t event -> 'a event val run_p : 'a Lwt.t event -> 'a event end module S : sig include module type of React.S (** {2 Monadic interface} *) val return : 'a -> 'a signal (** Same as [const]. *) val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal (** [bind ?eq s f] is initially [f x] where [x] is the current value of [s]. Each time [s] changes to a new value [y], [bind signal f] is set to [f y], until the next change of [signal]. *) val bind_s : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal Lwt.t) -> 'b signal Lwt.t (** Same as {!bind} except that [f] returns a promise. Calls to [f] are serialized. *) (** {2 Lwt-specific utilities} *) val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal (** [with_finaliser f s] returns a signal [s'] which behaves as [s], except that [f] is called when [s'] is garbage collected. *) val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal (** [limit f s] limits the rate of [s] update with [f]. For example, to limit it to 1 per second, you can use: [limit (fun () -> Lwt_unix.sleep 1.0) s]. *) val keep : 'a signal -> unit (** [keep s] keeps a reference to [s] so it will never be garbage collected. *) (** {2 Threaded versions of React transformation functions} *) (** The following functions behave as their [React] counterpart, except that they take functions that may yield. The [_s] suffix means that calls are serialized. *) val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'a signal -> 'b signal Lwt.t val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal Lwt.t val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal Lwt.t val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal Lwt.t val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'a signal -> 'b signal -> 'c signal Lwt.t val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal Lwt.t val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal Lwt.t val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal Lwt.t val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal Lwt.t val run_s : ?eq : ('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t end lwt-5.9.1/src/retry/000077500000000000000000000000001476253734400143075ustar00rootroot00000000000000lwt-5.9.1/src/retry/dune000066400000000000000000000006021476253734400151630ustar00rootroot00000000000000(* -*- tuareg -*- *) let preprocess = match Sys.getenv "BISECT_ENABLE" with | "yes" -> "(preprocess (pps bisect_ppx))" | _ -> "" | exception _ -> "" let () = Jbuild_plugin.V1.send @@ {| (library (public_name lwt_retry) (synopsis "A utility for retrying Lwt computations") (wrapped false) (libraries lwt lwt.unix) |} ^ preprocess ^ {| (flags (:standard -w +A))) |} lwt-5.9.1/src/retry/lwt_retry.ml000066400000000000000000000037551476253734400167060ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Syntax let default_sleep_duration n' = let base_sleep_time = 2.0 in let n = Int.to_float n' in n *. base_sleep_time *. Float.pow 2.0 n type ('retry, 'fatal) error = [ `Retry of 'retry | `Fatal of 'fatal ] let pp_opaque fmt _ = Format.fprintf fmt "" let pp_error ?(retry = pp_opaque) ?(fatal = pp_opaque) fmt err = match err with | `Retry r -> Format.fprintf fmt "`Retry %a" retry r | `Fatal f -> Format.fprintf fmt "`Fatal %a" fatal f let equal_error ~retry ~fatal a b = match a, b with | `Retry a', `Retry b' -> retry a' b' | `Fatal a', `Fatal b' -> fatal a' b' | _ -> false type ('ok, 'retry, 'fatal) attempt = ('ok, ('retry, 'fatal) error * int) result let on_error (f : unit -> ('ok, ('retry, 'fatal) error) result Lwt.t) : ('ok, 'retry, 'fatal) attempt Lwt_stream.t = let i = ref 0 in let stop = ref false in Lwt_stream.from begin fun () -> incr i; if !stop then Lwt.return None else let+ result = f () in match result with | Error (`Retry _ as retry) -> Some (Error (retry, !i)) | Error (`Fatal _ as fatal) -> stop := true; Some (Error (fatal, !i)) | Ok _ as ok -> stop := true; Some ok end let with_sleep ?(duration=default_sleep_duration) (attempts : _ attempt Lwt_stream.t) : _ attempt Lwt_stream.t = attempts |> Lwt_stream.map_s begin function | Ok _ as ok -> Lwt.return ok | Error (_, n) as err -> let* () = Lwt_unix.sleep @@ duration n in Lwt.return err end let n_times n attempts = if n < 0 then invalid_arg "Lwt_retry.n_times: n must be non-negative"; (* The first attempt is a try, and re-tries start counting from n + 1 *) let retries = n + 1 in let+ attempts = Lwt_stream.nget retries attempts in match List.rev attempts with | last :: _ -> last | _ -> failwith "Lwt_retry.n_times: impossible" lwt-5.9.1/src/retry/lwt_retry.mli000066400000000000000000000140031476253734400170430ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Utilities for retrying Lwt computations These utilities are useful for dealing with failure-prone computations that are expected to succeed after some number of repeated attempts. E.g., {[ let flaky_computation () = match try_to_get_resource () with | Flaky_error msg -> Error (`Retry msg) | Fatal_error err -> Error (`Fatal err) | Success result -> Ok result let error_tolerant_computation () = Lwt_retry.(flaky_computation |> on_error (* Retry when [`Retry]able results are produced. *) |> with_sleep (* Add a delay between attempts, with an exponential backoff. *) |> n_times 10 (* Try up to 10 times, so long as errors are retryable. *) ) ]} This library provides a few combinators, but retry attempts are produced on demand in an {!type:Lwt_stream.t}, and they can be consumed and traversed using the {!module:Lwt_stream} functions directly. *) type ('retry, 'fatal) error = [ `Retry of 'retry | `Fatal of 'fatal ] (** The type of errors that a retryable computation can produce. - [`Retry r] when [r] represents an error that can be retried. - [`Fatal f] when [f] represents an error that cannot be retried. *) type ('ok, 'retry, 'fatal) attempt = ('ok, ('retry, 'fatal) error * int) result (** A [('ok, 'retry, 'fatal) attempt] is the [result] of a retryable computation, with its the erroneous results enumerated. - [Ok v] is a successfully computed value [v] - [Error (err, n)] is the {!type:error} [err] produced on the [n]th attempt The enumeration of attempts is 1-based, because making 0 attempts means making no attempts all, making 1 attempt means {i trying} once, and (when [i>0]) making [n] attempts means trying once and then {i retrying} up to [n-1] times. *) val pp_error : ?retry:(Format.formatter -> 'retry -> unit) -> ?fatal:(Format.formatter -> 'fatal -> unit) -> Format.formatter -> ('retry, 'fatal) error -> unit (** [pp_error ~retry ~fatal] is a pretty printer for {!type:error}s that formats fatal and retryable errors according to the provided printers. If a printers is not provided, values of the type are represented as [""]. *) val equal_error : retry:('retry -> 'retry -> bool) -> fatal:('fatal -> 'fatal -> bool) -> ('retry, 'fatal) error -> ('retry, 'fatal) error -> bool val on_error : (unit -> ('ok, ('retry, 'fatal) error) result Lwt.t) -> ('ok, 'retry, 'fatal) attempt Lwt_stream.t (** [Lwt_retry.on_error f] is a stream of attempts to compute [f], with attempts made on demand. Attempts will be added to the stream when results are requested until the computation either succeeds or produces a fatal error. Examples {[ # let success () = Lwt.return_ok ();; val success : unit -> (unit, 'a) result Lwt.t = # Lwt_retry.(success |> on_error) |> Lwt_stream.to_list;; - : (unit, 'a, 'b) Lwt_retry.attempt list = [Ok ()] # let fatal_failure () = Lwt.return_error (`Fatal ());; val fatal_failure : unit -> ('a, [> `Fatal of unit ]) result Lwt.t = # Lwt_retry.(fatal_failure |> on_error) |> Lwt_stream.to_list;; - : ('a, 'b, unit) Lwt_retry.attempt list = [Error (`Fatal (), 1)] # let retryable_error () = Lwt.return_error (`Retry ());; val retryable_error : unit -> ('a, [> `Retry of unit ]) result Lwt.t = # Lwt_retry.(retryable_error |> on_error) |> Lwt_stream.nget 3;; - : ('a, unit, 'b) Lwt_retry.attempt list = [Error (`Retry (), 1); Error (`Retry (), 2); Error (`Retry (), 3)] ]}*) val with_sleep : ?duration:(int -> float) -> ('ok, 'retry, 'fatal) attempt Lwt_stream.t -> ('ok, 'retry, 'fatal) attempt Lwt_stream.t (** [with_sleep ~duration attempts] is the stream of [attempts] with a sleep of [duration n] seconds added before computing each [n]th retryable attempt. @param duration the optional sleep duration calculation, defaulting to {!val:default_sleep_duration}. Examples {[ # let f () = Lwt.return_error (`Retry ());; # let attempts_with_sleeps = Lwt_retry.(f |> on_error |> with_sleep);; # Lwt_stream.get attempts_with_sleeps;; (* computed immediately *) Some (Error (`Retry (), 1)) # Lwt_stream.get attempts_with_sleeps;; (* computed after 3 seconds *) Some (Error (`Retry (), 2)) # Lwt_stream.get attempts_with_sleeps;; (* computed after 9 seconds *) Some (Error (`Retry (), 3)) (* a stream with a constant 1s sleep between attempts *) # let attempts_with_constant_sleeps = Lwt_retry.(f |> on_error |> with_sleep ~duration:(fun _ -> 1.0));; ]} *) val default_sleep_duration : int -> float (** [default_sleep_duration n] is an exponential backoff computed as [n] * 2 * (2 ^ [n]), which gives the sequence [ [0.; 4.; 16.; 48.; 128.; 320.; 768.; 1792.; ...] ]. *) val n_times : int -> ('ok, 'retry, 'fatal) attempt Lwt_stream.t -> ('ok, 'retry, 'fatal) attempt Lwt.t (** [n_times n attempts] is [Ok v] if one of the [attempts] succeeds within [n] retries (or [n+1] attempts), [Error (`Fatal f, n+1)] if any of the attempts results in the fatal error, or [Error (`Retry r, n+1)] if all [n] retries are exhausted and the [n+1]th attempt results in a retry error. In particular [n_times 0 attempts] will *try* 1 attempt but *re-try* 0, so it is guaranteed to produce some result. [n_times] forces up to [n] elements of the on-demand stream of attempts. Examples {[ # let f () = let i = ref 0 in fun () -> Lwt.return_error (if !i < 3 then (incr i; `Retry ()) else `Fatal "error!");; # Lwt_retry.(f () |> on_error |> n_times 0);; Error (`Retry (), 1) # Lwt_retry.(f () |> on_error |> n_times 4);; Error (`Fatal "error!", 3) ]} *) lwt-5.9.1/src/unix/000077500000000000000000000000001476253734400141255ustar00rootroot00000000000000lwt-5.9.1/src/unix/config/000077500000000000000000000000001476253734400153725ustar00rootroot00000000000000lwt-5.9.1/src/unix/config/discover.ml000066400000000000000000000561501476253734400175510ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Lwt_unix feature discovery script. This program tests system features, and outputs four files: - [src/unix/lwt_features.h]: feature test results for consumption by C code. - [src/unix/lwt_features.ml]: test results for consumption by OCaml code. - [src/unix/unix_c_flags.sexp]: C compiler flags for Lwt_unix C sources. - [src/unix/unix_c_library_flags.sexp]: C linker flags for Lwt_unix. [src/unix/lwt_features.h] contains only basic [#define] macros. It is included in [src/unix/lwt_config.h], which computes a few more useful macros. [src/unix/lwt_config.h] is the file that is then directly included by all the C sources. [src/unix/lwt_features.ml] is included by [src/unix/lwt_config.ml] in the same way. You can examine the generated [lwt_features.h] by running [dune build] and looking in [_build/default/src/unix/lwt_features.h], and similarly for [lwt_features.ml]. This program tries to detect everything automatically. If it is not behaving correctly, its behavior can be tweaked by passing it arguments. There are four ways to do so: - By editing [src/unix/dune], to pass arguments to [discover.exe] on the command line. - By setting the environment variable [LWT_DISCOVER_ARGUMENTS]. The syntax is the same as the command line. - By writing a file [src/unix/discover_arguments]. The syntax is again the same as the command line. - By running [dune exec src/unix/config/discover.exe -- --save] with additional arguments. Those arguments will be written to [src/unix/discover_arguments] for the build to use later. The possible arguments can be found by running {v dune exec src/unix/config/discover.exe -- --help v} In addition, the environment variables [LIBEV_CFLAGS], [LIBEV_LIBS], [PTHREAD_CFLAGS], and [PTHREAD_LIBS] can be used to override the flags used for compiling with libev and pthreads. This [discover.ml] was added in Lwt 4.3.0, so if you pass arguments to [discover.ml], 4.3.0 is the minimal required version of Lwt. The code is broken up into sections, each of which is an OCaml module. If your text editor supports code folding, it will make reading this file much easier if you fold the structures. Add feature tests at the end of module [Features]. For most cases, what to do should be clear from the feature tests that are already in that module. *) module Configurator = Configurator.V1 let split = Configurator.Flags.extract_blank_separated_words let uppercase = String.uppercase_ascii (* Command-line arguments and environment variables. *) module Arguments : sig val use_libev : bool option ref val use_pthread : bool option ref val android_target : bool option ref val libev_default : bool option ref val verbose : bool ref val args : (Arg.key * Arg.spec * Arg.doc) list val parse_environment_variable : unit -> unit val parse_arguments_file : unit -> unit end = struct let use_libev = ref None let use_pthread = ref None let android_target = ref None let libev_default = ref None let verbose = ref false let set reference = Arg.Bool (fun value -> reference := Some value) let args = [ "--use-libev", set use_libev, "BOOLEAN whether to check for libev"; "--use-pthread", set use_pthread, "BOOLEAN whether to check for libpthread"; "--android-target", set android_target, "BOOLEAN whether to compile for Android"; "--libev-default", set libev_default, "BOOLEAN whether to use the libev backend by default"; "--verbose", Arg.Set verbose, "BOOLEAN show results of feature detection"; ] let environment_variable = "LWT_DISCOVER_ARGUMENTS" let arguments_file = "discover_arguments" let parse arguments = try Arg.parse_argv ~current:(ref 0) (Array.of_list ((Filename.basename Sys.argv.(0))::(split arguments))) (Arg.align args) (fun s -> raise (Arg.Bad (Printf.sprintf "Unrecognized argument '%s'" s))) (Printf.sprintf "Environment variable usage: %s=[OPTIONS]" environment_variable) with | Arg.Bad s -> prerr_string s; exit 2 | Arg.Help s -> print_string s; exit 0 let parse_environment_variable () = match Sys.getenv environment_variable with | exception Not_found -> () | arguments -> parse arguments let parse_arguments_file () = try let channel = open_in arguments_file in parse (input_line channel); close_in channel with _ -> () end module C_library_flags : sig val detect : ?env_var:string -> ?package:string -> ?header:string -> Configurator.t -> library:string -> unit val ws2_32_lib : Configurator.t -> unit val c_flags : unit -> string list val link_flags : unit -> string list val add_link_flags : string list -> unit end = struct let c_flags = ref ["-Wall"; "-fdiagnostics-color=always"] let link_flags = ref [] let extend c_flags' link_flags' = c_flags := !c_flags @ c_flags'; link_flags := !link_flags @ link_flags' let add_link_flags flags = extend [] flags let (//) = Filename.concat let default_search_paths = [ "/usr"; "/usr/local"; "/usr/pkg"; "/opt"; "/opt/local"; "/sw"; "/mingw"; ] let path_separator = if Sys.win32 then ';' else ':' let paths_from_environment_variable variable = match Sys.getenv variable with | exception Not_found -> [] | paths -> Configurator.Flags.extract_words paths ~is_word_char:((<>) path_separator) |> List.map Filename.dirname let search_paths = lazy begin paths_from_environment_variable "C_INCLUDE_PATH" @ paths_from_environment_variable "LIBRARY_PATH" @ default_search_paths end let default argument fallback = match argument with | Some value -> value | None -> fallback let detect ?env_var ?package ?header context ~library = let env_var = default env_var ("LIB" ^ uppercase library) in let package = default package ("lib" ^ library) in let header = default header (library ^ ".h") in let flags_from_env_var = let c_flags_var = env_var ^ "_CFLAGS" in let link_flags_var = env_var ^ "_LIBS" in match Sys.getenv c_flags_var, Sys.getenv link_flags_var with | exception Not_found -> None | "", "" -> None | values -> Some values in match flags_from_env_var with | Some (c_flags', link_flags') -> extend (split c_flags') (split link_flags') | None -> let flags_from_pkg_config = match Configurator.Pkg_config.get context with | None -> None | Some pkg_config -> Configurator.Pkg_config.query pkg_config ~package in match flags_from_pkg_config with | Some flags -> extend flags.cflags flags.libs | None -> try let path = List.find (fun path -> Sys.file_exists (path // "include" // header)) (Lazy.force search_paths) in extend ["-I" ^ (path // "include")] ["-L" ^ (path // "lib"); "-l" ^ library] with Not_found -> () let ws2_32_lib context = if Configurator.ocaml_config_var_exn context "os_type" = "Win32" then let unicode = ["-DUNICODE"; "-D_UNICODE"] in if Configurator.ocaml_config_var_exn context "ccomp_type" = "msvc" then extend unicode ["ws2_32.lib"] else extend unicode ["-lws2_32"] let c_flags () = !c_flags let link_flags () = !link_flags end module Output : sig type t = { name : string; found : bool; } val write_c_header : ?extra:string list -> Configurator.t -> t list -> unit val write_ml_file : ?extra:t list -> t list -> unit val write_flags_files : unit -> unit end = struct type t = { name : string; found : bool; } module C_define = Configurator.C_define let c_header = "lwt_features.h" let ml_file = "lwt_features.ml" let c_flags_file = "unix_c_flags.sexp" let link_flags_file = "unix_c_library_flags.sexp" let write_c_header ?(extra = []) context macros = macros |> List.filter (fun {found; _} -> found) |> List.map (fun {name; _} -> name, C_define.Value.Switch true) |> (@) (List.map (fun s -> s, C_define.Value.Switch true) extra) |> C_define.gen_header_file context ~fname:c_header let write_ml_file ?(extra = []) macros = macros |> List.map (fun {name; found} -> Printf.sprintf "let _%s = %b" name found) |> (@) (List.map (fun {name; found} -> Printf.sprintf "let %s = %b" name found) extra) |> Configurator.Flags.write_lines ml_file let write_flags_files () = Configurator.Flags.write_sexp c_flags_file (C_library_flags.c_flags ()); Configurator.Flags.write_sexp link_flags_file (C_library_flags.link_flags ()); end module Features : sig val detect : Configurator.t -> Output.t list end = struct type t = { pretty_name : string; macro_name : string; detect : Configurator.t -> bool option; } let features = ref [] let feature the_feature = features := !features @ [the_feature] let verbose = Printf.ksprintf (fun s -> if !Arguments.verbose then print_string s) let dots feature to_column = String.make (to_column - String.length feature.pretty_name) '.' let right_column = 40 let detect context = !features |> List.map begin fun feature -> verbose "%s " feature.pretty_name; match feature.detect context with | None -> verbose "%s skipped\n" (dots feature right_column); Output.{name = feature.macro_name; found = false} | Some found -> begin if found then verbose "%s available\n" (dots feature (right_column - 2)) else verbose "%s unavailable\n" (dots feature (right_column - 4)) end; Output.{name = feature.macro_name; found} end let compiles ?(werror = false) ?(link_flags = []) context code = let c_flags = C_library_flags.c_flags () in let c_flags = if werror then "-Werror"::c_flags else c_flags in let link_flags = link_flags @ (C_library_flags.link_flags ()) in Configurator.c_test context ~c_flags ~link_flags code |> fun result -> Some result let skip_if_windows context k = match Configurator.ocaml_config_var_exn context "os_type" with | "Win32" -> None | _ -> k () let skip_if_android _context k = match !Arguments.android_target with | Some true -> None | _ -> k () let () = feature { pretty_name = "libev"; macro_name = "HAVE_LIBEV"; detect = fun context -> let detect_esy_wants_libev () = match Sys.getenv "cur__target_dir" with | exception Not_found -> None | _ -> match Sys.getenv "LIBEV_CFLAGS", Sys.getenv "LIBEV_LIBS" with | exception Not_found -> Some false | "", "" -> Some false | _ -> Some true in let should_look_for_libev = match !Arguments.use_libev with | Some argument -> argument | None -> match detect_esy_wants_libev () with | Some result -> result | None -> (* we're not under esy *) let os = Configurator.ocaml_config_var_exn context "os_type" in os <> "Win32" && !Arguments.android_target <> Some true in if not should_look_for_libev then None else begin let code = {| #include int main(void) { ev_default_loop(0); return 0; } |} in match compiles context code ~link_flags:["-lev"] with | Some true -> C_library_flags.add_link_flags ["-lev"]; Some true | _ -> C_library_flags.detect context ~library:"ev"; compiles context code end } let () = feature { pretty_name = "pthread"; macro_name = "HAVE_PTHREAD"; detect = fun context -> if !Arguments.use_pthread = Some false then None else begin skip_if_windows context @@ fun () -> let code = {| #include int main(void) { pthread_create(0, 0, 0, 0); return 0; } |} in (* On some platforms, pthread is included in the standard library, but linking with -lpthread fails. So, try to link the test code without any flags first. If that fails and we are not targeting Android, try to link with -lpthread. If *that* fails, search for libpthread in the filesystem. When targeting Android, compiling without -lpthread is the only way to link with pthread, and we don't to search for libpthread, because if we find it, it is likely the host's libpthread. *) match compiles context code with | Some true -> Some true | no -> if !Arguments.android_target = Some true then no else begin match compiles context code ~link_flags:["-lpthread"] with | Some true -> C_library_flags.add_link_flags ["-lpthread"]; Some true | _ -> C_library_flags.detect context ~library:"pthread"; compiles context code end end } let () = feature { pretty_name = "eventfd"; macro_name = "HAVE_EVENTFD"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context {| #include int main(void) { eventfd(0, 0); return 0; } |} } let () = feature { pretty_name = "fd passing"; macro_name = "HAVE_FD_PASSING"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context {| #include #include int main(void) { struct msghdr msg; msg.msg_controllen = 0; msg.msg_control = 0; return 0; } |} } let () = feature { pretty_name = "sched_getcpu"; macro_name = "HAVE_GETCPU"; detect = fun context -> skip_if_windows context @@ fun () -> skip_if_android context @@ fun () -> compiles context {| #define _GNU_SOURCE #include int main(void) { sched_getcpu(); return 0; } |} } let () = feature { pretty_name = "affinity getting/setting"; macro_name = "HAVE_AFFINITY"; detect = fun context -> skip_if_windows context @@ fun () -> skip_if_android context @@ fun () -> compiles context {| #define _GNU_SOURCE #include int main(void) { sched_getaffinity(0, 0, 0); return 0; } |} } let get_credentials struct_name = {| #define _GNU_SOURCE #include #include int main(void) { struct |} ^ struct_name ^ {| cred; socklen_t cred_len = sizeof(cred); getsockopt(0, SOL_SOCKET, SO_PEERCRED, &cred, &cred_len); return 0; } |} let () = feature { pretty_name = "credentials getting (Linux)"; macro_name = "HAVE_GET_CREDENTIALS_LINUX"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context (get_credentials "ucred") } let () = feature { pretty_name = "credentials getting (NetBSD)"; macro_name = "HAVE_GET_CREDENTIALS_NETBSD"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context (get_credentials "sockcred") } let () = feature { pretty_name = "credentials getting (OpenBSD)"; macro_name = "HAVE_GET_CREDENTIALS_OPENBSD"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context (get_credentials "sockpeercred") } let () = feature { pretty_name = "credentials getting (FreeBSD)"; macro_name = "HAVE_GET_CREDENTIALS_FREEBSD"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context (get_credentials "cmsgcred") } let () = feature { pretty_name = "getpeereid"; macro_name = "HAVE_GETPEEREID"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context {| #include #include int main(void) { uid_t euid; gid_t egid; getpeereid(0, &euid, &egid); return 0; } |} } let () = feature { pretty_name = "fdatasync"; macro_name = "HAVE_FDATASYNC"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context {| #include int main(void) { int (*fdatasyncp)(int) = fdatasync; fdatasyncp(0); return 0; } |} } let () = feature { pretty_name = "netdb_reentrant"; macro_name = "HAVE_NETDB_REENTRANT"; detect = fun context -> skip_if_windows context @@ fun () -> skip_if_android context @@ fun () -> compiles context {| #define _POSIX_PTHREAD_SEMANTICS #include #include int main(void) { int x; x = gethostbyname_r( (const char*)NULL, (struct hostent*)NULL, (char*)NULL, (int)0, (struct hostent**)NULL, (int*)NULL); x = gethostbyaddr_r( (const void*)NULL, (int)0, (int)0, (struct hostent*)NULL, (char*)NULL, (int)0, (struct hostent**)NULL, (int*)NULL); x = getservbyname_r( (const char*)NULL, (const char*)NULL, (struct servent*)NULL, (char*)NULL, (int)0, (struct servent**)NULL); x = getservbyport_r( (int)0, (const char*)NULL, (struct servent*)NULL, (char*)NULL, (int)0, (struct servent**)NULL); x = getprotoent_r( (struct protoent*)NULL, (char*)NULL, (int)0, (struct protoent**)NULL); x = getprotobyname_r( (const char*)NULL, (struct protoent*)NULL, (char*)NULL, (int)0, (struct protoent**)NULL); x = getprotobynumber_r( (int)0, (struct protoent*)NULL, (char*)NULL, (int)0, (struct protoent**)NULL); return 0; } |} } let () = feature { pretty_name = "reentrant gethost*"; macro_name = "HAVE_REENTRANT_HOSTENT"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context {| #define _GNU_SOURCE #include #include /* Helper functions for not re-entrant functions */ #if !defined(HAS_GETHOSTBYADDR_R) || \ (HAS_GETHOSTBYADDR_R != 7 && HAS_GETHOSTBYADDR_R != 8) #define NON_R_GETHOSTBYADDR 1 #endif #if !defined(HAS_GETHOSTBYNAME_R) || \ (HAS_GETHOSTBYNAME_R != 5 && HAS_GETHOSTBYNAME_R != 6) #define NON_R_GETHOSTBYNAME 1 #endif int main(void) { #if defined(NON_R_GETHOSTBYNAME) || defined(NON_R_GETHOSTBYNAME) #error "not available" #else return 0; #endif } |} } let nanosecond_stat projection = {| #define _GNU_SOURCE #include #include #include int main(void) { struct stat *buf; double a, m, c; a = (double)buf->st_a|} ^ projection ^ {|; m = (double)buf->st_m|} ^ projection ^ {|; c = (double)buf->st_c|} ^ projection ^ {|; return 0; } |} let () = feature { pretty_name = "st_mtim.tv_nsec"; macro_name = "HAVE_ST_MTIM_TV_NSEC"; detect = fun context -> compiles context (nanosecond_stat "tim.tv_nsec") } let () = feature { pretty_name = "st_mtimespec.tv_nsec"; macro_name = "HAVE_ST_MTIMESPEC_TV_NSEC"; detect = fun context -> compiles context (nanosecond_stat "timespec.tv_nsec") } let () = feature { pretty_name = "st_mtimensec"; macro_name = "HAVE_ST_MTIMENSEC"; detect = fun context -> compiles context (nanosecond_stat "timensec") } let () = feature { pretty_name = "BSD mincore"; macro_name = "HAVE_BSD_MINCORE"; detect = fun context -> skip_if_windows context @@ fun () -> compiles ~werror:true context {| #include #include int main(void) { int (*mincore_ptr)(const void*, size_t, char*) = mincore; return (int)(mincore_ptr == NULL); } |} } let () = feature { pretty_name = "accept4"; macro_name = "HAVE_ACCEPT4"; detect = fun context -> skip_if_windows context @@ fun () -> compiles context {| #define _GNU_SOURCE #include #include int main(void) { accept4(0, NULL, 0, 0); return 0; } |} } end let () = begin match List.partition ((=) "--save") (Array.to_list Sys.argv) with | ["--save"], rest -> Configurator.Flags.write_lines "src/unix/discover_arguments" [String.concat " " (List.tl rest)]; exit 0 | _ -> () end; Configurator.main ~args:Arguments.args ~name:"lwt" begin fun context -> (* Parse arguments from additional sources. *) Arguments.parse_environment_variable (); Arguments.parse_arguments_file (); (* Detect features. *) let macros = Features.detect context in (* Link with ws2_32.lib on Windows. *) C_library_flags.ws2_32_lib context; (* Write lwt_features.h. *) let extra = match Configurator.ocaml_config_var_exn context "os_type" with | "Win32" -> ["LWT_ON_WINDOWS"] | _ -> [] in Output.write_c_header ~extra context macros; (* Write lwt_features.ml. *) let libev_default = match !Arguments.libev_default with | Some argument -> argument | None -> true in Output.write_ml_file ~extra:[ { name = "android"; found = !Arguments.android_target = Some true; }; { name = "libev_default"; found = libev_default; }; ] macros; (* Write unix_c_flags.sexp and unix_c_library_flags.sexp. *) Output.write_flags_files () end lwt-5.9.1/src/unix/config/dune000066400000000000000000000001211476253734400162420ustar00rootroot00000000000000(executable (name discover) (modules discover) (libraries dune.configurator)) lwt-5.9.1/src/unix/dune000066400000000000000000000101111476253734400147750ustar00rootroot00000000000000(* -*- tuareg -*- *) let preprocess = match Sys.getenv "BISECT_ENABLE" with | "yes" -> "(preprocess (pps bisect_ppx))" | _ -> "" | exception _ -> "" let () = Jbuild_plugin.V1.send @@ {| (rule (targets lwt_process.ml) (deps (:ml lwt_process.cppo.ml)) (action (chdir %{project_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{ml} -o %{targets})))) (rule (targets lwt_unix.ml) (deps (:ml lwt_unix.cppo.ml)) (action (chdir %{project_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{ml} -o %{targets})))) (rule (targets lwt_unix.mli) (deps (:ml lwt_unix.cppo.mli)) (action (chdir %{project_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{ml} -o %{targets})))) (rule (mode fallback) (targets discover_arguments) (action (with-stdout-to %{targets} (echo "")))) (rule (targets unix_c_flags.sexp unix_c_library_flags.sexp lwt_features.h lwt_features.ml) (deps (:exe config/discover.exe) discover_arguments) (action (run %{exe}))) (copy_files unix_c/*) (copy_files windows_c/*.c) (library (name lwt_unix) (public_name lwt.unix) (synopsis "Unix support for Lwt") (optional) (wrapped false) (libraries bigarray lwt ocplib-endian.bigstring threads unix) |} ^ preprocess ^ {| (install_c_headers lwt_features lwt_config lwt_unix) (foreign_stubs (language c) (names lwt_unix_stubs lwt_libev_stubs lwt_process_stubs unix_readable unix_writable unix_madvise unix_get_page_size windows_get_page_size unix_mincore unix_read unix_pread windows_read windows_pread unix_bytes_read windows_bytes_read unix_write unix_pwrite windows_write windows_pwrite unix_bytes_write windows_bytes_write unix_readv_writev_utils unix_iov_max unix_writev unix_writev_job unix_readv unix_readv_job unix_send unix_bytes_send unix_recv unix_bytes_recv unix_recvfrom unix_bytes_recvfrom unix_sendto unix_sendto_byte unix_bytes_sendto unix_bytes_sendto_byte unix_recv_send_utils unix_recv_msg unix_send_msg unix_send_msg_byte unix_get_credentials unix_mcast_utils unix_mcast_set_loop unix_mcast_set_ttl unix_mcast_modify_membership unix_wait4 unix_get_cpu unix_get_affinity unix_set_affinity unix_guess_blocking_job unix_wait_mincore_job unix_open_job unix_read_job unix_pread_job windows_read_job windows_pread_job unix_bytes_read_job windows_bytes_read_job unix_write_job windows_write_job unix_pwrite_job windows_pwrite_job unix_bytes_write_job windows_bytes_write_job unix_stat_job_utils unix_stat_job unix_stat_64_job unix_lstat_job unix_lstat_64_job unix_fstat_job unix_fstat_64_job unix_utimes_job unix_isatty_job unix_opendir_job unix_closedir_job unix_valid_dir unix_invalidate_dir unix_rewinddir_job unix_readdir_job unix_readdir_n_job unix_readlink_job unix_lockf_job unix_getlogin_job unix_get_pw_gr_nam_id_job unix_get_network_information_utils unix_gethostname_job unix_gethostbyname_job unix_gethostbyaddr_job unix_getprotoby_getservby_job unix_getaddrinfo_job unix_getnameinfo_job unix_bind_job unix_getcwd_job unix_termios_conversion unix_tcgetattr_job unix_tcsetattr_job windows_is_socket windows_fsync_job windows_system_job windows_not_available unix_not_available unix_access_job unix_chdir_job unix_chmod_job unix_chown_job unix_chroot_job unix_close_job unix_fchmod_job unix_fchown_job unix_fdatasync_job unix_fsync_job unix_ftruncate_job unix_link_job unix_lseek_job unix_mkdir_job unix_mkfifo_job unix_rename_job unix_rmdir_job unix_symlink_job unix_tcdrain_job unix_tcflow_job unix_tcflush_job unix_tcsendbreak_job unix_truncate_job unix_unlink_job unix_somaxconn windows_somaxconn unix_accept4) (flags (:include unix_c_flags.sexp))) (c_library_flags (:include unix_c_library_flags.sexp))) |} lwt-5.9.1/src/unix/lwt_bytes.ml000066400000000000000000000170551476253734400165030ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Bigarray type t = (char, int8_unsigned_elt, c_layout) Array1.t let create size = Array1.create char c_layout size let length bytes = Array1.dim bytes external get : t -> int -> char = "%caml_ba_ref_1" external set : t -> int -> char -> unit = "%caml_ba_set_1" external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1" external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1" [@@@ocaml.warning "-3"] external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc" [@@@ocaml.warning "+3"] let fill bytes ofs len ch = if ofs < 0 || len < 0 || ofs > length bytes - len then invalid_arg "Lwt_bytes.fill" else unsafe_fill bytes ofs len ch (* +-----------------------------------------------------------------+ | Blitting | +-----------------------------------------------------------------+ *) [@@@ocaml.warning "-3"] external unsafe_blit_from_bytes : Bytes.t -> int -> t -> int -> int -> unit = "lwt_unix_blit_from_bytes" "noalloc" external unsafe_blit_from_string : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_from_string" "noalloc" external unsafe_blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit = "lwt_unix_blit_to_bytes" "noalloc" external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit" "noalloc" [@@@ocaml.warning "+3"] let blit_from_string src_buf src_ofs dst_buf dst_ofs len = if (len < 0 || src_ofs < 0 || src_ofs > String.length src_buf - len || dst_ofs < 0 || dst_ofs > length dst_buf - len) then invalid_arg "Lwt_bytes.blit_from_string" else unsafe_blit_from_string src_buf src_ofs dst_buf dst_ofs len let blit_from_bytes src_buf src_ofs dst_buf dst_ofs len = if (len < 0 || src_ofs < 0 || src_ofs > Bytes.length src_buf - len || dst_ofs < 0 || dst_ofs > length dst_buf - len) then invalid_arg "Lwt_bytes.blit_from_bytes" else unsafe_blit_from_bytes src_buf src_ofs dst_buf dst_ofs len let blit_to_bytes src_buf src_ofs dst_buf dst_ofs len = if (len < 0 || src_ofs < 0 || src_ofs > length src_buf - len || dst_ofs < 0 || dst_ofs > Bytes.length dst_buf - len) then invalid_arg "Lwt_bytes.blit_to_bytes" else unsafe_blit_to_bytes src_buf src_ofs dst_buf dst_ofs len let blit src_buf src_ofs dst_buf dst_ofs len = if (len < 0 || src_ofs < 0 || src_ofs > length src_buf - len || dst_ofs < 0 || dst_ofs > length dst_buf - len) then invalid_arg "Lwt_bytes.blit" else unsafe_blit src_buf src_ofs dst_buf dst_ofs len let of_bytes buf = let len = Bytes.length buf in let bytes = create len in unsafe_blit_from_bytes buf 0 bytes 0 len; bytes let of_string str = of_bytes (Bytes.unsafe_of_string str) let to_bytes bytes = let len = length bytes in let str = Bytes.create len in unsafe_blit_to_bytes bytes 0 str 0 len; str let to_string bytes = Bytes.unsafe_to_string (to_bytes bytes) let proxy = Array1.sub let extract buf ofs len = if ofs < 0 || len < 0 || ofs > length buf - len then invalid_arg "Lwt_bytes.extract" else begin let buf' = create len in blit buf ofs buf' 0 len; buf' end let copy buf = let len = length buf in let buf' = create len in blit buf 0 buf' 0 len; buf' (* +-----------------------------------------------------------------+ | IOs | +-----------------------------------------------------------------+ *) open Lwt_unix let read = Lwt_unix.read_bigarray "Lwt_bytes.read" [@ocaml.warning "-3"] let write = Lwt_unix.write_bigarray "Lwt_bytes.write" [@ocaml.warning "-3"] external stub_recv : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_recv" let recv fd buf pos len flags = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.recv" else wrap_syscall Read fd (fun () -> stub_recv (unix_file_descr fd) buf pos len flags) external stub_send : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_send" let send fd buf pos len flags = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.send" else wrap_syscall Write fd (fun () -> stub_send (unix_file_descr fd) buf pos len flags) type io_vector = { iov_buffer : t; iov_offset : int; iov_length : int; } let io_vector ~buffer ~offset ~length = ({ iov_buffer = buffer; iov_offset = offset; iov_length = length; } : io_vector) let convert_io_vectors old_io_vectors = let io_vectors = IO_vectors.create () in old_io_vectors |> List.iter (fun ({iov_buffer; iov_offset; iov_length} : io_vector) -> IO_vectors.append_bigarray io_vectors iov_buffer iov_offset iov_length); io_vectors let recv_msg ~socket ~io_vectors = Lwt_unix.recv_msg ~socket ~io_vectors:(convert_io_vectors io_vectors) let send_msg ~socket ~io_vectors ~fds = Lwt_unix.send_msg ~socket ~io_vectors:(convert_io_vectors io_vectors) ~fds external stub_recvfrom : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_bytes_recvfrom" let recvfrom fd buf pos len flags = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.recvfrom" else wrap_syscall Read fd (fun () -> stub_recvfrom (unix_file_descr fd) buf pos len flags) external stub_sendto : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_bytes_sendto_byte" "lwt_unix_bytes_sendto" let sendto fd buf pos len flags addr = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.sendto" else wrap_syscall Write fd (fun () -> stub_sendto (unix_file_descr fd) buf pos len flags addr) (* +-----------------------------------------------------------------+ | Memory mapped files | +-----------------------------------------------------------------+ *) let map_file ~fd ?pos ~shared ?(size=(-1)) () = Unix.map_file fd ?pos char c_layout shared [|size|] |> Bigarray.array1_of_genarray [@@@ocaml.warning "-3"] external mapped : t -> bool = "lwt_unix_mapped" "noalloc" [@@@ocaml.warning "+3"] type advice = | MADV_NORMAL | MADV_RANDOM | MADV_SEQUENTIAL | MADV_WILLNEED | MADV_DONTNEED | MADV_MERGEABLE | MADV_UNMERGEABLE | MADV_HUGEPAGE | MADV_NOHUGEPAGE external stub_madvise : t -> int -> int -> advice -> unit = "lwt_unix_madvise" let madvise buf pos len advice = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.madvise" else stub_madvise buf pos len advice external get_page_size : unit -> int = "lwt_unix_get_page_size" let page_size = get_page_size () external stub_mincore : t -> int -> int -> bool array -> unit = "lwt_unix_mincore" let mincore buffer offset states = if (offset mod page_size <> 0 || offset < 0 || length buffer - offset < (Array.length states - 1) * page_size + 1) then invalid_arg "Lwt_bytes.mincore" else stub_mincore buffer offset (Array.length states * page_size) states external wait_mincore_job : t -> int -> unit job = "lwt_unix_wait_mincore_job" let wait_mincore buffer offset = if offset < 0 || offset >= length buffer then invalid_arg "Lwt_bytes.wait_mincore" else begin let state = [|false|] in mincore buffer (offset - (offset mod page_size)) state; if state.(0) then Lwt.return_unit else run_job (wait_mincore_job buffer offset) end lwt-5.9.1/src/unix/lwt_bytes.mli000066400000000000000000000147641476253734400166600ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Byte arrays *) type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t (** Type of array of bytes. *) val create : int -> t (** Creates a new byte array of the given size. *) val length : t -> int (** Returns the length of the given byte array. *) (** {2 Access} *) val get : t -> int -> char (** [get buffer offset] returns the byte at offset [offset] in [buffer]. *) val set : t -> int -> char -> unit (** [get buffer offset value] changes the value of the byte at offset [offset] in [buffer] to [value]. *) val unsafe_get : t -> int -> char (** Same as {!get} but without bounds checking. *) val unsafe_set : t -> int -> char -> unit (** Same as {!set} but without bounds checking. *) (** {2 Conversions} *) val of_bytes : bytes -> t (** [of_bytes buf] returns a newly allocated byte array with the same contents as [buf]. *) val of_string : string -> t (** [of_string buf] returns a newly allocated byte array with the same contents as [buf]. *) val to_bytes : t -> bytes (** [to_bytes buf] returns newly allocated bytes with the same contents as [buf]. *) val to_string : t -> string (** [to_string buf] returns a newly allocated string with the same contents as [buf]. *) (** {2 Copying} *) val blit : t -> int -> t -> int -> int -> unit (** [blit buf1 ofs1 buf2 ofs2 len] copies [len] bytes from [buf1] starting at offset [ofs1] to [buf2] starting at offset [ofs2]. *) val blit_from_string : string -> int -> t -> int -> int -> unit (** Same as {!blit} but the first buffer is a [String.t] instead of a byte array. *) val blit_from_bytes : bytes -> int -> t -> int -> int -> unit (** Same as {!blit} but the first buffer is a [Bytes.t] instead of a byte array. *) val blit_to_bytes : t -> int -> bytes -> int -> int -> unit (** Same as {!blit} but the second buffer is a [Bytes.t] instead of a byte array. *) val unsafe_blit : t -> int -> t -> int -> int -> unit (** Same as {!blit} but without bound checking. *) val unsafe_blit_from_bytes : bytes -> int -> t -> int -> int -> unit (** Same as {!Lwt_bytes.blit_from_bytes} but without bounds checking. *) val unsafe_blit_from_string : string -> int -> t -> int -> int -> unit (** Same as {!Lwt_bytes.blit_from_string} but without bounds checking. *) val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit (** Same as {!Lwt_bytes.blit_to_bytes} but without bounds checking. *) val proxy : t -> int -> int -> t (** [proxy buffer offset length] creates a ``proxy''. The returned byte array share the data of [buffer] but with different bounds. *) val extract : t -> int -> int -> t (** [extract buffer offset length] creates a new byte array of length [length] and copy the [length] bytes of [buffer] at [offset] into it. *) val copy : t -> t (** [copy buffer] creates a copy of the given byte array. *) (** {2 Filling} *) val fill : t -> int -> int -> char -> unit (** [fill buffer offset length value] puts [value] in all [length] bytes of [buffer] starting at offset [offset]. *) external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc" [@@ocaml.warning "-3"] (** Same as {!fill} but without bounds checking. *) (** {2 IOs} *) (** The following functions behave similarly to the ones in {!Lwt_unix}, except they use byte arrays instead of [Bytes.t], and they never perform extra copies of the data. *) val read : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t val write : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t val recv : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t (** Not implemented on Windows. *) val send : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t (** Not implemented on Windows. *) val recvfrom : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> (int * Unix.sockaddr) Lwt.t (** Not implemented on Windows. *) val sendto : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int Lwt.t (** Not implemented on Windows. *) type io_vector = { iov_buffer : t; iov_offset : int; iov_length : int; } val io_vector : buffer : t -> offset : int -> length : int -> io_vector val recv_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> (int * Unix.file_descr list) Lwt.t [@@ocaml.deprecated " Use Lwt_unix.Versioned.recv_msg_2."] (** Not implemented on Windows. @deprecated Use {!Lwt_unix.Versioned.recv_msg_2}. *) val send_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> fds : Unix.file_descr list -> int Lwt.t [@@ocaml.deprecated " Use Lwt_unix.Versioned.send_msg_2."] (** Not implemented on Windows. @deprecated Use {!Lwt_unix.Versioned.send_msg_2}. *) (** {2 Memory mapped files} *) val map_file : fd : Unix.file_descr -> ?pos : int64 -> shared : bool -> ?size : int -> unit -> t (** [map_file ~fd ?pos ~shared ?size ()] maps the file descriptor [fd] to an array of bytes. *) external mapped : t -> bool = "lwt_unix_mapped" "noalloc" [@@ocaml.warning "-3"] (** [mapped buffer] returns [true] iff [buffer] is a memory mapped file. *) (** Type of advise that can be sent to the kernel by the program. See the manual madvise(2) for a description of each. *) type advice = | MADV_NORMAL | MADV_RANDOM | MADV_SEQUENTIAL | MADV_WILLNEED | MADV_DONTNEED | MADV_MERGEABLE | MADV_UNMERGEABLE | MADV_HUGEPAGE | MADV_NOHUGEPAGE val madvise : t -> int -> int -> advice -> unit (** [madvise buffer pos len advice] advises the kernel how the program will use the memory mapped file between [pos] and [pos + len]. This call is not available on windows. *) val page_size : int (** Size of pages. *) val mincore : t -> int -> bool array -> unit (** [mincore buffer offset states] tests whether the given pages are in the system memory (the RAM). The [offset] argument must be a multiple of {!page_size}. [states] is used to store the result; each cases is [true] if the corresponding page is in RAM and [false] otherwise. This call is not available on windows and cygwin. *) val wait_mincore : t -> int -> unit Lwt.t (** [wait_mincore buffer offset] waits until the page containing the byte at offset [offset] is in RAM. This functions is not available on windows and cygwin. *) lwt-5.9.1/src/unix/lwt_config.h000066400000000000000000000021301476253734400164250ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #ifndef _LWT_CONFIG_H_ #define _LWT_CONFIG_H_ #include "lwt_features.h" #if defined(HAVE_GET_CREDENTIALS_LINUX) || \ defined(HAVE_GET_CREDENTIALS_NETBSD) || \ defined(HAVE_GET_CREDENTIALS_OPENBSD) || \ defined(HAVE_GET_CREDENTIALS_FREEBSD) || \ defined(HAVE_GETPEEREID) #define HAVE_GET_CREDENTIALS #endif #if defined(HAVE_ST_MTIM_TV_NSEC) #define NANOSEC(buf, field) buf->st_##field##tim.tv_nsec #elif defined(HAVE_ST_MTIMESPEC_TV_NSEC) #define NANOSEC(buf, field) buf->st_##field##timespec.tv_nsec #elif defined(HAVE_ST_MTIMENSEC) #define NANOSEC(buf, field) buf->st_##field##timensec #else #define NANOSEC(buf, field) 0.0 #endif #include #if OCAML_VERSION < 50000 #define CAML_NAME_SPACE #endif #if OCAML_VERSION < 41200 #define Val_none Val_int(0) #define Some_val(v) Field(v, 0) #define Tag_some 0 #define Is_none(v) ((v) == Val_none) #define Is_some(v) Is_block(v) #endif #endif // #ifndef _LWT_CONFIG_H_ lwt-5.9.1/src/unix/lwt_config.ml000066400000000000000000000005601476253734400166130ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) include Lwt_features let _HAVE_GET_CREDENTIALS = _HAVE_GET_CREDENTIALS_LINUX || _HAVE_GET_CREDENTIALS_NETBSD || _HAVE_GET_CREDENTIALS_OPENBSD || _HAVE_GET_CREDENTIALS_FREEBSD || _HAVE_GETPEEREID lwt-5.9.1/src/unix/lwt_engine.ml000066400000000000000000000353051476253734400166200ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] (* +-----------------------------------------------------------------+ | Events | +-----------------------------------------------------------------+ *) type _event = { stop : unit Lazy.t; (* The stop method of the event. *) node : Obj.t Lwt_sequence.node; (* The node in the sequence of registered events. *) } type event = _event ref external cast_node : 'a Lwt_sequence.node -> Obj.t Lwt_sequence.node = "%identity" let stop_event ev = let ev = !ev in Lwt_sequence.remove ev.node; Lazy.force ev.stop let _fake_event = { stop = lazy (); node = Lwt_sequence.add_l (Obj.repr ()) (Lwt_sequence.create ()); } let fake_event = ref _fake_event (* +-----------------------------------------------------------------+ | Engines | +-----------------------------------------------------------------+ *) class virtual abstract = object(self) method virtual iter : bool -> unit method virtual private cleanup : unit method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t val readables = Lwt_sequence.create () (* Sequence of callbacks waiting for a file descriptor to become readable. *) val writables = Lwt_sequence.create () (* Sequence of callbacks waiting for a file descriptor to become writable. *) val timers = Lwt_sequence.create () (* Sequence of timers. *) method destroy = Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) readables; Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) writables; Lwt_sequence.iter_l (fun (_delay, _repeat, _f, _g, ev) -> stop_event ev) timers; self#cleanup method transfer (engine : abstract) = Lwt_sequence.iter_l (fun (fd, f, _g, ev) -> stop_event ev; ev := !(engine#on_readable fd f)) readables; Lwt_sequence.iter_l (fun (fd, f, _g, ev) -> stop_event ev; ev := !(engine#on_writable fd f)) writables; Lwt_sequence.iter_l (fun (delay, repeat, f, _g, ev) -> stop_event ev; ev := !(engine#on_timer delay repeat f)) timers method fake_io fd = Lwt_sequence.iter_l (fun (fd', _f, g, _stop) -> if fd = fd' then g ()) readables; Lwt_sequence.iter_l (fun (fd', _f, g, _stop) -> if fd = fd' then g ()) writables method on_readable fd f = let ev = ref _fake_event in let g () = f ev in let stop = self#register_readable fd g in ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) readables) }; ev method on_writable fd f = let ev = ref _fake_event in let g () = f ev in let stop = self#register_writable fd g in ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) writables) } ; ev method on_timer delay repeat f = let ev = ref _fake_event in let g () = f ev in let stop = self#register_timer delay repeat g in ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (delay, repeat, f, g, ev) timers) }; ev method readable_count = Lwt_sequence.length readables method writable_count = Lwt_sequence.length writables method timer_count = Lwt_sequence.length timers method fork = () method forwards_signal (_signum:int) = false end class type t = object inherit abstract method iter : bool -> unit method private cleanup : unit method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t end (* +-----------------------------------------------------------------+ | The libev engine | +-----------------------------------------------------------------+ *) type ev_loop type ev_io type ev_timer module Ev_backend = struct type t = | EV_DEFAULT | EV_SELECT | EV_POLL | EV_EPOLL | EV_KQUEUE | EV_DEVPOLL | EV_PORT let default = EV_DEFAULT let select = EV_SELECT let poll = EV_POLL let epoll = EV_EPOLL let kqueue = EV_KQUEUE let devpoll = EV_DEVPOLL let port = EV_PORT let equal = ( = ) let name = function | EV_DEFAULT -> "EV_DEFAULT" | EV_SELECT -> "EV_SELECT" | EV_POLL -> "EV_POLL" | EV_EPOLL -> "EV_EPOLL" | EV_KQUEUE -> "EV_KQUEUE" | EV_DEVPOLL -> "EV_DEVPOLL" | EV_PORT -> "EV_PORT" let pp fmt t = Format.pp_print_string fmt (name t) end external ev_init : Ev_backend.t -> ev_loop = "lwt_libev_init" external ev_backend : ev_loop -> Ev_backend.t = "lwt_libev_backend" external ev_stop : ev_loop -> unit = "lwt_libev_stop" external ev_loop : ev_loop -> bool -> unit = "lwt_libev_loop" external ev_unloop : ev_loop -> unit = "lwt_libev_unloop" external ev_readable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_readable_init" external ev_writable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_writable_init" external ev_io_stop : ev_loop -> ev_io -> unit = "lwt_libev_io_stop" external ev_timer_init : ev_loop -> float -> bool -> (unit -> unit) -> ev_timer = "lwt_libev_timer_init" external ev_timer_stop : ev_loop -> ev_timer -> unit = "lwt_libev_timer_stop" class libev ?(backend=Ev_backend.default) () = object inherit abstract val loop = ev_init backend method loop = loop method backend = ev_backend loop method private cleanup = ev_stop loop method iter block = try ev_loop loop block with exn -> ev_unloop loop; raise exn method private register_readable fd f = let ev = ev_readable_init loop fd f in lazy(ev_io_stop loop ev) method private register_writable fd f = let ev = ev_writable_init loop fd f in lazy(ev_io_stop loop ev) method private register_timer delay repeat f = let ev = ev_timer_init loop delay repeat f in lazy(ev_timer_stop loop ev) end class libev_deprecated = libev () (* +-----------------------------------------------------------------+ | Select/poll based engines | +-----------------------------------------------------------------+ *) (* Type of a sleeper for the select engine. *) type sleeper = { mutable time : float; (* The time at which the sleeper should be wakeup. *) mutable stopped : bool; (* [true] iff the event has been stopped. *) action : unit -> unit; (* The action for the sleeper. *) } module Sleep_queue = Lwt_pqueue.Make(struct type t = sleeper let compare {time = t1; _} {time = t2; _} = compare t1 t2 end) [@@ocaml.warning "-3"] module Fd_map = Map.Make(struct type t = Unix.file_descr let compare = compare end) let rec restart_actions sleep_queue now = match Sleep_queue.lookup_min sleep_queue with | Some{ stopped = true; _ } -> restart_actions (Sleep_queue.remove_min sleep_queue) now | Some{ time = time; action = action; _ } when time <= now -> (* We have to remove the sleeper to the queue before performing the action. The action can change the sleeper's time, and this might break the priority queue invariant if the sleeper is still in the queue. *) let q = Sleep_queue.remove_min sleep_queue in action (); restart_actions q now | _ -> sleep_queue let rec get_next_timeout sleep_queue = match Sleep_queue.lookup_min sleep_queue with | Some{ stopped = true; _ } -> get_next_timeout (Sleep_queue.remove_min sleep_queue) | Some{ time = time; _ } -> max 0. (time -. Unix.gettimeofday ()) | None -> -1. let bad_fd fd = try let _ = Unix.fstat fd in false with Unix.Unix_error (_, _, _) -> true let invoke_actions fd map = match Fd_map.find fd map with | exception Not_found -> () | actions -> Lwt_sequence.iter_l (fun f -> f ()) actions class virtual select_or_poll_based = object inherit abstract val mutable sleep_queue = Sleep_queue.empty (* Threads waiting for a timeout to expire. *) val mutable new_sleeps = [] (* Sleepers added since the last iteration of the main loop: They are not added immediately to the main sleep queue in order to prevent them from being wakeup immediately. *) val mutable wait_readable = Fd_map.empty (* Sequences of actions waiting for file descriptors to become readable. *) val mutable wait_writable = Fd_map.empty (* Sequences of actions waiting for file descriptors to become writable. *) method private cleanup = () method private register_timer delay repeat f = if repeat then begin let rec sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = g } and g () = sleeper.time <- Unix.gettimeofday () +. delay; new_sleeps <- sleeper :: new_sleeps; f () in new_sleeps <- sleeper :: new_sleeps; lazy(sleeper.stopped <- true) end else begin let sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = f } in new_sleeps <- sleeper :: new_sleeps; lazy(sleeper.stopped <- true) end method private register_readable fd f = let actions = try Fd_map.find fd wait_readable with Not_found -> let actions = Lwt_sequence.create () in wait_readable <- Fd_map.add fd actions wait_readable; actions in let node = Lwt_sequence.add_l f actions in lazy(Lwt_sequence.remove node; if Lwt_sequence.is_empty actions then wait_readable <- Fd_map.remove fd wait_readable) method private register_writable fd f = let actions = try Fd_map.find fd wait_writable with Not_found -> let actions = Lwt_sequence.create () in wait_writable <- Fd_map.add fd actions wait_writable; actions in let node = Lwt_sequence.add_l f actions in lazy(Lwt_sequence.remove node; if Lwt_sequence.is_empty actions then wait_writable <- Fd_map.remove fd wait_writable) end class virtual select_based = object(self) inherit select_or_poll_based method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list method iter block = (* Transfer all sleepers added since the last iteration to the main sleep queue: *) sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; new_sleeps <- []; (* Collect file descriptors. *) let fds_r = Fd_map.fold (fun fd _ l -> fd :: l) wait_readable [] in let fds_w = Fd_map.fold (fun fd _ l -> fd :: l) wait_writable [] in (* Compute the timeout. *) let timeout = if block then get_next_timeout sleep_queue else 0. in (* Do the blocking call *) let fds_r, fds_w = try self#select fds_r fds_w timeout with | Unix.Unix_error (Unix.EINTR, _, _) -> ([], []) | Unix.Unix_error (Unix.EBADF, _, _) -> (* Keeps only bad file descriptors. Actions registered on them have to handle the error: *) (List.filter bad_fd fds_r, List.filter bad_fd fds_w) in (* Restart threads waiting for a timeout: *) sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); (* Restart threads waiting on a file descriptors: *) List.iter (fun fd -> invoke_actions fd wait_readable) fds_r; List.iter (fun fd -> invoke_actions fd wait_writable) fds_w end class virtual poll_based = object(self) inherit select_or_poll_based method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list method iter block = (* Transfer all sleepers added since the last iteration to the main sleep queue: *) sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; new_sleeps <- []; (* Collect file descriptors. *) let fds = [] in let fds = Fd_map.fold (fun fd _ l -> (fd, true, false) :: l) wait_readable fds in let fds = Fd_map.fold (fun fd _ l -> (fd, false, true) :: l) wait_writable fds in (* Compute the timeout. *) let timeout = if block then get_next_timeout sleep_queue else 0. in (* Do the blocking call *) let fds = try self#poll fds timeout with | Unix.Unix_error (Unix.EINTR, _, _) -> [] | Unix.Unix_error (Unix.EBADF, _, _) -> (* Keeps only bad file descriptors. Actions registered on them have to handle the error: *) List.filter (fun (fd, _, _) -> bad_fd fd) fds in (* Restart threads waiting for a timeout: *) sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); (* Restart threads waiting on a file descriptors: *) List.iter (fun (fd, readable, writable) -> if readable then invoke_actions fd wait_readable; if writable then invoke_actions fd wait_writable) fds end class select = object inherit select_based method private select fds_r fds_w timeout = let fds_r, fds_w, _ = Unix.select fds_r fds_w [] timeout in (fds_r, fds_w) end (* +-----------------------------------------------------------------+ | The current engine | +-----------------------------------------------------------------+ *) let current = if Lwt_config._HAVE_LIBEV && Lwt_config.libev_default then ref (new libev () :> t) else ref (new select :> t) let get () = !current let set ?(transfer=true) ?(destroy=true) engine = if transfer then !current#transfer (engine : #t :> abstract); if destroy then !current#destroy; current := (engine : #t :> t) let iter block = !current#iter block let on_readable fd f = !current#on_readable fd f let on_writable fd f = !current#on_writable fd f let on_timer delay repeat f = !current#on_timer delay repeat f let fake_io fd = !current#fake_io fd let readable_count () = !current#readable_count let writable_count () = !current#writable_count let timer_count () = !current#timer_count let fork () = !current#fork let forwards_signal n = !current#forwards_signal n module Versioned = struct class libev_1 = libev_deprecated class libev_2 = libev end lwt-5.9.1/src/unix/lwt_engine.mli000066400000000000000000000170611476253734400167700ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Lwt unix main loop engine *) (** {2 Events} *) type event (** Type of events. An event represent a callback registered to be called when some event occurs. *) val stop_event : event -> unit (** [stop_event event] stops the given event. *) val fake_event : event (** Event which does nothing when stopped. *) (** {2 Event loop functions} *) val iter : bool -> unit (** [iter block] performs one iteration of the main loop. If [block] is [true] the function must block until one event becomes available, otherwise it should just check for available events and return immediately. *) val on_readable : Unix.file_descr -> (event -> unit) -> event (** [on_readable fd f] calls [f] each time [fd] becomes readable. *) val on_writable : Unix.file_descr -> (event -> unit) -> event (** [on_readable fd f] calls [f] each time [fd] becomes writable. *) val on_timer : float -> bool -> (event -> unit) -> event (** [on_timer delay repeat f] calls [f] one time after [delay] seconds. If [repeat] is [true] then [f] is called each [delay] seconds, otherwise it is called only one time. *) val readable_count : unit -> int (** Returns the number of events waiting for a file descriptor to become readable. *) val writable_count : unit -> int (** Returns the number of events waiting for a file descriptor to become writable. *) val timer_count : unit -> int (** Returns the number of registered timers. *) val fake_io : Unix.file_descr -> unit (** Simulates activity on the given file descriptor. *) val fork : unit -> unit (** Called internally by Lwt_unix.fork to make sure we don't get strange behaviour *) val forwards_signal : int -> bool (** [forwards_signal signum] is [true] if the engine will call {!Lwt_unix.handle_signal} when signal [signum] occurs. In this case, Lwt will not install its own signal handler. Normally, this just returns [false], but when Lwt is used in combination with other IO libraries, this allows sharing e.g. the SIGCHLD handler. *) (** {2 Engines} *) (** An engine represents a set of functions used to register different kinds of callbacks for different kinds of events. *) (** Abstract class for engines. *) class virtual abstract : object method destroy : unit (** Destroy the engine, remove all its events and free its associated resources. *) method transfer : abstract -> unit (** [transfer engine] moves all events from the current engine to [engine]. Note that timers are reset in the destination engine, i.e. if a timer with a delay of 2 seconds was registered 1 second ago it will occur in 2 seconds in the destination engine. *) (** {2 Event loop methods} *) method virtual iter : bool -> unit method fork : unit method on_readable : Unix.file_descr -> (event -> unit) -> event method on_writable : Unix.file_descr -> (event -> unit) -> event method on_timer : float -> bool -> (event -> unit) -> event method fake_io : Unix.file_descr -> unit method readable_count : int method writable_count : int method timer_count : int method forwards_signal : int -> bool (** {2 Backend methods} *) (** Notes: - the callback passed to register methods is of type [unit -> unit] and not [event -> unit] - register methods return a lazy value which unregisters the event when forced *) method virtual private cleanup : unit (** Cleanup resources associated with the engine. *) method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t end (** Type of engines. *) class type t = object inherit abstract method iter : bool -> unit method private cleanup : unit method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t end (** {2 Predefined engines} *) type ev_loop module Ev_backend : sig type t val default : t val select : t val poll : t val epoll : t val kqueue : t val devpoll : t val port : t val equal : t -> t -> bool val pp : Format.formatter -> t -> unit end (** Type of libev loops. *) (** Engine based on libev. If not compiled with libev support, the creation of the class will raise {!Lwt_sys.Not_available}. *) class libev : ?backend:Ev_backend.t -> unit -> object inherit t method backend : Ev_backend.t (** The backend picked by libev. *) val loop : ev_loop (** The libev loop used for this engine. *) method loop : ev_loop (** Returns [loop]. *) end (** Engine based on {!Unix.select}. *) class select : t (** Abstract class for engines based on a select-like function. *) class virtual select_based : object inherit t method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list (** [select fds_r fds_w timeout] waits for either: - one of the file descriptor of [fds_r] to become readable - one of the file descriptor of [fds_w] to become writable - timeout to expire and returns the list of readable file descriptor and the list of writable file descriptors. *) end (** Abstract class for engines based on a poll-like function. *) class virtual poll_based : object inherit t method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list (** [poll fds tiomeout], where [fds] is a list of tuples of the form [(fd, check_readable, check_writable)], waits for either: - one of the file descriptor with [check_readable] set to [true] to become readable - one of the file descriptor with [check_writable] set to [true] to become writable - timeout to expire and returns the list of file descriptors with their readable and writable status. *) end (** {2 The current engine} *) val get : unit -> t (** [get ()] returns the engine currently in use. *) val set : ?transfer : bool -> ?destroy : bool -> #t -> unit (** [set ?transfer ?destroy engine] replaces the current engine by the given one. If [transfer] is [true] (the default) all events from the current engine are transferred to the new one. If [destroy] is [true] (the default) then the current engine is destroyed before being replaced. *) module Versioned : sig class libev_1 : object inherit t val loop : ev_loop method backend : Ev_backend.t method loop : ev_loop end [@@ocaml.deprecated " Deprecated in favor of Lwt_engine.libev. See https://github.com/ocsigen/lwt/pull/269"] (** Old version of {!Lwt_engine.libev}. The current {!Lwt_engine.libev} allows selecting the libev back end. @deprecated Use {!Lwt_engine.libev}. @since 2.7.0 *) class libev_2 : ?backend:Ev_backend.t -> unit -> object inherit t val loop : ev_loop method backend : Ev_backend.t method loop : ev_loop end [@@ocaml.deprecated " In Lwt >= 3.0.0, this is an alias for Lwt_engine.libev."] (** Since Lwt 3.0.0, this is just an alias for {!Lwt_engine.libev}. @deprecated Use {!Lwt_engine.libev}. @since 2.7.0 *) end lwt-5.9.1/src/unix/lwt_fmt.ml000066400000000000000000000037551476253734400161450ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix type formatter = { commit : unit -> unit Lwt.t ; fmt : Format.formatter ; } let write_pending ppft = ppft.commit () let flush ppft = Format.pp_print_flush ppft.fmt () ; ppft.commit () let make_formatter ~commit ~fmt () = { commit ; fmt } let get_formatter x = x.fmt (** Stream formatter *) type order = | String of string * int * int | Flush let make_stream () = let stream, push = Lwt_stream.create () in let out_string s i j = push @@ Some (String (s, i, j)) and flush () = push @@ Some Flush in let fmt = Format.make_formatter out_string flush in (* Not sure about that one *) Gc.finalise (fun _ -> push None) fmt ; let commit () = Lwt.return_unit in stream, make_formatter ~commit ~fmt () (** Channel formatter *) let write_order oc = function | String (s, i, j) -> Lwt_io.write_from_string_exactly oc s i j | Flush -> Lwt_io.flush oc let rec write_orders oc queue = if Queue.is_empty queue then Lwt.return_unit else let o = Queue.pop queue in write_order oc o >>= fun () -> write_orders oc queue let of_channel oc = let q = Queue.create () in let out_string s i j = Queue.push (String (s, i, j)) q and flush () = Queue.push Flush q in let fmt = Format.make_formatter out_string flush in let commit () = write_orders oc q in make_formatter ~commit ~fmt () (** Printing functions *) let kfprintf k ppft fmt = Format.kfprintf (fun _ppf -> k ppft @@ ppft.commit ()) ppft.fmt fmt let ikfprintf k ppft fmt = Format.ikfprintf (fun _ppf -> k ppft @@ Lwt.return_unit) ppft.fmt fmt let fprintf ppft fmt = kfprintf (fun _ t -> t) ppft fmt let ifprintf ppft fmt = ikfprintf (fun _ t -> t) ppft fmt let stdout = of_channel Lwt_io.stdout let stderr = of_channel Lwt_io.stderr let printf fmt = fprintf stdout fmt let eprintf fmt = fprintf stderr fmt lwt-5.9.1/src/unix/lwt_fmt.mli000066400000000000000000000061611476253734400163100ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Format API for Lwt-powered IOs @since 4.1.0 *) (** This module bridges the gap between {!Stdlib.Format} and {!Lwt}. Although it is not required, it is recommended to use this module with the {{:https://erratique.ch/software/fmt} [Fmt]} library. Compared to regular formatting function, the main difference is that printing statements will now return promises instead of blocking. *) val printf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a (** Returns a promise that prints on the standard output. Similar to {!Stdlib.Format.printf}. *) val eprintf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a (** Returns a promise that prints on the standard error. Similar to {!Stdlib.Format.eprintf}. *) (** {1 Formatters} *) type formatter (** Lwt enabled formatters *) type order = | String of string * int * int (** [String (s, off, len)] indicate the output of [s] at offset [off] and length [len]. *) | Flush (** Flush operation *) val make_stream : unit -> order Lwt_stream.t * formatter (** [make_stream ()] returns a formatter and a stream of all the writing order given on that stream. *) val of_channel : Lwt_io.output_channel -> formatter (** [of_channel oc] creates a formatter that writes to the channel [oc]. *) val stdout : formatter (** Formatter printing on {!Lwt_io.stdout}. *) val stderr : formatter (** Formatter printing on {!Lwt_io.stdout}. *) val make_formatter : commit:(unit -> unit Lwt.t) -> fmt:Format.formatter -> unit -> formatter (** [make_formatter ~commit ~fmt] creates a new lwt formatter based on the {!Stdlib.Format.formatter} [fmt]. The [commit] function will be called by the printing functions to update the underlying channel. *) val get_formatter : formatter -> Format.formatter (** [get_formatter fmt] returns the underlying {!Stdlib.Format.formatter}. To access the underlying formatter during printing, it is recommended to use [%t] and [%a]. *) (** {2 Printing} *) val fprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a val kfprintf : (formatter -> unit Lwt.t -> 'a) -> formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b val ifprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a val ikfprintf : (formatter -> unit Lwt.t -> 'a) -> formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b val flush : formatter -> unit Lwt.t (** [flush fmt] flushes the formatter (as with {!Stdlib.Format.pp_print_flush}) and executes all the printing action on the underlying channel. *) (** Low level functions *) val write_order : Lwt_io.output_channel -> order -> unit Lwt.t (** [write_order oc o] applies the order [o] on the channel [oc]. *) val write_pending : formatter -> unit Lwt.t (** Write all the pending orders of a formatter. Warning: This function flush neither the internal format queues nor the underlying channel and is intended for low level use only. You should probably use {!flush} instead. *) lwt-5.9.1/src/unix/lwt_gc.ml000066400000000000000000000052021476253734400157350ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] let ensure_termination t = if Lwt.state t = Lwt.Sleep then begin let hook = Lwt_sequence.add_l (fun _ -> t) Lwt_main.exit_hooks [@ocaml.warning "-3"] in (* Remove the hook when t has terminated *) ignore ( Lwt.finalize (fun () -> t) (fun () -> Lwt_sequence.remove hook; Lwt.return_unit)) end let finaliser f = (* In order not to create a reference to the value in the notification callback, we use an initially unset option cell which will be filled when the finaliser is called. *) let opt = ref None in let id = Lwt_unix.make_notification ~once:true (fun () -> match !opt with | None -> assert false | Some x -> opt := None; ensure_termination (f x)) in (* The real finaliser: fill the cell and send a notification. *) (fun x -> opt := Some x; Lwt_unix.send_notification id) let finalise f x = Gc.finalise (finaliser f) x (* Exit hook for a finalise_or_exit *) let foe_exit f called weak () = match Weak.get weak 0 with | None -> (* The value has been garbage collected, normally this point is never reached *) Lwt.return_unit | Some x -> (* Just to avoid double finalisation *) Weak.set weak 0 None; if !called then Lwt.return_unit else begin called := true; f x end (* Finaliser for a finalise_or_exit *) let foe_finaliser f called hook = finaliser (fun x -> (* Remove the exit hook, it is not needed anymore. *) Lwt_sequence.remove hook; (* Call the real finaliser. *) if !called then Lwt.return_unit else begin called := true; f x end) let finalise_or_exit f x = (* Create a weak pointer, so the exit-hook does not keep a reference to [x]. *) let weak = Weak.create 1 in Weak.set weak 0 (Some x); let called = ref false in let hook = Lwt_sequence.add_l (foe_exit f called weak) Lwt_main.exit_hooks [@ocaml.warning "-3"] in Gc.finalise (foe_finaliser f called hook) x lwt-5.9.1/src/unix/lwt_gc.mli000066400000000000000000000015521476253734400161120ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Interaction with the garbage collector *) (** This module offers a convenient way to add a finaliser launching a thread to a value, without having to use [Lwt_unix.run] in the finaliser. *) val finalise : ('a -> unit Lwt.t) -> 'a -> unit (** [finalise f x] ensures [f x] is evaluated after [x] has been garbage collected. If [f x] yields, then Lwt will wait for its termination at the end of the program. Note that [f x] is not called at garbage collection time, but later in the main loop. *) val finalise_or_exit : ('a -> unit Lwt.t) -> 'a -> unit (** [finalise_or_exit f x] call [f x] when [x] is garbage collected or (exclusively) when the program exits. *) lwt-5.9.1/src/unix/lwt_io.ml000066400000000000000000001576261476253734400157750ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] open Lwt.Infix exception Channel_closed of string (* Minimum size for buffers: *) let min_buffer_size = 16 let check_buffer_size fun_name buffer_size = if buffer_size < min_buffer_size then Printf.ksprintf invalid_arg "Lwt_io.%s: too small buffer size" fun_name else if buffer_size > Sys.max_string_length then Printf.ksprintf invalid_arg "Lwt_io.%s: too big buffer size" fun_name else () let check_buffer fun_name buffer = check_buffer_size fun_name (Lwt_bytes.length buffer) let default_buffer_size = ref 4096 (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) type input type output type 'a mode = | Input : input mode | Output : output mode let input : input mode = Input let output : output mode = Output (* A channel state *) type 'mode state = | Busy_primitive (* A primitive is running on the channel *) | Busy_atomic of 'mode channel (* An atomic operations is being performed on the channel. The argument is the temporary atomic wrapper. *) | Waiting_for_busy (* A queued operation has not yet started. *) | Idle (* The channel is unused *) | Closed (* The channel has been closed *) | Invalid (* The channel is a temporary channel created for an atomic operation which has terminated. *) (* A wrapper, which ensures that io operations are atomic: *) and 'mode channel = { mutable state : 'mode state; channel : 'mode _channel; (* The real channel *) mutable queued : unit Lwt.u Lwt_sequence.t; (* Queued operations *) } and 'mode _channel = { mutable buffer : Lwt_bytes.t; mutable length : int; mutable ptr : int; (* Current position *) mutable max : int; (* Position of the end of data int the buffer. It is equal to [length] for output channels. *) abort_waiter : int Lwt.t; (* Thread which is wakeup with an exception when the channel is closed. *) abort_wakener : int Lwt.u; mutable auto_flushing : bool; (* Whether the auto-flusher is currently running or not *) main : 'mode channel; (* The main wrapper *) close : unit Lwt.t Lazy.t; (* Close function *) mode : 'mode mode; (* The channel mode *) mutable offset : int64; (* Number of bytes really read/written *) typ : typ; (* Type of the channel. *) } and typ = | Type_normal of (Lwt_bytes.t -> int -> int -> int Lwt.t) * (int64 -> Unix.seek_command -> int64 Lwt.t) (* The channel has been created with [make]. The first argument is the refill/flush function and the second is the seek function. *) | Type_bytes (* The channel has been created with [of_bytes]. *) type input_channel = input channel type output_channel = output channel type direct_access = { da_buffer : Lwt_bytes.t; mutable da_ptr : int; mutable da_max : int; da_perform : unit -> int Lwt.t; } let mode wrapper = wrapper.channel.mode (* +-----------------------------------------------------------------+ | Creations, closing, locking, ... | +-----------------------------------------------------------------+ *) (* This strange hash function is fine because Lwt_io only ever: - adds distinct channels to the hash set, - folds over the hash set. Lwt_io never looks up individual elements. The constant function is not suitable, because then all channels will end up in the same hash bucket. A weak hash set is used instead of a weak array to avoid having to include resizing and compaction code in Lwt_io. *) let hash_output_channel = let index = ref 0 in fun () -> index := !index + 1; !index module Outputs = Weak.Make(struct type t = output_channel let hash _ = hash_output_channel () let equal = ( == ) end) (* Table of all opened output channels. On exit they are all flushed: *) let outputs = Outputs.create 32 let position : type mode. mode channel -> int64 = fun wrapper -> let ch = wrapper.channel in match ch.mode with | Input -> Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) | Output -> Int64.add ch.offset (Int64.of_int ch.ptr) let name : type mode. mode _channel -> string = fun ch -> match ch.mode with | Input -> "input" | Output -> "output" let closed_channel ch = Channel_closed (name ch) let invalid_channel ch = Failure (Printf.sprintf "temporary atomic channel %s no more valid" (name ch)) let is_busy ch = match ch.state with | Invalid -> raise (invalid_channel ch.channel) | Idle | Closed -> false | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> true (* Flush/refill the buffer. No race condition could happen because this function is always called atomically: *) let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> match ch.main.state with | Closed -> Lwt.fail (closed_channel ch) | Invalid -> Lwt.fail (invalid_channel ch) | Idle | Waiting_for_busy -> assert false | Busy_primitive | Busy_atomic _ -> match ch.typ with | Type_normal (perform, _) -> let ptr, len = match ch.mode with | Input -> (* Size of data in the buffer *) let size = ch.max - ch.ptr in (* If there are still data in the buffer, keep them: *) if size > 0 then Lwt_bytes.unsafe_blit ch.buffer ch.ptr ch.buffer 0 size; (* Update positions: *) ch.ptr <- 0; ch.max <- size; (size, ch.length - size) | Output -> (0, ch.ptr) in let perform = if Sys.win32 then Lwt.catch (fun () -> perform ch.buffer ptr len) (function | Unix.Unix_error (Unix.EPIPE, _, _) -> Lwt.return 0 | exn -> Lwt.reraise exn) [@ocaml.warning "-4"] else perform ch.buffer ptr len in Lwt.pick [ch.abort_waiter; perform] >>= fun n -> (* Never trust user functions... *) if n < 0 || n > len then Lwt.fail (Failure (Printf.sprintf "Lwt_io.perform_io: invalid result of the [%s] function" (match ch.mode with Input -> "read" | Output -> "write"))) else begin (* Update the global offset: *) ch.offset <- Int64.add ch.offset (Int64.of_int n); (* Update buffer positions: *) begin match ch.mode with | Input -> ch.max <- ch.max + n | Output -> (* Shift remaining data: *) let len = len - n in Lwt_bytes.unsafe_blit ch.buffer n ch.buffer 0 len; ch.ptr <- len end; Lwt.return n end | Type_bytes -> begin match ch.mode with | Input -> Lwt.return 0 | Output -> Lwt.fail (Failure "cannot flush a channel created with Lwt_io.of_string") end let refill = perform_io let flush_partial = perform_io let rec flush_total oc = if oc.ptr > 0 then flush_partial oc >>= fun _ -> flush_total oc else Lwt.return_unit let safe_flush_total oc = Lwt.catch (fun () -> flush_total oc) (fun _ -> Lwt.return_unit) let deepest_wrapper ch = let rec loop wrapper = match wrapper.state with | Busy_atomic wrapper -> loop wrapper | Busy_primitive | Waiting_for_busy | Idle | Closed | Invalid -> wrapper in loop ch.main let auto_flush oc = Lwt.pause () >>= fun () -> let wrapper = deepest_wrapper oc in match wrapper.state with | Busy_primitive | Waiting_for_busy -> (* The channel is used, cancel auto flushing. It will be restarted when the channel Lwt.returns to the [Idle] state: *) oc.auto_flushing <- false; Lwt.return_unit | Busy_atomic _ -> (* Cannot happen since we took the deepest wrapper: *) assert false | Idle -> oc.auto_flushing <- false; wrapper.state <- Busy_primitive; safe_flush_total oc >>= fun () -> if wrapper.state = Busy_primitive then wrapper.state <- Idle; if not (Lwt_sequence.is_empty wrapper.queued) then Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) (); Lwt.return_unit | Closed | Invalid -> Lwt.return_unit (* A ``locked'' channel is a channel in the state [Busy_primitive] or [Busy_atomic] *) let unlock : type m. m channel -> unit = fun wrapper -> match wrapper.state with | Busy_primitive | Busy_atomic _ -> if Lwt_sequence.is_empty wrapper.queued then wrapper.state <- Idle else begin wrapper.state <- Waiting_for_busy; Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () end; (* Launches the auto-flusher: *) let ch = wrapper.channel in if (* Launch the auto-flusher only if the channel is not busy: *) (wrapper.state = Idle && (* Launch the auto-flusher only for output channel: *) (match ch.mode with Input -> false | Output -> true) && (* Do not launch two auto-flusher: *) not ch.auto_flushing && (* Do not launch the auto-flusher if operations are queued: *) Lwt_sequence.is_empty wrapper.queued) then begin ch.auto_flushing <- true; ignore (auto_flush ch) end | Closed | Invalid -> (* Do not change channel state if the channel has been closed *) if not (Lwt_sequence.is_empty wrapper.queued) then Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () | Idle | Waiting_for_busy -> (* We must never unlock an unlocked channel *) assert false (* Wrap primitives into atomic io operations: *) let primitive f wrapper = match wrapper.state with | Idle -> wrapper.state <- Busy_primitive; Lwt.finalize (fun () -> f wrapper.channel) (fun () -> unlock wrapper; Lwt.return_unit) | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> (Lwt.add_task_r [@ocaml.warning "-3"]) wrapper.queued >>= fun () -> begin match wrapper.state with | Closed -> (* The channel has been closed while we were waiting *) unlock wrapper; Lwt.fail (closed_channel wrapper.channel) | Idle | Waiting_for_busy -> wrapper.state <- Busy_primitive; Lwt.finalize (fun () -> f wrapper.channel) (fun () -> unlock wrapper; Lwt.return_unit) | Invalid -> Lwt.fail (invalid_channel wrapper.channel) | Busy_primitive | Busy_atomic _ -> assert false end | Closed -> Lwt.fail (closed_channel wrapper.channel) | Invalid -> Lwt.fail (invalid_channel wrapper.channel) (* Wrap a sequence of io operations into an atomic operation: *) let atomic f wrapper = match wrapper.state with | Idle -> let tmp_wrapper = { state = Idle; channel = wrapper.channel; queued = Lwt_sequence.create () } in wrapper.state <- Busy_atomic tmp_wrapper; Lwt.finalize (fun () -> f tmp_wrapper) (fun () -> (* The temporary wrapper is no more valid: *) tmp_wrapper.state <- Invalid; unlock wrapper; Lwt.return_unit) | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> (Lwt.add_task_r [@ocaml.warning "-3"]) wrapper.queued >>= fun () -> begin match wrapper.state with | Closed -> (* The channel has been closed while we were waiting *) unlock wrapper; Lwt.fail (closed_channel wrapper.channel) | Idle | Waiting_for_busy -> let tmp_wrapper = { state = Idle; channel = wrapper.channel; queued = Lwt_sequence.create () } in wrapper.state <- Busy_atomic tmp_wrapper; Lwt.finalize (fun () -> f tmp_wrapper) (fun () -> tmp_wrapper.state <- Invalid; unlock wrapper; Lwt.return_unit) | Invalid -> Lwt.fail (invalid_channel wrapper.channel) | Busy_primitive | Busy_atomic _ -> assert false end | Closed -> Lwt.fail (closed_channel wrapper.channel) | Invalid -> Lwt.fail (invalid_channel wrapper.channel) let rec abort wrapper = match wrapper.state with | Busy_atomic tmp_wrapper -> (* Close the depest opened wrapper: *) abort tmp_wrapper | Closed -> (* Double close, just returns the same thing as before *) Lazy.force wrapper.channel.close | Invalid -> Lwt.fail (invalid_channel wrapper.channel) | Idle | Busy_primitive | Waiting_for_busy -> wrapper.state <- Closed; (* Abort any current real reading/writing operation on the channel: *) Lwt.wakeup_exn wrapper.channel.abort_wakener (closed_channel wrapper.channel); Lazy.force wrapper.channel.close let close : type mode. mode channel -> unit Lwt.t = fun wrapper -> let channel = wrapper.channel in if channel.main != wrapper then Lwt.fail (Failure "Lwt_io.close: cannot close a channel obtained via Lwt_io.atomic") else match channel.mode with | Input -> (* Just close it now: *) abort wrapper | Output -> Lwt.catch (fun () -> (* Performs all pending actions, flush the buffer, then close it: *) primitive (fun channel -> safe_flush_total channel >>= fun () -> abort wrapper) wrapper) (fun _ -> abort wrapper) let is_closed wrapper = match wrapper.state with | Closed -> true | Busy_primitive | Busy_atomic _ | Waiting_for_busy | Idle | Invalid -> false let flush_all () = let wrappers = Outputs.fold (fun x l -> x :: l) outputs [] in Lwt_list.iter_p (fun wrapper -> Lwt.catch (fun () -> primitive safe_flush_total wrapper) (fun _ -> Lwt.return_unit)) wrappers let () = (* Flush all opened output channels on exit: *) Lwt_main.at_exit flush_all let no_seek _pos _cmd = Lwt.fail (Failure "Lwt_io.seek: seek not supported on this channel") let make : type m. ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> mode : m mode -> (Lwt_bytes.t -> int -> int -> int Lwt.t) -> m channel = fun ?buffer ?(close=Lwt.return) ?(seek=no_seek) ~mode perform_io -> let (buffer, size) = match buffer with | Some buffer -> check_buffer "Lwt_io.make" buffer; (buffer, Lwt_bytes.length buffer) | None -> let size = !default_buffer_size in (Lwt_bytes.create size, size) in let abort_waiter, abort_wakener = Lwt.wait () in let rec ch = { buffer = buffer; length = size; ptr = 0; max = (match mode with | Input -> 0 | Output -> size); close = lazy(Lwt.catch close Lwt.reraise); abort_waiter = abort_waiter; abort_wakener = abort_wakener; main = wrapper; auto_flushing = false; mode = mode; offset = 0L; typ = Type_normal ( perform_io, fun pos cmd -> try seek pos cmd with e when Lwt.Exception_filter.run e -> Lwt.reraise e ); } and wrapper = { state = Idle; channel = ch; queued = Lwt_sequence.create (); } in (match mode with | Input -> () | Output -> Outputs.add outputs wrapper); wrapper let of_bytes (type m) ~(mode : m mode) bytes = let length = Lwt_bytes.length bytes in let abort_waiter, abort_wakener = Lwt.wait () in let rec ch = { buffer = bytes; length = length; ptr = 0; max = length; close = lazy(Lwt.return_unit); abort_waiter = abort_waiter; abort_wakener = abort_wakener; main = wrapper; (* Auto flush is set to [true] to prevent writing functions from trying to launch the auto-fllushed. *) auto_flushing = true; mode = mode; offset = (match mode with | Output -> 0L | Input -> Int64.of_int length); typ = Type_bytes; } and wrapper = { state = Idle; channel = ch; queued = Lwt_sequence.create (); } in wrapper let of_fd : type m. ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mode : m mode -> Lwt_unix.file_descr -> m channel = fun ?buffer ?close ~mode fd -> let perform_io = match mode with | Input -> Lwt_bytes.read fd | Output -> Lwt_bytes.write fd in make ?buffer ~close:(match close with | Some f -> f | None -> (fun () -> Lwt_unix.close fd)) ~seek:(fun pos cmd -> Lwt_unix.LargeFile.lseek fd pos cmd) ~mode perform_io let of_unix_fd : type m. ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mode : m mode -> Unix.file_descr -> m channel = fun ?buffer ?close ~mode fd -> of_fd ?buffer ?close ~mode (Lwt_unix.of_unix_file_descr fd) let buffered : type m. m channel -> int = fun ch -> match ch.channel.mode with | Input -> ch.channel.max - ch.channel.ptr | Output -> ch.channel.ptr let buffer_size ch = ch.channel.length let resize_buffer : type m. m channel -> int -> unit Lwt.t = fun wrapper len -> if len < min_buffer_size then invalid_arg "Lwt_io.resize_buffer: buffer size too small"; match wrapper.channel.typ with | Type_bytes -> Lwt.fail (Failure ("Lwt_io.resize_buffer: cannot resize the buffer of a channel " ^ "created with Lwt_io.of_string")) | Type_normal _ -> let f : type m. m _channel -> unit Lwt.t = fun ch -> match ch.mode with | Input -> let unread_count = ch.max - ch.ptr in (* Fail if we want to decrease the buffer size and there is too much unread data in the buffer: *) if len < unread_count then Lwt.fail (Failure ("Lwt_io.resize_buffer: cannot decrease buffer size, too much " ^ "unread data")) else begin let buffer = Lwt_bytes.create len in Lwt_bytes.unsafe_blit ch.buffer ch.ptr buffer 0 unread_count; ch.buffer <- buffer; ch.length <- len; ch.ptr <- 0; ch.max <- unread_count; Lwt.return_unit end | Output -> (* If we decrease the buffer size, flush the buffer until the number of buffered bytes fits into the new buffer: *) let rec loop () = if ch.ptr > len then flush_partial ch >>= fun _ -> loop () else Lwt.return_unit in loop () >>= fun () -> let buffer = Lwt_bytes.create len in Lwt_bytes.unsafe_blit ch.buffer 0 buffer 0 ch.ptr; ch.buffer <- buffer; ch.length <- len; ch.max <- len; Lwt.return_unit in primitive f wrapper module Primitives = struct (* This module contains all primitives operations. The operates without protection regarding locking, they are wrapped after into safe operations. *) (* +---------------------------------------------------------------+ | Reading | +---------------------------------------------------------------+ *) let rec read_char ic = let ptr = ic.ptr in if ptr = ic.max then refill ic >>= function | 0 -> raise End_of_file | _ -> read_char ic else begin ic.ptr <- ptr + 1; Lwt.return (Lwt_bytes.unsafe_get ic.buffer ptr) end let read_char_opt ic = Lwt.catch (fun () -> read_char ic >|= fun ch -> Some ch) (function | End_of_file -> Lwt.return_none | exn -> Lwt.reraise exn) let read_line ic = let buf = Buffer.create 128 in let rec loop cr_read = Lwt.try_bind (fun _ -> read_char ic) (function | '\n' -> Lwt.return(Buffer.contents buf) | '\r' -> if cr_read then Buffer.add_char buf '\r'; loop true | ch -> if cr_read then Buffer.add_char buf '\r'; Buffer.add_char buf ch; loop false) (function | End_of_file -> if cr_read then Buffer.add_char buf '\r'; Lwt.return(Buffer.contents buf) | exn -> Lwt.reraise exn) in read_char ic >>= function | '\r' -> loop true | '\n' -> Lwt.return "" | ch -> Buffer.add_char buf ch; loop false let read_line_opt ic = Lwt.catch (fun () -> read_line ic >|= fun ch -> Some ch) (function | End_of_file -> Lwt.return_none | exn -> Lwt.reraise exn) let unsafe_read_into' ic blit buf ofs len = let avail = ic.max - ic.ptr in if avail > 0 then begin let len = min len avail in blit ic.buffer ic.ptr buf ofs len; ic.ptr <- ic.ptr + len; Lwt.return len end else begin refill ic >>= fun n -> let len = min len n in blit ic.buffer 0 buf ofs len; ic.ptr <- len; ic.max <- n; Lwt.return len end let unsafe_read_into_bigstring ic buf ofs len = unsafe_read_into' ic Lwt_bytes.unsafe_blit buf ofs len let unsafe_read_into ic buf ofs len = unsafe_read_into' ic Lwt_bytes.unsafe_blit_to_bytes buf ofs len let read_into_bigstring ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Lwt_bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.read_into_bigstring") else begin if len = 0 then Lwt.return 0 else unsafe_read_into_bigstring ic buf ofs len end let read_into ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.read_into") else begin if len = 0 then Lwt.return 0 else unsafe_read_into ic buf ofs len end let unsafe_read_into_exactly' read_into ic buf ofs len = let rec loop ic buf ofs len = read_into ic buf ofs len >>= function | 0 -> raise End_of_file | n -> let len = len - n in if len = 0 then Lwt.return_unit else loop ic buf (ofs + n) len in loop ic buf ofs len let unsafe_read_into_exactly_bigstring ic buf ofs len = unsafe_read_into_exactly' unsafe_read_into_bigstring ic buf ofs len let unsafe_read_into_exactly ic buf ofs len = unsafe_read_into_exactly' unsafe_read_into ic buf ofs len let read_into_exactly_bigstring ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Lwt_bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.read_into_exactly_bigstring") else begin if len = 0 then Lwt.return_unit else unsafe_read_into_exactly_bigstring ic buf ofs len end let read_into_exactly ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.read_into_exactly") else begin if len = 0 then Lwt.return_unit else unsafe_read_into_exactly ic buf ofs len end let rev_concat len l = let buf = Bytes.create len in let _ = List.fold_left (fun ofs str -> let len = String.length str in let ofs = ofs - len in String.unsafe_blit str 0 buf ofs len; ofs) len l in buf let rec read_all ic total_len acc = let len = ic.max - ic.ptr in let buf = Bytes.create len in Lwt_bytes.unsafe_blit_to_bytes ic.buffer ic.ptr buf 0 len; let str = Bytes.unsafe_to_string buf in ic.ptr <- ic.max; refill ic >>= function | 0 -> Lwt.return (rev_concat (len + total_len) (str :: acc)) | _ -> read_all ic (len + total_len) (str :: acc) let read count ic = match count with | None -> read_all ic 0 [] >|= Bytes.unsafe_to_string | Some len -> let buf = Bytes.create len in unsafe_read_into ic buf 0 len >>= fun real_len -> if real_len < len then Lwt.return Bytes.(sub buf 0 real_len |> unsafe_to_string) else Lwt.return (Bytes.unsafe_to_string buf) let read_value ic = let header = Bytes.create Marshal.header_size in unsafe_read_into_exactly ic header 0 Marshal.header_size >>= fun () -> let bsize = Marshal.data_size header 0 in let buffer = Bytes.create (Marshal.header_size + bsize) in Bytes.unsafe_blit header 0 buffer 0 Marshal.header_size; unsafe_read_into_exactly ic buffer Marshal.header_size bsize >>= fun () -> Lwt.return (Marshal.from_bytes buffer 0) (* +---------------------------------------------------------------+ | Writing | +---------------------------------------------------------------+ *) let flush = flush_total let rec write_char oc ch = let ptr = oc.ptr in if ptr < oc.length then begin oc.ptr <- ptr + 1; Lwt_bytes.unsafe_set oc.buffer ptr ch; Lwt.return_unit end else flush_partial oc >>= fun _ -> write_char oc ch let rec unsafe_write_from' blit oc str ofs len = let avail = oc.length - oc.ptr in if avail >= len then begin blit str ofs oc.buffer oc.ptr len; oc.ptr <- oc.ptr + len; Lwt.return 0 end else begin blit str ofs oc.buffer oc.ptr avail; oc.ptr <- oc.length; flush_partial oc >>= fun _ -> let len = len - avail in if oc.ptr = 0 then begin if len = 0 then Lwt.return 0 else (* Everything has been written, try to write more: *) unsafe_write_from' blit oc str (ofs + avail) len end else (* Not everything has been written, just what is remaining: *) Lwt.return len end let unsafe_write_from_bigstring oc bytes ofs len = unsafe_write_from' Lwt_bytes.blit oc bytes ofs len let unsafe_write_from oc str ofs len = unsafe_write_from' Lwt_bytes.unsafe_blit_from_bytes oc str ofs len let write_from_bigstring oc bytes ofs len = if ofs < 0 || len < 0 || ofs + len > Lwt_bytes.length bytes then Lwt.fail (Invalid_argument "Lwt_io.write_from_bigstring") else begin if len = 0 then Lwt.return 0 else unsafe_write_from_bigstring oc bytes ofs len >>= fun remaining -> Lwt.return (len - remaining) end let write_from oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.write_from") else begin if len = 0 then Lwt.return 0 else unsafe_write_from oc buf ofs len >>= fun remaining -> Lwt.return (len - remaining) end let write_from_string oc buf ofs len = let buf = Bytes.unsafe_of_string buf in write_from oc buf ofs len let unsafe_write_from_exactly' write_from oc buf ofs len = let rec loop oc buf ofs len = write_from oc buf ofs len >>= function | 0 -> Lwt.return_unit | n -> loop oc buf (ofs + len - n) n in loop oc buf ofs len let unsafe_write_from_exactly oc buf ofs len = unsafe_write_from_exactly' unsafe_write_from oc buf ofs len let unsafe_write_from_exactly_bigstring oc buf ofs len = unsafe_write_from_exactly' unsafe_write_from_bigstring oc buf ofs len let write_from_exactly oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.write_from_exactly") else begin if len = 0 then Lwt.return_unit else unsafe_write_from_exactly oc buf ofs len end let write_from_exactly_bigstring oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Lwt_bytes.length buf then Lwt.fail (Invalid_argument "Lwt_io.write_from_exactly_bigstring") else begin if len = 0 then Lwt.return_unit else unsafe_write_from_exactly_bigstring oc buf ofs len end let write_from_string_exactly oc buf ofs len = let buf = Bytes.unsafe_of_string buf in write_from_exactly oc buf ofs len let write oc str = let buf = Bytes.unsafe_of_string str in unsafe_write_from_exactly oc buf 0 (Bytes.length buf) let write_line oc str = let buf = Bytes.unsafe_of_string str in unsafe_write_from_exactly oc buf 0 (Bytes.length buf) >>= fun () -> write_char oc '\n' let write_value oc ?(flags=[]) x = write oc (Marshal.to_string x flags) (* +---------------------------------------------------------------+ | Low-level access | +---------------------------------------------------------------+ *) let rec read_block_unsafe ic size f = if ic.max - ic.ptr < size then refill ic >>= function | 0 -> raise End_of_file | _ -> read_block_unsafe ic size f else begin let ptr = ic.ptr in ic.ptr <- ptr + size; f ic.buffer ptr end let rec write_block_unsafe oc size f = if oc.max - oc.ptr < size then flush_partial oc >>= fun _ -> write_block_unsafe oc size f else begin let ptr = oc.ptr in oc.ptr <- ptr + size; f oc.buffer ptr end let block : type m. m _channel -> int -> (Lwt_bytes.t -> int -> 'a Lwt.t) -> 'a Lwt.t = fun ch size f -> if size < 0 || size > min_buffer_size then Lwt.fail (Invalid_argument "Lwt_io.block") else if ch.max - ch.ptr >= size then begin let ptr = ch.ptr in ch.ptr <- ptr + size; f ch.buffer ptr end else match ch.mode with | Input -> read_block_unsafe ch size f | Output -> write_block_unsafe ch size f let perform token da ch = if !token then begin if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then Lwt.fail (Invalid_argument "Lwt_io.direct_access.da_perform") else begin ch.ptr <- da.da_ptr; perform_io ch >>= fun count -> da.da_ptr <- ch.ptr; da.da_max <- ch.max; Lwt.return count end end else Lwt.fail (Failure ("Lwt_io.perform: this function can not be called outside " ^ "Lwt_io.direct_access")) let direct_access ch f = let token = ref true in let rec da = { da_ptr = ch.ptr; da_max = ch.max; da_buffer = ch.buffer; da_perform = (fun _ -> perform token da ch); } in f da >>= fun x -> token := false; if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then Lwt.fail (Failure "Lwt_io.direct_access: invalid result of [f]") else begin ch.ptr <- da.da_ptr; Lwt.return x end module MakeNumberIO (Endian : EndianBigstring.EndianBigstringSig) = struct (* +-------------------------------------------------------------+ | Reading numbers | +-------------------------------------------------------------+ *) let read_int ic = read_block_unsafe ic 4 (fun buffer ptr -> Lwt.return (Int32.to_int (Endian.get_int32 buffer ptr))) let read_int16 ic = read_block_unsafe ic 2 (fun buffer ptr -> Lwt.return (Endian.get_int16 buffer ptr)) let read_int32 ic = read_block_unsafe ic 4 (fun buffer ptr -> Lwt.return (Endian.get_int32 buffer ptr)) let read_int64 ic = read_block_unsafe ic 8 (fun buffer ptr -> Lwt.return (Endian.get_int64 buffer ptr)) let read_float32 ic = read_int32 ic >>= fun x -> Lwt.return (Int32.float_of_bits x) let read_float64 ic = read_int64 ic >>= fun x -> Lwt.return (Int64.float_of_bits x) (* +-------------------------------------------------------------+ | Writing numbers | +-------------------------------------------------------------+ *) let write_int oc v = write_block_unsafe oc 4 (fun buffer ptr -> Endian.set_int32 buffer ptr (Int32.of_int v); Lwt.return_unit) let write_int16 oc v = write_block_unsafe oc 2 (fun buffer ptr -> Endian.set_int16 buffer ptr v; Lwt.return_unit) let write_int32 oc v = write_block_unsafe oc 4 (fun buffer ptr -> Endian.set_int32 buffer ptr v; Lwt.return_unit) let write_int64 oc v = write_block_unsafe oc 8 (fun buffer ptr -> Endian.set_int64 buffer ptr v; Lwt.return_unit) let write_float32 oc v = write_int32 oc (Int32.bits_of_float v) let write_float64 oc v = write_int64 oc (Int64.bits_of_float v) end (* +---------------------------------------------------------------+ | Random access | +---------------------------------------------------------------+ *) let do_seek fun_name seek pos = seek pos Unix.SEEK_SET >>= fun offset -> if offset <> pos then Lwt.fail (Failure (Printf.sprintf "Lwt_io.%s: seek failed" fun_name)) else Lwt.return_unit let set_position : type m. m _channel -> int64 -> unit Lwt.t = fun ch pos -> match ch.typ, ch.mode with | Type_normal(_, seek), Output -> flush_total ch >>= fun () -> do_seek "set_position" seek pos >>= fun () -> ch.offset <- pos; Lwt.return_unit | Type_normal(_, seek), Input -> let current = Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) in if pos >= current && pos <= ch.offset then begin ch.ptr <- ch.max - (Int64.to_int (Int64.sub ch.offset pos)); Lwt.return_unit end else begin do_seek "set_position" seek pos >>= fun () -> ch.offset <- pos; ch.ptr <- 0; ch.max <- 0; Lwt.return_unit end | Type_bytes, _ -> if pos < 0L || pos > Int64.of_int ch.length then Lwt.fail (Failure "Lwt_io.set_position: out of bounds") else begin ch.ptr <- Int64.to_int pos; Lwt.return_unit end let length ch = match ch.typ with | Type_normal(_, seek) -> seek 0L Unix.SEEK_END >>= fun len -> do_seek "length" seek ch.offset >>= fun () -> Lwt.return len | Type_bytes -> Lwt.return (Int64.of_int ch.length) end (* +-----------------------------------------------------------------+ | Primitive operations | +-----------------------------------------------------------------+ *) let read_char wrapper = let channel = wrapper.channel in let ptr = channel.ptr in (* Speed-up in case a character is available in the buffer. It increases performances by 10x. *) if wrapper.state = Idle && ptr < channel.max then begin channel.ptr <- ptr + 1; Lwt.return (Lwt_bytes.unsafe_get channel.buffer ptr) end else primitive Primitives.read_char wrapper let read_char_opt wrapper = let channel = wrapper.channel in let ptr = channel.ptr in if wrapper.state = Idle && ptr < channel.max then begin channel.ptr <- ptr + 1; Lwt.return (Some(Lwt_bytes.unsafe_get channel.buffer ptr)) end else primitive Primitives.read_char_opt wrapper let read_line ic = primitive Primitives.read_line ic let read_line_opt ic = primitive Primitives.read_line_opt ic let read ?count ic = primitive (fun ic -> Primitives.read count ic) ic let read_into ic str ofs len = primitive (fun ic -> Primitives.read_into ic str ofs len) ic let read_into_exactly ic str ofs len = primitive (fun ic -> Primitives.read_into_exactly ic str ofs len) ic let read_into_bigstring ic bytes ofs len = primitive (fun ic -> Primitives.read_into_bigstring ic bytes ofs len) ic let read_into_exactly_bigstring ic bytes ofs len = primitive (fun ic -> Primitives.read_into_exactly_bigstring ic bytes ofs len) ic let read_value ic = primitive Primitives.read_value ic let flush oc = primitive Primitives.flush oc let write_char wrapper x = let channel = wrapper.channel in let ptr = channel.ptr in if wrapper.state = Idle && ptr < channel.max then begin channel.ptr <- ptr + 1; Lwt_bytes.unsafe_set channel.buffer ptr x; (* Fast launching of the auto flusher: *) if not channel.auto_flushing then begin channel.auto_flushing <- true; ignore (auto_flush channel); Lwt.return_unit end else Lwt.return_unit end else primitive (fun oc -> Primitives.write_char oc x) wrapper let write oc str = primitive (fun oc -> Primitives.write oc str) oc let write_line oc x = primitive (fun oc -> Primitives.write_line oc x) oc let write_from oc str ofs len = primitive (fun oc -> Primitives.write_from oc str ofs len) oc let write_from_bigstring oc bytes ofs len = primitive (fun oc -> Primitives.write_from_bigstring oc bytes ofs len) oc let write_from_string oc str ofs len = primitive (fun oc -> Primitives.write_from_string oc str ofs len) oc let write_from_exactly oc str ofs len = primitive (fun oc -> Primitives.write_from_exactly oc str ofs len) oc let write_from_exactly_bigstring oc bytes ofs len = primitive (fun oc -> Primitives.write_from_exactly_bigstring oc bytes ofs len) oc let write_from_string_exactly oc str ofs len = primitive (fun oc -> Primitives.write_from_string_exactly oc str ofs len) oc let write_value oc ?flags x = primitive (fun oc -> Primitives.write_value oc ?flags x) oc let block ch size f = primitive (fun ch -> Primitives.block ch size f) ch let direct_access ch f = primitive (fun ch -> Primitives.direct_access ch f) ch let set_position ch pos = primitive (fun ch -> Primitives.set_position ch pos) ch let length ch = primitive Primitives.length ch module type NumberIO = sig val read_int : input_channel -> int Lwt.t val read_int16 : input_channel -> int Lwt.t val read_int32 : input_channel -> int32 Lwt.t val read_int64 : input_channel -> int64 Lwt.t val read_float32 : input_channel -> float Lwt.t val read_float64 : input_channel -> float Lwt.t val write_int : output_channel -> int -> unit Lwt.t val write_int16 : output_channel -> int -> unit Lwt.t val write_int32 : output_channel -> int32 -> unit Lwt.t val write_int64 : output_channel -> int64 -> unit Lwt.t val write_float32 : output_channel -> float -> unit Lwt.t val write_float64 : output_channel -> float -> unit Lwt.t end module MakeNumberIO (Endian : EndianBigstring.EndianBigstringSig) = struct module Primitives = Primitives.MakeNumberIO (Endian) let read_int ic = primitive Primitives.read_int ic let read_int16 ic = primitive Primitives.read_int16 ic let read_int32 ic = primitive Primitives.read_int32 ic let read_int64 ic = primitive Primitives.read_int64 ic let read_float32 ic = primitive Primitives.read_float32 ic let read_float64 ic = primitive Primitives.read_float64 ic let write_int oc x = primitive (fun oc -> Primitives.write_int oc x) oc let write_int16 oc x = primitive (fun oc -> Primitives.write_int16 oc x) oc let write_int32 oc x = primitive (fun oc -> Primitives.write_int32 oc x) oc let write_int64 oc x = primitive (fun oc -> Primitives.write_int64 oc x) oc let write_float32 oc x = primitive (fun oc -> Primitives.write_float32 oc x) oc let write_float64 oc x = primitive (fun oc -> Primitives.write_float64 oc x) oc end module LE = MakeNumberIO (EndianBigstring.LittleEndian_unsafe) module BE = MakeNumberIO (EndianBigstring.BigEndian_unsafe) type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian let system_byte_order = Lwt_sys.byte_order include (val (match system_byte_order with | Little_endian -> (module LE : NumberIO) | Big_endian -> (module BE : NumberIO)) : NumberIO) (* +-----------------------------------------------------------------+ | Other | +-----------------------------------------------------------------+ *) let read_chars ic = Lwt_stream.from (fun _ -> read_char_opt ic) let write_chars oc chars = Lwt_stream.iter_s (fun char -> write_char oc char) chars let read_lines ic = Lwt_stream.from (fun _ -> read_line_opt ic) let write_lines oc lines = Lwt_stream.iter_s (fun line -> write_line oc line) lines let zero = make ~mode:input ~buffer:(Lwt_bytes.create min_buffer_size) (fun str ofs len -> Lwt_bytes.fill str ofs len '\x00'; Lwt.return len) let null = make ~mode:output ~buffer:(Lwt_bytes.create min_buffer_size) (fun _str _ofs len -> Lwt.return len) (* Do not close standard ios on close, otherwise uncaught exceptions will not be printed *) let stdin = of_fd ~mode:input Lwt_unix.stdin let stdout = of_fd ~mode:output Lwt_unix.stdout let stderr = of_fd ~mode:output Lwt_unix.stderr let fprint oc txt = write oc txt let fprintl oc txt = write_line oc txt let fprintf oc fmt = Printf.ksprintf (fun txt -> write oc txt) fmt let fprintlf oc fmt = Printf.ksprintf (fun txt -> write_line oc txt) fmt let print txt = write stdout txt let printl txt = write_line stdout txt let printf fmt = Printf.ksprintf print fmt let printlf fmt = Printf.ksprintf printl fmt let eprint txt = write stderr txt let eprintl txt = write_line stderr txt let eprintf fmt = Printf.ksprintf eprint fmt let eprintlf fmt = Printf.ksprintf eprintl fmt let pipe ?cloexec ?in_buffer ?out_buffer _ = let fd_r, fd_w = Lwt_unix.pipe ?cloexec () in (of_fd ?buffer:in_buffer ~mode:input fd_r, of_fd ?buffer:out_buffer ~mode:output fd_w) type file_name = string let open_file : type m. ?buffer : Lwt_bytes.t -> ?flags : Unix.open_flag list -> ?perm : Unix.file_perm -> mode : m mode -> file_name -> m channel Lwt.t = fun ?buffer ?flags ?perm ~mode filename -> let flags = match flags, mode with | Some l, _ -> l | None, Input -> [Unix.O_RDONLY; Unix.O_NONBLOCK] | None, Output -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] and perm = match perm, mode with | Some p, _ -> p | None, Input -> 0 | None, Output -> 0o666 in Lwt_unix.openfile filename flags perm >>= fun fd -> Lwt.return (of_fd ?buffer ~mode fd) let with_file ?buffer ?flags ?perm ~mode filename f = open_file ?buffer ?flags ?perm ~mode filename >>= fun ic -> Lwt.finalize (fun () -> f ic) (fun () -> close ic) let prng = lazy (Random.State.make_self_init ()) let temp_file_name temp_dir prefix suffix = let rnd = Random.State.int (Lazy.force prng) 0x1000000 in Filename.concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix) let open_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?(suffix = "") () = let flags = match flags with | None -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL; Unix.O_CLOEXEC] | Some flags -> flags in let dir = match temp_dir with | None -> Filename.get_temp_dir_name () | Some dirname -> dirname in let prefix = match prefix with | None -> "lwt_io_temp_file_" | Some prefix -> prefix in let rec attempt n = let fname = temp_file_name dir prefix suffix in Lwt.catch (fun () -> open_file ?buffer ~flags ?perm ~mode:Output fname >>= fun chan -> Lwt.return (fname, chan)) (function | Unix.Unix_error _ when n < 1000 -> attempt (n + 1) | exn -> Lwt.reraise exn) in attempt 0 let with_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?suffix f = open_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?suffix () >>= fun (fname, chan) -> Lwt.finalize (fun () -> f (fname, chan)) (fun () -> close chan >>= fun () -> Lwt_unix.unlink fname) let create_temp_dir ?(perm = 0o755) ?(parent = Filename.get_temp_dir_name ()) ?(prefix = "lwt_io_temp_dir_") ?(suffix = "") () = let rec attempt n = let name = temp_file_name parent prefix suffix in Lwt.catch (fun () -> Lwt_unix.mkdir name perm >>= fun () -> Lwt.return name) (function | Unix.Unix_error (Unix.EEXIST, _, _) when n < 1000 -> attempt (n + 1) | exn -> Lwt.reraise exn) in attempt 0 let win32_unlink fn = Lwt.catch (fun () -> Lwt_unix.unlink fn) (function | Unix.Unix_error (Unix.EACCES, _, _) as exn -> (* Try removing the read-only attribute before retrying unlink. We catch any exception here and ignore it in favour of the original [exn]. *) Lwt.catch (fun () -> Lwt_unix.lstat fn >>= fun {st_perm; _} -> Lwt_unix.chmod fn 0o666 >>= fun () -> Lwt.catch (fun () -> Lwt_unix.unlink fn) (function _ -> (* If everything succeeded but the final removal still failed, restore original permissions *) Lwt_unix.chmod fn st_perm >>= fun () -> Lwt.reraise exn) ) (fun _ -> Lwt.reraise exn) | exn -> Lwt.reraise exn) let unlink = if Sys.win32 then win32_unlink else Lwt_unix.unlink (* This is likely VERY slow for directories with many files. That is probably best addressed by switching to blocking calls run inside a worker thread, i.e. with Lwt_preemptive. *) let rec delete_recursively directory = Lwt_unix.files_of_directory directory |> Lwt_stream.iter_s begin fun entry -> if entry = Filename.current_dir_name || entry = Filename.parent_dir_name then Lwt.return_unit else let path = Filename.concat directory entry in Lwt_unix.lstat path >>= fun {Lwt_unix.st_kind; _} -> match st_kind with | S_DIR -> delete_recursively path | S_LNK when (Sys.win32 || Sys.cygwin) -> Lwt_unix.stat path >>= fun {Lwt_unix.st_kind; _} -> begin match st_kind with | S_DIR -> Lwt_unix.rmdir path | _ -> unlink path end | _ -> unlink path end >>= fun () -> Lwt_unix.rmdir directory let with_temp_dir ?perm ?parent ?prefix ?suffix f = create_temp_dir ?perm ?parent ?prefix ?suffix () >>= fun name -> Lwt.finalize (fun () -> f name) (fun () -> delete_recursively name) let file_length filename = Lwt_unix.stat filename >>= fun stat -> if stat.Unix.st_kind = Unix.S_DIR then Lwt.fail (Unix.(Unix_error (EISDIR, "file_length", filename))) else with_file ~mode:input filename length let close_socket fd = Lwt.finalize (fun () -> Lwt.catch (fun () -> Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; Lwt.return_unit) (function (* Occurs if the peer closes the connection first. *) | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit | exn -> Lwt.reraise exn) [@ocaml.warning "-4"]) (fun () -> Lwt_unix.close fd) let open_connection ?fd ?in_buffer ?out_buffer sockaddr = let fd = match fd with | None -> Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 | Some fd -> fd in let close = lazy (close_socket fd) in Lwt.catch (fun () -> Lwt_unix.connect fd sockaddr >>= fun () -> (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); Lwt.return (make ?buffer:in_buffer ~close:(fun _ -> Lazy.force close) ~mode:input (Lwt_bytes.read fd), make ?buffer:out_buffer ~close:(fun _ -> Lazy.force close) ~mode:output (Lwt_bytes.write fd))) (fun exn -> Lwt_unix.close fd >>= fun () -> Lwt.reraise exn) let with_close_connection f (ic, oc) = (* If the user already tried to close the socket and got an exception, we don't want to raise that exception again during implicit close. *) let close_if_not_closed channel = if is_closed channel then Lwt.return_unit else close channel in Lwt.finalize (fun () -> f (ic, oc)) (fun () -> close_if_not_closed ic <&> close_if_not_closed oc) let with_connection ?fd ?in_buffer ?out_buffer sockaddr f = open_connection ?fd ?in_buffer ?out_buffer sockaddr >>= fun channels -> with_close_connection f channels type server = { shutdown : unit Lwt.t Lazy.t; } let shutdown_server server = Lazy.force server.shutdown let shutdown_server_deprecated server = Lwt.async (fun () -> shutdown_server server) (* There are several variants of establish_server that have accumulated over the years in Lwt_io. This is their underlying implementation. The functions exposed in the API are various wrappers around this one. *) let establish_server_generic bind_function ?fd:preexisting_socket_for_listening ?(backlog = Lwt_unix.somaxconn () [@ocaml.warning "-3"]) listening_address connection_handler_callback = let listening_socket = match preexisting_socket_for_listening with | None -> Lwt_unix.socket (Unix.domain_of_sockaddr listening_address) Unix.SOCK_STREAM 0 | Some socket -> socket in Lwt_unix.setsockopt listening_socket Unix.SO_REUSEADDR true; (* This promise gets resolved with `Should_stop when the user calls Lwt_io.shutdown_server. This begins the shutdown procedure. *) let should_stop, notify_should_stop = Lwt.wait () in (* Some time after Lwt_io.shutdown_server is called, this function establish_server_generic will actually close the listening socket. At that point, this promise is resolved. This ends the shutdown procedure. *) let wait_until_listening_socket_closed, notify_listening_socket_closed = Lwt.wait () in let rec accept_loop () = let try_to_accept = Lwt.catch (fun () -> Lwt_unix.accept listening_socket >|= fun x -> `Accepted x) (function | Unix.Unix_error (Unix.ECONNABORTED, _, _) -> Lwt.return `Try_again | e -> Lwt.reraise e) in Lwt.pick [try_to_accept; should_stop] >>= function | `Accepted (client_socket, client_address) -> begin try Lwt_unix.set_close_on_exec client_socket with Invalid_argument _ -> () end; connection_handler_callback client_address client_socket; accept_loop () | `Should_stop -> Lwt_unix.close listening_socket >>= fun () -> begin match listening_address with | Unix.ADDR_UNIX path when path <> "" && path.[0] <> '\x00' -> Unix.unlink path | _ -> () end [@ocaml.warning "-4"]; Lwt.wakeup_later notify_listening_socket_closed (); Lwt.return_unit | `Try_again -> accept_loop () in let server = {shutdown = lazy begin Lwt.wakeup_later notify_should_stop `Should_stop; wait_until_listening_socket_closed end} in (* Actually start the server. *) let server_has_started = bind_function listening_socket listening_address >>= fun () -> Lwt_unix.listen listening_socket backlog; Lwt.async accept_loop; Lwt.return_unit in server, server_has_started let establish_server_with_client_socket ?server_fd ?backlog ?(no_close = false) sockaddr f = let handler client_address client_socket = Lwt.async begin fun () -> (* Not using Lwt.finalize here, to make sure that exceptions from [f] reach !Lwt.async_exception_hook before exceptions from closing the channels. *) Lwt.catch (fun () -> f client_address client_socket) (fun exn -> !Lwt.async_exception_hook exn; Lwt.return_unit) >>= fun () -> if no_close then Lwt.return_unit else if Lwt_unix.state client_socket = Lwt_unix.Closed then Lwt.return_unit else Lwt.catch (fun () -> close_socket client_socket) (fun exn -> !Lwt.async_exception_hook exn; Lwt.return_unit) end in let server, server_started = establish_server_generic Lwt_unix.bind ?fd:server_fd ?backlog sockaddr handler in server_started >>= fun () -> Lwt.return server let establish_server_with_client_address_generic bind_function ?fd ?(buffer_size = !default_buffer_size) ?backlog ?(no_close = false) sockaddr handler = let best_effort_close channel = (* First, check whether the channel is closed. f may have already tried to close the channel, received an exception, and handled it somehow. If so, trying to close the channel here will trigger the same exception, which will go to !Lwt.async_exception_hook, despite the user's efforts. *) (* The Invalid state is not possible on the channel, because it was not created using Lwt_io.atomic. *) if is_closed channel then Lwt.return_unit else Lwt.catch (fun () -> close channel) (fun exn -> !Lwt.async_exception_hook exn; Lwt.return_unit) in let handler client_address client_socket = Lwt.async (fun () -> let close = lazy (close_socket client_socket) in let input_channel = of_fd ~buffer:(Lwt_bytes.create buffer_size) ~mode:input ~close:(fun () -> Lazy.force close) client_socket in let output_channel = of_fd ~buffer:(Lwt_bytes.create buffer_size) ~mode:output ~close:(fun () -> Lazy.force close) client_socket in (* Not using Lwt.finalize here, to make sure that exceptions from [f] reach !Lwt.async_exception_hook before exceptions from closing the channels. *) Lwt.catch (fun () -> handler client_address (input_channel, output_channel)) (fun exn -> !Lwt.async_exception_hook exn; Lwt.return_unit) >>= fun () -> if no_close then Lwt.return_unit else best_effort_close input_channel >>= fun () -> best_effort_close output_channel) in establish_server_generic bind_function ?fd ?backlog sockaddr handler let establish_server_with_client_address ?fd ?buffer_size ?backlog ?no_close sockaddr handler = let server, server_started = establish_server_with_client_address_generic Lwt_unix.bind ?fd ?buffer_size ?backlog ?no_close sockaddr handler in server_started >>= fun () -> Lwt.return server let establish_server ?fd ?buffer_size ?backlog ?no_close sockaddr f = let f _addr c = f c in establish_server_with_client_address ?fd ?buffer_size ?backlog ?no_close sockaddr f (* Old, deprecated version of [establish_server]. This function has to persist for a while, in some form, until it is no longer exposed as [Lwt_io.Versioned.establish_server_1]. *) let establish_server_deprecated ?fd ?buffer_size ?backlog sockaddr f = let blocking_bind fd addr = Lwt.return (Lwt_unix.Versioned.bind_1 fd addr) [@ocaml.warning "-3"] in let f _addr c = f c; Lwt.return_unit in let server, server_started = establish_server_with_client_address_generic blocking_bind ?fd ?buffer_size ?backlog ~no_close:true sockaddr f in (* Poll for exceptions in server startup that may have occurred synchronously. This emulates an old, deprecated behavior. *) Lwt.ignore_result server_started; server let ignore_close ch = ignore (close ch) let make_stream f lazy_ic = let lazy_ic = lazy(Lazy.force lazy_ic >>= fun ic -> Gc.finalise ignore_close ic; Lwt.return ic) in Lwt_stream.from (fun _ -> Lazy.force lazy_ic >>= fun ic -> f ic >>= fun x -> if x = None then close ic >>= fun () -> Lwt.return x else Lwt.return x) let lines_of_file filename = make_stream read_line_opt (lazy(open_file ~mode:input filename)) let lines_to_file filename lines = with_file ~mode:output filename (fun oc -> write_lines oc lines) let chars_of_file filename = make_stream read_char_opt (lazy(open_file ~mode:input filename)) let chars_to_file filename chars = with_file ~mode:output filename (fun oc -> write_chars oc chars) let hexdump_stream oc stream = write_lines oc (Lwt_stream.hexdump stream) let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf) let set_default_buffer_size size = check_buffer_size "set_default_buffer_size" size; default_buffer_size := size let default_buffer_size _ = !default_buffer_size module Versioned = struct let establish_server_1 = establish_server_deprecated let establish_server_2 = establish_server let shutdown_server_1 = shutdown_server_deprecated let shutdown_server_2 = shutdown_server end lwt-5.9.1/src/unix/lwt_io.mli000066400000000000000000000757341476253734400161450ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Buffered byte channels *) (** A {b channel} is a high-level object for performing input/output (IO). It allows to read/write from/to the outside world in an efficient way, by minimising the number of system calls. An {b output channel} is used to send data and an {b input channel} is used to receive data. If you are familiar with buffered channels you may be familiar too with the {b flush} operation. Note that byte channels of this module are automatically flushed when there is nothing else to do (i.e. before the program becomes idle), so this means that you no longer have to write: {[ eprintf "log message\n"; flush stderr; ]} to have your messages displayed. Note about errors: input functions of this module raise [End_of_file] when the end-of-file is reached (i.e. when the read function returns [0]). Other exceptions are ones caused by the backend read/write functions, such as {!Unix.Unix_error}. *) exception Channel_closed of string (** Exception raised when a channel is closed. The parameter is a description of the channel. *) (** {2 Types} *) type 'mode channel (** Type of buffered byte channels *) type input (** Input mode *) type output (** Output mode *) (** Channel mode *) type 'a mode = | Input : input mode | Output : output mode val input : input mode (** [input] input mode representation *) val output : output mode (** [output] output mode representation *) type input_channel = input channel (** Type of input channels *) type output_channel = output channel (** Type of output channels *) val mode : 'a channel -> 'a mode (** [mode ch] returns the mode of a channel *) (** {2 Well-known instances} *) val stdin : input_channel (** The standard input, it reads data from {!Lwt_unix.stdin} *) val stdout : output_channel (** The standard output, it writes data to {!Lwt_unix.stdout} *) val stderr : output_channel (** The standard output for error messages, it writes data to {!Lwt_unix.stderr} *) val zero : input_channel (** Inputs which returns always ['\x00'] *) val null : output_channel (** Output which drops everything *) (** {2 Channels creation/manipulation} *) val pipe : ?cloexec : bool -> ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> unit -> input_channel * output_channel (** [pipe ?cloexec ?in_buffer ?out_buffer ()] creates a pipe using {!Lwt_unix.pipe} and makes two channels from the two returned file descriptors *) val make : ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> mode : 'mode mode -> (Lwt_bytes.t -> int -> int -> int Lwt.t) -> 'mode channel (** [make ?buffer ?close ~mode perform_io] is the main function for creating new channels. @param buffer user-supplied buffer. When this argument is present, its value will be used as the buffer for the created channel. The size of buffer must conform to the limitations described in {!set_default_buffer_size}. When this argument is not present, a new internal buffer of default size will be allocated for this channel. Warning: do not use the same buffer for simultaneous work with more than one channel. There are other functions in this module that take a [buffer] argument, sharing the same semantics. @param close close function of the channel. It defaults to [Lwt.return] @param seek same meaning as {!Unix.lseek} @param mode either {!input} or {!output} @param perform_io is the read or write function. It is called when more input is needed or when the buffer need to be flushed. *) val of_bytes : mode : 'mode mode -> Lwt_bytes.t -> 'mode channel (** Create a channel from a byte array. Reading/writing is done directly on the provided array. *) val of_fd : ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mode : 'mode mode -> Lwt_unix.file_descr -> 'mode channel (** [of_fd ?buffer ?close ~mode fd] creates a channel from a file descriptor. @param close defaults to closing the file descriptor. *) val of_unix_fd : ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mode : 'mode mode -> Unix.file_descr -> 'mode channel (** [of_unix_fd ?buffer ?close ~mode fd] is a short-hand for: [of_fd ?buffer ?close (Lwt_unix.of_unix_file_descr fd)] *) val close : 'a channel -> unit Lwt.t (** [close ch] closes the given channel. If [ch] is an output channel, it performs all pending actions, flushes it and closes it. If [ch] is an input channel, it just closes it immediately. [close] returns the result of the close function of the channel. Multiple calls to [close] will return exactly the same value. Note: you cannot use [close] on channels obtained with {!atomic}. *) val abort : 'a channel -> unit Lwt.t (** [abort ch] abort current operations and close the channel immediately. *) val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t) (** [atomic f] transforms a sequence of io operations into one single atomic io operation. Note: - the channel passed to [f] is invalid after [f] terminates - [atomic] can be called inside another [atomic] *) val file_length : string -> int64 Lwt.t (** Retrieves the length of the file at the given path. If the path refers to a directory, the returned promise is rejected with [Unix.(Unix_error (EISDIR, _, _))]. *) val buffered : 'a channel -> int (** [buffered oc] returns the number of bytes in the buffer *) val flush : output_channel -> unit Lwt.t (** [flush oc] performs all pending writes on [oc] *) val flush_all : unit -> unit Lwt.t (** [flush_all ()] flushes all open output channels *) val buffer_size : 'a channel -> int (** Returns the size of the internal buffer. *) val resize_buffer : 'a channel -> int -> unit Lwt.t (** Resize the internal buffer to the given size *) val is_busy : 'a channel -> bool (** [is_busy channel] returns whether the given channel is currently busy. A channel is busy when there is at least one job using it that has not yet terminated. *) val is_closed : 'a channel -> bool (** [is_closed channel] returns whether the given channel is currently closed. @since 4.2.0 *) (** {2 Random access} *) val position : 'a channel -> int64 (** [position ch] Returns the current position in the channel. *) val set_position : 'a channel -> int64 -> unit Lwt.t (** [set_position ch pos] Sets the position in the output channel. This does not work if the channel does not support random access. *) val length : 'a channel -> int64 Lwt.t (** Returns the length of the channel in bytes *) (** {2 Reading} *) (** Note: except for functions dealing with streams ({!read_chars} and {!read_lines}) all functions are {b atomic}. *) val read_char : input_channel -> char Lwt.t (** [read_char ic] reads the next character of [ic]. @raise End_of_file if the end of the file is reached *) val read_char_opt : input_channel -> char option Lwt.t (** Same as {!Lwt_io.read_char}, but does not raise [End_of_file] on end of input *) val read_chars : input_channel -> char Lwt_stream.t (** [read_chars ic] returns a stream holding all characters of [ic] *) val read_line : input_channel -> string Lwt.t (** [read_line ic] reads one complete line from [ic] and returns it without the end of line. End of line is either ["\n"] or ["\r\n"]. If the end of input is reached before reading any character, [End_of_file] is raised. If it is reached before reading an end of line but characters have already been read, they are returned. *) val read_line_opt : input_channel -> string option Lwt.t (** Same as {!read_line} but do not raise [End_of_file] on end of input. *) val read_lines : input_channel -> string Lwt_stream.t (** [read_lines ic] returns a stream holding all lines of [ic] *) val read : ?count : int -> input_channel -> string Lwt.t (** If [~count] is specified, [read ~count ic] reads at most [~count] bytes from [ic] in one read operation. Note that fewer than [~count] bytes can be read. This can happen for multiple reasons, including end of input, or no more data currently available. Check the size of the resulting string. [read] resolves with [""] if the input channel is already at the end of input. If [~count] is not specified, [read ic] reads all bytes until the end of input. *) val read_into : input_channel -> bytes -> int -> int -> int Lwt.t (** [read_into ic buffer offset length] reads up to [length] bytes, stores them in [buffer] at offset [offset], and returns the number of bytes read. Note: [read_into] does not raise [End_of_file], it returns a length of [0] instead. *) val read_into_exactly : input_channel -> bytes -> int -> int -> unit Lwt.t (** [read_into_exactly ic buffer offset length] reads exactly [length] bytes and stores them in [buffer] at offset [offset]. @raise End_of_file on end of input *) val read_into_bigstring : input_channel -> Lwt_bytes.t -> int -> int -> int Lwt.t val read_into_exactly_bigstring : input_channel -> Lwt_bytes.t -> int -> int -> unit Lwt.t val read_value : input_channel -> 'a Lwt.t (** [read_value channel] reads a marshaled value from [channel]; it corresponds to the standard library's {!Stdlib.Marshal.from_channel}. The corresponding writing function is {!write_value}. Note that reading marshaled values is {e not}, in general, type-safe. See the warning in the description of module {!Stdlib.Marshal} for details. The short version is: if you read a value of one type, such as [string], when a value of another type, such as [int] has actually been marshaled to [channel], you may get arbitrary behavior, including segmentation faults, access violations, security bugs, etc. *) (** {2 Writing} *) (** Note: as for reading functions, all functions except {!write_chars} and {!write_lines} are {b atomic}. For example if you use {!write_line} in two different threads, the two operations will be serialized, and lines cannot be mixed. *) val write_char : output_channel -> char -> unit Lwt.t (** [write_char oc char] writes [char] on [oc] *) val write_chars : output_channel -> char Lwt_stream.t -> unit Lwt.t (** [write_chars oc chars] writes all characters of [chars] on [oc] *) val write : output_channel -> string -> unit Lwt.t (** [write oc str] writes all characters of [str] on [oc] *) val write_line : output_channel -> string -> unit Lwt.t (** [write_line oc str] writes [str] on [oc] followed by a new-line. *) val write_lines : output_channel -> string Lwt_stream.t -> unit Lwt.t (** [write_lines oc lines] writes all lines of [lines] to [oc] *) val write_from : output_channel -> bytes -> int -> int -> int Lwt.t (** [write_from oc buffer offset length] writes up to [length] bytes to [oc], from [buffer] at offset [offset] and returns the number of bytes actually written *) val write_from_bigstring : output_channel -> Lwt_bytes.t -> int -> int -> int Lwt.t val write_from_string : output_channel -> string -> int -> int -> int Lwt.t (** See {!write}. *) val write_from_exactly : output_channel -> bytes -> int -> int -> unit Lwt.t (** [write_from_exactly oc buffer offset length] writes all [length] bytes from [buffer] at offset [offset] to [oc] *) val write_from_exactly_bigstring : output_channel -> Lwt_bytes.t -> int -> int -> unit Lwt.t val write_from_string_exactly : output_channel -> string -> int -> int -> unit Lwt.t (** See {!write_from_exactly}. *) val write_value : output_channel -> ?flags : Marshal.extern_flags list -> 'a -> unit Lwt.t (** [write_value channel ?flags v] writes [v] to [channel] using the [Marshal] module of the standard library. See {!Stdlib.Marshal.to_channel} for an explanation of [?flags]. The corresponding reading function is {!read_value}. See warnings about type safety in the description of {!read_value}. *) (** {2 Printing} *) (** These functions are basically helpers. Also you may prefer using the name {!printl} rather than {!write_line} because it is shorter. The general name of a printing function is [print], where [] is one of: - ['f'], which means that the function takes as argument a channel - nothing, which means that the function prints on {!stdout} - ['e'], which means that the function prints on {!stderr} and [] is a combination of: - ['l'] which means that a new-line character is printed after the message - ['f'] which means that the function takes as argument a {b format} instead of a string *) val fprint : output_channel -> string -> unit Lwt.t val fprintl : output_channel -> string -> unit Lwt.t val fprintf : output_channel -> ('a, unit, string, unit Lwt.t) format4 -> 'a (** [%!] does nothing here. To flush the channel, use [Lwt_io.flush channel]. *) val fprintlf : output_channel -> ('a, unit, string, unit Lwt.t) format4 -> 'a (** [%!] does nothing here. To flush the channel, use [Lwt_io.flush channel]. *) val print : string -> unit Lwt.t val printl : string -> unit Lwt.t val printf : ('a, unit, string, unit Lwt.t) format4 -> 'a (** [%!] does nothing here. To flush the channel, use [Lwt_io.(flush stdout)]. *) val printlf : ('a, unit, string, unit Lwt.t) format4 -> 'a (** [%!] does nothing here. To flush the channel, use [Lwt_io.(flush stdout)]. *) val eprint : string -> unit Lwt.t val eprintl : string -> unit Lwt.t val eprintf : ('a, unit, string, unit Lwt.t) format4 -> 'a (** [%!] does nothing here. To flush the channel, use [Lwt_io.(flush stderr)]. *) val eprintlf : ('a, unit, string, unit Lwt.t) format4 -> 'a (** [%!] does nothing here. To flush the channel, use [Lwt_io.(flush stderr)]. *) (** {2 Utilities} *) val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t (** [hexdump_stream oc byte_stream] produces the same output as the command [hexdump -C]. *) val hexdump : output_channel -> string -> unit Lwt.t (** [hexdump oc str = hexdump_stream oc (Lwt_stream.of_string str)] *) (** {2 File utilities} *) type file_name = string (** Type of file names *) val open_file : ?buffer:Lwt_bytes.t -> ?flags:Unix.open_flag list -> ?perm:Unix.file_perm -> mode:'a mode -> file_name -> 'a channel Lwt.t (** [Lwt_io.open_file ~mode file] opens the given file, either for reading (with [~mode:Input]) or for writing (with [~mode:Output]). The returned channel provides buffered I/O on the file. If [~buffer] is supplied, it is used as the I/O buffer. If [~flags] is supplied, the file is opened with the given flags (see {!Unix.open_flag}). Note that [~flags] is used {e exactly} as given. For example, opening a file with [~flags] and [~mode:Input] does {e not} implicitly add [O_RDONLY]. So, you should include [O_RDONLY] when opening for reading ([~mode:Input]), and [O_WRONLY] when opening for writing ([~mode:Input]). It is also recommended to include [O_NONBLOCK], unless you are sure that the file cannot be a socket or a named pipe. The default permissions used for creating new files are [0o666], i.e. reading and writing are allowed for the file owner, group, and everyone. These default permissions can be overridden by supplying [~perm]. Note: if opening for writing ([~mode:Output]), and the file already exists, [open_file] truncates (clears) the file by default. If you would like to keep the pre-existing contents of the file, use the [~flags] parameter to pass a custom flags list that does not include {!Unix.O_TRUNC}. @raise Unix.Unix_error on error. *) val with_file : ?buffer:Lwt_bytes.t -> ?flags:Unix.open_flag list -> ?perm:Unix.file_perm -> mode:'a mode -> file_name -> ('a channel -> 'b Lwt.t) -> 'b Lwt.t (** [Lwt_io.with_file ~mode filename f] opens the given using {!Lwt_io.open_file}, and passes the resulting channel to [f]. [Lwt_io.with_file] ensures that the channel is closed when the promise returned by [f] resolves, or if [f] raises an exception. See {!Lwt_io.open_file} for a description of the arguments, warnings, and other notes. *) val open_temp_file : ?buffer:Lwt_bytes.t -> ?flags:Unix.open_flag list -> ?perm:Unix.file_perm -> ?temp_dir:string -> ?prefix:string -> ?suffix:string -> unit -> (string * output_channel) Lwt.t (** [open_temp_file ()] starts creating a new temporary file, and evaluates to a promise for the pair of the file's name, and an output channel for writing to the file. The caller should take care to delete the file later. Alternatively, see {!Lwt_io.with_temp_file}. The [?buffer] and [?perm] arguments are passed directly to an internal call to {!Lwt_io.open_file}. If not specified, [?flags] defaults to [[O_CREATE; O_EXCL; O_WRONLY; O_CLOEXEC]]. If specified, the specified flags are used exactly. Note that these should typically contain at least [O_CREAT] and [O_EXCL], otherwise [open_temp_file] may open an existing file. [?temp_dir] can be used to choose the directory in which the file is created. For the current directory, use {!Stdlib.Filename.current_dir_name}. If not specified, the directory is taken from {!Stdlib.Filename.get_temp_dir_name}, which is typically set to your system temporary file directory. [?prefix] helps determine the name of the file. It will be the prefix concatenated with a random sequence of characters. If not specified, [open_temp_file] uses some default prefix. [?suffix] is like [prefix], but it is appended at the end of the filename. In particular, it can be used to set the extension. This argument is supported since Lwt 4.4.0. @since 3.2.0 *) val with_temp_file : ?buffer:Lwt_bytes.t -> ?flags:Unix.open_flag list -> ?perm:Unix.file_perm -> ?temp_dir:string -> ?prefix:string -> ?suffix:string -> (string * output_channel -> 'b Lwt.t) -> 'b Lwt.t (** [with_temp_file f] calls {!open_temp_file}[ ()], passing all optional arguments directly to it. It then attaches [f] to run after the file is created, passing the filename and output channel to [f]. When the promise returned by [f] is resolved, [with_temp_file] closes the channel and deletes the temporary file by calling {!Lwt_unix.unlink}. @since 3.2.0 *) val create_temp_dir : ?perm:Unix.file_perm -> ?parent:string -> ?prefix:string -> ?suffix:string -> unit -> string Lwt.t (** Creates a temporary directory, and returns a promise that resolves to its path. The caller must take care to remove the directory. Alternatively, see {!Lwt_io.with_temp_dir}. If [~perm] is specified, the directory is created with the given permissions. The default permissions are [0755]. [~parent] is the directory in which the temporary directory is created. If not specified, the default value is the result of [Filename.get_temp_dir_name ()]. [~prefix] is prepended to the directory name, and [~suffix] is appended to it. @since 4.4.0 *) val with_temp_dir : ?perm:Unix.file_perm -> ?parent:string -> ?prefix:string -> ?suffix:string -> (string -> 'a Lwt.t) -> 'a Lwt.t (** [with_temp_dir f] first calls {!create_temp_dir}, forwarding all optional arguments to it. Once the temporary directory is created at [path], [with_temp_dir f] calls [f path]. When the promise returned by [f path] is resolved, [with_temp_dir f] recursively deletes the temporary directory and all its contents by calling {!Lwt_io.delete_recursively}. @since 4.4.0 *) val delete_recursively : string -> unit Lwt.t (** [delete_recursively path] attempts to delete the directory [path] and all its content recursively. This is likely VERY slow for directories with many files. That is probably best addressed by switching to blocking calls run inside a worker thread, i.e. with {!Lwt_preemptive}. @since 5.7.0 *) val open_connection : ?fd : Lwt_unix.file_descr -> ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> Unix.sockaddr -> (input_channel * output_channel) Lwt.t (** [open_connection ?fd ?in_buffer ?out_buffer addr] opens a connection to the given address and returns two channels for using it. If [fd] is not specified, a fresh one will be used. The connection is completely closed when you close both channels. @raise Unix.Unix_error on error. *) val with_connection : ?fd : Lwt_unix.file_descr -> ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> Unix.sockaddr -> (input_channel * output_channel -> 'a Lwt.t) -> 'a Lwt.t (** [with_connection ?fd ?in_buffer ?out_buffer addr f] opens a connection to the given address and passes the channels to [f] *) (**/**) (** This function is not public API and can be changed or removed without notice. It is exposed in order to test [with_connection]. [with_close_connection f (ic, oc)] calls [f (ic, oc)] and makes sure that [ic] and [oc] are closed, whether [f] returns or fails with an exception. Does not fail if [ic] or [oc] is already closed. *) val with_close_connection : (input_channel * output_channel -> 'a Lwt.t) -> input_channel * output_channel -> 'a Lwt.t (**/**) type server (** Type of a server *) val establish_server_with_client_socket : ?server_fd:Lwt_unix.file_descr -> ?backlog:int -> ?no_close:bool -> Unix.sockaddr -> (Lwt_unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t) -> server Lwt.t (** [establish_server_with_client_socket listen_address f] creates a server which listens for incoming connections on [listen_address]. When a client makes a new connection, it is passed to [f]: more precisely, the server calls {[ f client_address client_socket ]} where [client_address] is the address (peer name) of the new client, and [client_socket] is the socket connected to the client. The server does not block waiting for [f] to complete: it concurrently tries to accept more client connections while [f] is handling the client. When the promise returned by [f] completes (i.e., [f] is done handling the client), [establish_server_with_client_socket] automatically closes [client_socket]. This is a default behavior that is useful for simple cases, but for a robust application you should explicitly close these channels yourself, and handle any exceptions as appropriate. If the channels are still open when [f] completes, and their automatic closing raises an exception, [establish_server_with_client_socket] treats it as an unhandled exception reaching the top level of the application: it passes that exception to {!Lwt.async_exception_hook}, the default behavior of which is to print the exception and {e terminate your process}. Automatic closing can be completely disabled by passing [~no_close:true]. Similarly, if [f] raises an exception (or the promise it returns fails with an exception), [establish_server_with_client_socket] can do nothing with that exception, except pass it to {!Lwt.async_exception_hook}. [~server_fd] can be specified to use an existing file descriptor for listening. Otherwise, a fresh socket is created internally. In either case, [establish_server_with_client_socket] will internally assign [listen_address] to the server socket. [~backlog] is the argument passed to {!Lwt_unix.listen}. Its default value is [SOMAXCONN], which varies by platform and socket kind. The returned promise (a [server Lwt.t]) resolves when the server has just started listening on [listen_address]: right after the internal call to [listen], and right before the first internal call to [accept]. @since 4.1.0 *) val establish_server_with_client_address : ?fd:Lwt_unix.file_descr -> ?buffer_size:int -> ?backlog:int -> ?no_close:bool -> Unix.sockaddr -> (Lwt_unix.sockaddr -> input_channel * output_channel -> unit Lwt.t) -> server Lwt.t (** Like {!Lwt_io.establish_server_with_client_socket}, but passes two buffered channels to the connection handler [f]. These channels wrap the client socket. The channels are closed automatically when the promise returned by [f] resolves. To avoid this behavior, pass [~no_close:true]. @since 3.1.0 *) val shutdown_server : server -> unit Lwt.t (** Closes the given server's listening socket. The returned promise resolves when the [close(2)] system call completes. This function does not affect the sockets of connections that have already been accepted, i.e. passed to [f] by {!establish_server}. @since 3.0.0 *) val lines_of_file : file_name -> string Lwt_stream.t (** [lines_of_file name] returns a stream of all lines of the file with name [name]. The file is automatically closed when all lines have been read. *) val lines_to_file : file_name -> string Lwt_stream.t -> unit Lwt.t (** [lines_to_file name lines] writes all lines of [lines] to file with name [name]. *) val chars_of_file : file_name -> char Lwt_stream.t (** [chars_of_file name] returns a stream of all characters of the file with name [name]. As for {!lines_of_file} the file is closed when all characters have been read. *) val chars_to_file : file_name -> char Lwt_stream.t -> unit Lwt.t (** [chars_to_file name chars] writes all characters of [chars] to [name] *) (** {2 Input/output of integers} *) (** Common interface for reading/writing integers in binary *) module type NumberIO = sig (** {3 Reading} *) val read_int : input_channel -> int Lwt.t (** Reads a 32-bits integer as an ocaml int *) val read_int16 : input_channel -> int Lwt.t val read_int32 : input_channel -> int32 Lwt.t val read_int64 : input_channel -> int64 Lwt.t val read_float32 : input_channel -> float Lwt.t (** Reads an IEEE single precision floating point value *) val read_float64 : input_channel -> float Lwt.t (** Reads an IEEE double precision floating point value *) (** {3 Writing} *) val write_int : output_channel -> int -> unit Lwt.t (** Writes an ocaml int as a 32-bits integer *) val write_int16 : output_channel -> int -> unit Lwt.t val write_int32 : output_channel -> int32 -> unit Lwt.t val write_int64 : output_channel -> int64 -> unit Lwt.t val write_float32 : output_channel -> float -> unit Lwt.t (** Writes an IEEE single precision floating point value *) val write_float64 : output_channel -> float -> unit Lwt.t (** Writes an IEEE double precision floating point value *) end module LE : NumberIO (** Reading/writing of numbers in little-endian *) module BE : NumberIO (** Reading/writing of numbers in big-endian *) include NumberIO (** Reading/writing of numbers in the system endianness. *) type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian (** Type of byte order *) val system_byte_order : byte_order (** Same as {!val:Lwt_sys.byte_order}. *) (** {2 Low-level access to the internal buffer} *) val block : 'a channel -> int -> (Lwt_bytes.t -> int -> 'b Lwt.t) -> 'b Lwt.t (** [block ch size f] pass to [f] the internal buffer and an offset. The buffer contains [size] chars at [offset]. [f] may read or write these chars. [size] must satisfy [0 <= size <= 16] *) (** Information for directly accessing the internal buffer of a channel *) type direct_access = { da_buffer : Lwt_bytes.t; (** The internal buffer *) mutable da_ptr : int; (** The pointer to: - the beginning of free space for output channels - the beginning of data for input channels *) mutable da_max : int; (** The maximum offset *) da_perform : unit -> int Lwt.t; (** - for input channels: refills the buffer and returns how many bytes have been read - for output channels: flush partially the buffer and returns how many bytes have been written *) } val direct_access : 'a channel -> (direct_access -> 'b Lwt.t) -> 'b Lwt.t (** [direct_access ch f] passes to [f] a {!type:direct_access} structure. [f] must use it and update [da_ptr] to reflect how many bytes have been read/written. *) (** {2 Misc} *) val default_buffer_size : unit -> int (** Return the default size for buffers. Channels that are created without a specific buffer use new buffer of this size. *) val set_default_buffer_size : int -> unit (** Change the default buffer size. @raise Invalid_argument if the given size is smaller than [16] or greater than {!Stdlib.Sys.max_string_length} *) (** {2 Deprecated} *) val establish_server : ?fd : Lwt_unix.file_descr -> ?buffer_size : int -> ?backlog : int -> ?no_close : bool -> Unix.sockaddr -> (input_channel * output_channel -> unit Lwt.t) -> server Lwt.t [@@ocaml.deprecated " Since Lwt 3.1.0, use Lwt_io.establish_server_with_client_address"] (** Like [establish_server_with_client_address], but does not pass the client address or fd to the callback [f]. @deprecated Use {!establish_server_with_client_address}. @since 3.0.0 *) (** Versioned variants of APIs undergoing breaking changes. *) module Versioned : sig val establish_server_1 : ?fd : Lwt_unix.file_descr -> ?buffer_size : int -> ?backlog : int -> Unix.sockaddr -> (input_channel * output_channel -> unit) -> server [@@ocaml.deprecated " Deprecated in favor of Lwt_io.establish_server. See https://github.com/ocsigen/lwt/pull/258"] (** Old version of {!Lwt_io.establish_server}. The current {!Lwt_io.establish_server} automatically closes channels passed to the callback, and notifies the caller when the server's listening socket is bound. @deprecated Use {!Lwt_io.establish_server_with_client_address}. @since 2.7.0 *) val establish_server_2 : ?fd : Lwt_unix.file_descr -> ?buffer_size : int -> ?backlog : int -> ?no_close : bool -> Unix.sockaddr -> (input_channel * output_channel -> unit Lwt.t) -> server Lwt.t [@@ocaml.deprecated " In Lwt >= 3.0.0, this is an alias for Lwt_io.establish_server."] (** Since Lwt 3.0.0, this is just an alias for {!Lwt_io.establish_server}. @deprecated Use {!Lwt_io.establish_server_with_client_address}. @since 2.7.0 *) val shutdown_server_1 : server -> unit [@@ocaml.deprecated " Deprecated in favor of Lwt_io.shutdown_server. See https://github.com/ocsigen/lwt/issues/259"] (** Old version of {!Lwt_io.shutdown_server}. The current {!Lwt_io.shutdown_server} returns a promise, which resolves when the server's listening socket is closed. @deprecated Use {!Lwt_io.shutdown_server}. @since 2.7.0 *) val shutdown_server_2 : server -> unit Lwt.t [@@ocaml.deprecated " In Lwt >= 3.0.0, this is an alias for Lwt_io.shutdown_server."] (** Since Lwt 3.0.0, this is just an alias for {!Lwt_io.shutdown_server}. @deprecated Use {!Lwt_io.shutdown_server}. @since 2.7.0 *) end lwt-5.9.1/src/unix/lwt_libev_stubs.c000066400000000000000000000203401476253734400174770ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Stubs for libev */ #include "lwt_config.h" #if defined(HAVE_LIBEV) #include #include #include #include #include #include #include #include #include #include "lwt_unix.h" /* +-----------------------------------------------------------------+ | Backend types | +-----------------------------------------------------------------+ */ enum { val_EVBACKEND_DEFAULT, val_EVBACKEND_SELECT, val_EVBACKEND_POLL, val_EVBACKEND_EPOLL, val_EVBACKEND_KQUEUE, val_EVBACKEND_DEVPOLL, val_EVBACKEND_PORT }; static unsigned int backend_val(value v) { switch (Int_val(v)) { case val_EVBACKEND_DEFAULT: return 0; case val_EVBACKEND_SELECT: return EVBACKEND_SELECT; case val_EVBACKEND_POLL: return EVBACKEND_POLL; case val_EVBACKEND_EPOLL: return EVBACKEND_EPOLL; case val_EVBACKEND_KQUEUE: return EVBACKEND_KQUEUE; case val_EVBACKEND_DEVPOLL: return EVBACKEND_DEVPOLL; case val_EVBACKEND_PORT: return EVBACKEND_PORT; default: assert(0); } } /* +-----------------------------------------------------------------+ | Loops | +-----------------------------------------------------------------+ */ static int compare_loops(value a, value b) { return (int)((char *)Ev_loop_val(a) - (char *)Ev_loop_val(b)); } static long hash_loop(value loop) { return (long)Ev_loop_val(loop); } static struct custom_operations loop_ops = { "lwt.libev.loop", custom_finalize_default, compare_loops, hash_loop, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default, NULL }; /* Do nothing. We replace the invoke_pending callback of the event loop, so when events are ready, they can be executed after ev_loop has returned: it is executed in a blocking section and callbacks must be executed outside. */ static void nop(struct ev_loop *loop) {} CAMLprim value lwt_libev_init(value backend) { struct ev_loop *loop = ev_loop_new(EVFLAG_FORKCHECK | backend_val(backend)); if (!loop) caml_failwith("lwt_libev_init"); /* Remove the invoke_pending callback. */ ev_set_invoke_pending_cb(loop, nop); value result = caml_alloc_custom(&loop_ops, sizeof(struct ev_loop *), 0, 1); Ev_loop_val(result) = loop; return result; } CAMLprim value lwt_libev_backend(value loop) { switch (ev_backend(Ev_loop_val(loop))) { case EVBACKEND_SELECT: return Val_int(val_EVBACKEND_SELECT); case EVBACKEND_POLL: return Val_int(val_EVBACKEND_POLL); case EVBACKEND_EPOLL: return Val_int(val_EVBACKEND_EPOLL); case EVBACKEND_KQUEUE: return Val_int(val_EVBACKEND_KQUEUE); case EVBACKEND_DEVPOLL: return Val_int(val_EVBACKEND_DEVPOLL); case EVBACKEND_PORT: return Val_int(val_EVBACKEND_PORT); default: assert(0); } } CAMLprim value lwt_libev_stop(value loop) { ev_loop_destroy(Ev_loop_val(loop)); return Val_unit; } CAMLprim value lwt_libev_loop(value val_loop, value val_block) { struct ev_loop *loop = Ev_loop_val(val_loop); /* Call the event loop inside a blocking section. */ caml_enter_blocking_section(); ev_loop(loop, Bool_val(val_block) ? EVLOOP_ONESHOT : EVLOOP_ONESHOT | EVLOOP_NONBLOCK); caml_leave_blocking_section(); /* Invoke callbacks now, i.e. outside the blocking section. */ ev_invoke_pending(loop); return Val_unit; } CAMLprim value lwt_libev_unloop(value loop) { ev_unloop(Ev_loop_val(loop), EVUNLOOP_ONE); return Val_unit; } /* +-----------------------------------------------------------------+ | Watchers | +-----------------------------------------------------------------+ */ #define Ev_io_val(v) *(struct ev_io **)Data_custom_val(v) #define Ev_timer_val(v) *(struct ev_timer **)Data_custom_val(v) static int compare_watchers(value a, value b) { return (int)((char *)Ev_io_val(a) - (char *)Ev_io_val(b)); } static long hash_watcher(value watcher) { return (long)Ev_io_val(watcher); } static struct custom_operations watcher_ops = { "lwt.libev.watcher", custom_finalize_default, compare_watchers, hash_watcher, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default, NULL }; /* +-----------------------------------------------------------------+ | IO watchers | +-----------------------------------------------------------------+ */ static void handle_io(struct ev_loop *loop, ev_io *watcher, int revents) { caml_callback((value)watcher->data, Val_unit); } static value lwt_libev_io_init(struct ev_loop *loop, int fd, int event, value callback) { CAMLparam1(callback); CAMLlocal1(result); /* Create and initialise the watcher */ struct ev_io *watcher = lwt_unix_new(struct ev_io); ev_io_init(watcher, handle_io, fd, event); /* Wrap the watcher into a custom caml value */ result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_io *), 0, 1); Ev_io_val(result) = watcher; /* Store the callback in the watcher, and register it as a root */ watcher->data = (void *)callback; caml_register_generational_global_root((value *)(&(watcher->data))); /* Start the event */ ev_io_start(loop, watcher); CAMLreturn(result); } CAMLprim value lwt_libev_readable_init(value loop, value fd, value callback) { return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_READ, callback); } CAMLprim value lwt_libev_writable_init(value loop, value fd, value callback) { return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_WRITE, callback); } CAMLprim value lwt_libev_io_stop(value loop, value val_watcher) { CAMLparam2(loop, val_watcher); struct ev_io *watcher = Ev_io_val(val_watcher); caml_remove_generational_global_root((value *)(&(watcher->data))); ev_io_stop(Ev_loop_val(loop), watcher); free(watcher); CAMLreturn(Val_unit); } /* +-----------------------------------------------------------------+ | Timer watchers | +-----------------------------------------------------------------+ */ static void handle_timer(struct ev_loop *loop, ev_timer *watcher, int revents) { caml_callback((value)watcher->data, Val_unit); } CAMLprim value lwt_libev_timer_init(value loop, value delay, value repeat, value callback) { CAMLparam4(loop, delay, repeat, callback); CAMLlocal1(result); struct ev_loop* ev_loop = Ev_loop_val(loop); /* Create and initialise the watcher */ struct ev_timer *watcher = lwt_unix_new(struct ev_timer); ev_tstamp adjusted_delay = Double_val(delay) + ev_time() - ev_now(ev_loop); if (Bool_val(repeat)) ev_timer_init(watcher, handle_timer, adjusted_delay, Double_val(delay)); else ev_timer_init(watcher, handle_timer, adjusted_delay, 0.0); /* Wrap the watcher into a custom caml value */ result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_timer *), 0, 1); Ev_timer_val(result) = watcher; /* Store the callback in the watcher, and register it as a root */ watcher->data = (void *)callback; caml_register_generational_global_root((value *)(&(watcher->data))); /* Start the event */ ev_timer_start(ev_loop, watcher); CAMLreturn(result); } CAMLprim value lwt_libev_timer_stop(value loop, value val_watcher) { CAMLparam2(loop, val_watcher); struct ev_timer *watcher = Ev_timer_val(val_watcher); caml_remove_generational_global_root((value *)(&(watcher->data))); ev_timer_stop(Ev_loop_val(loop), watcher); free(watcher); CAMLreturn(Val_unit); } #else #include "lwt_unix.h" LWT_NOT_AVAILABLE1(libev_backend) LWT_NOT_AVAILABLE1(libev_init) LWT_NOT_AVAILABLE1(libev_stop) LWT_NOT_AVAILABLE2(libev_loop) LWT_NOT_AVAILABLE1(libev_unloop) LWT_NOT_AVAILABLE3(libev_readable_init) LWT_NOT_AVAILABLE3(libev_writable_init) LWT_NOT_AVAILABLE2(libev_io_stop) LWT_NOT_AVAILABLE4(libev_timer_init) LWT_NOT_AVAILABLE2(libev_timer_stop) #endif lwt-5.9.1/src/unix/lwt_main.ml000066400000000000000000000120741476253734400162750ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] open Lwt.Infix let enter_iter_hooks = Lwt_sequence.create () let leave_iter_hooks = Lwt_sequence.create () let yield = Lwt.pause let abandon_yielded_and_paused () = Lwt.abandon_paused () let run p = let rec run_loop () = match Lwt.poll p with | Some x -> x | None -> (* Call enter hooks. *) Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; (* Do the main loop call. *) let should_block_waiting_for_io = Lwt.paused_count () = 0 in Lwt_engine.iter should_block_waiting_for_io; (* Fulfill paused promises. *) Lwt.wakeup_paused (); (* Call leave hooks. *) Lwt_sequence.iter_l (fun f -> f ()) leave_iter_hooks; (* Repeat. *) run_loop () in run_loop () let run_already_called = ref `No let run_already_called_mutex = Mutex.create () let finished () = Mutex.lock run_already_called_mutex; run_already_called := `No; Mutex.unlock run_already_called_mutex let run p = (* Fail in case a call to Lwt_main.run is nested under another invocation of Lwt_main.run. *) Mutex.lock run_already_called_mutex; let error_message_if_call_is_nested = match !run_already_called with (* `From is effectively disabled for the time being, because there is a bug, present in all versions of OCaml supported by Lwt, where, with the bytecode runtime, if one changes the working directory and then attempts to retrieve the backtrace, the runtime calls [abort] at the C level and exits the program ungracefully. It is especially likely that a daemon would change directory before calling [Lwt_main.run], so we can't have it retrieving the backtrace, even though a daemon is not likely to be compiled to bytecode. This can be addressed with detection. Starting with 4.04, there is a type [Sys.backend_type] that could be used. *) | `From backtrace_string -> Some (Printf.sprintf "%s\n%s\n%s" "Nested calls to Lwt_main.run are not allowed" "Lwt_main.run already called from:" backtrace_string) | `From_somewhere -> Some ("Nested calls to Lwt_main.run are not allowed") | `No -> let called_from = (* See comment above. if Printexc.backtrace_status () then let backtrace = try raise Exit with Exit -> Printexc.get_backtrace () in `From backtrace else *) `From_somewhere in run_already_called := called_from; None in Mutex.unlock run_already_called_mutex; begin match error_message_if_call_is_nested with | Some message -> failwith message | None -> () end; match run p with | result -> finished (); result | exception exn when Lwt.Exception_filter.run exn -> finished (); raise exn let exit_hooks = Lwt_sequence.create () let rec call_hooks () = match Lwt_sequence.take_opt_l exit_hooks with | None -> Lwt.return_unit | Some f -> Lwt.catch (fun () -> f ()) (fun _ -> Lwt.return_unit) >>= fun () -> call_hooks () let () = at_exit (fun () -> if not (Lwt_sequence.is_empty exit_hooks) then begin Lwt.abandon_wakeups (); finished (); run (call_hooks ()) end) let at_exit f = ignore (Lwt_sequence.add_l f exit_hooks) module type Hooks = sig type 'return_value kind type hook val add_first : (unit -> unit kind) -> hook val add_last : (unit -> unit kind) -> hook val remove : hook -> unit val remove_all : unit -> unit end module type Hook_sequence = sig type 'return_value kind val sequence : (unit -> unit kind) Lwt_sequence.t end module Wrap_hooks (Sequence : Hook_sequence) = struct type 'a kind = 'a Sequence.kind type hook = (unit -> unit Sequence.kind) Lwt_sequence.node let add_first hook_fn = let hook_node = Lwt_sequence.add_l hook_fn Sequence.sequence in hook_node let add_last hook_fn = let hook_node = Lwt_sequence.add_r hook_fn Sequence.sequence in hook_node let remove hook_node = Lwt_sequence.remove hook_node let remove_all () = Lwt_sequence.iter_node_l Lwt_sequence.remove Sequence.sequence end module Enter_iter_hooks = Wrap_hooks (struct type 'return_value kind = 'return_value let sequence = enter_iter_hooks end) module Leave_iter_hooks = Wrap_hooks (struct type 'return_value kind = 'return_value let sequence = leave_iter_hooks end) module Exit_hooks = Wrap_hooks (struct type 'return_value kind = 'return_value Lwt.t let sequence = exit_hooks end) lwt-5.9.1/src/unix/lwt_main.mli000066400000000000000000000135011476253734400164420ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Main loop and event queue *) (** This module controls the ``main-loop'' of Lwt. *) val run : 'a Lwt.t -> 'a (** [Lwt_main.run p] calls the Lwt scheduler, performing I/O until [p] resolves. [Lwt_main.run p] returns the value in [p] if [p] is fulfilled. If [p] is rejected with an exception instead, [Lwt_main.run p] raises that exception. Every native and bytecode program that uses Lwt should call this function at its top level. It implements the Lwt main loop. Example: {[ let main () = Lwt_io.write_line Lwt_io.stdout "hello world" let () = Lwt_main.run (main ()) ]} [Lwt_main.run] is not available when targeting JavaScript, because the environment (such as Node.js or the browser's script engine) implements the I/O loop. On Unix, calling [Lwt_main.run] installs a [SIGCHLD] handler, which is needed for the implementations of {!Lwt_unix.waitpid} and {!Lwt_unix.wait4}. As a result, programs that call [Lwt_main.run] and also use non-Lwt system calls need to handle those system calls failing with [EINTR]. Nested calls to [Lwt_main.run] are not allowed. That is, do not call [Lwt_main.run] in a callback triggered by a promise that is resolved by an outer invocation of [Lwt_main.run]. If your program makes such a call, [Lwt_main.run] will raise [Failure]. This should be considered a logic error (i.e., code making such a call is inherently broken). In addition, note that if you have set the exception filter to let runtime exceptions bubble up (via [Lwt.Exception_filter.(set handle_all_except_runtime)]) then Lwt does not attempt to catch exceptions thrown by the OCaml runtime. Specifically, in this case, Lwt lets [Out_of_memory] and [Stack_overflow] exceptions traverse all of its functions and bubble up to the caller of [Lwt_main.run]. Moreover because these exceptions are left to traverse the call stack, they leave the internal data-structures in an inconsistent state. For this reason, calling [Lwt_main.run] again after such an exception will raise [Failure]. It is not safe to call [Lwt_main.run] in a function registered with [Stdlib.at_exit], use {!Lwt_main.at_exit} instead. *) val yield : unit -> unit Lwt.t [@@deprecated "Use Lwt.pause instead"] (** [yield ()] is a pending promise that is fulfilled after Lwt finishes calling all currently ready callbacks, i.e. it is fulfilled on the next “tick.” @deprecated Since 5.5.0 [yield] is deprecated in favor of the more general {!Lwt.pause} in order to avoid discrepancies in resolution (see below) and stay compatible with other execution environments such as js_of_ocaml. *) val abandon_yielded_and_paused : unit -> unit [@@deprecated "Use Lwt.abandon_paused instead"] (** Causes promises created with {!Lwt.pause} and {!Lwt_main.yield} to remain forever pending. (Note that [yield] is deprecated in favor of the more general {!Lwt.pause}.) This is meant for use with {!Lwt_unix.fork}, as a way to “abandon” more promise chains that are pending in your process. @deprecated Since 5.7 [abandon_yielded_and_paused] is deprecated in favour of [Lwt.abandon_paused]. *) (** Hook sequences. Each module of this type is a set of hooks, to be run by Lwt at certain points during execution. See modules {!Enter_iter_hooks}, {!Leave_iter_hooks}, and {!Exit_hooks}. *) module type Hooks = sig type 'return_value kind (** Hooks are functions of either type [unit -> unit] or [unit -> unit Lwt.t]; this type constructor is used only to express both possibilities in one signature. *) type hook (** Values of type [hook] represent hooks that have been added, so that they can be removed later (if needed). *) val add_first : (unit -> unit kind) -> hook (** Adds a hook to the hook sequence underlying this module, to be run {e first}, before any other hooks already added. *) val add_last : (unit -> unit kind) -> hook (** Adds a hook to the hook sequence underlying this module, to be run {e last}, after any other hooks already added. *) val remove : hook -> unit (** Removes a hook added by {!add_first} or {!add_last}. *) val remove_all : unit -> unit (** Removes all hooks from the hook sequence underlying this module. *) end (** Hooks, of type [unit -> unit], that are called before each iteration of the Lwt main loop. @since 4.2.0 *) module Enter_iter_hooks : Hooks with type 'return_value kind = 'return_value (** Hooks, of type [unit -> unit], that are called after each iteration of the Lwt main loop. @since 4.2.0 *) module Leave_iter_hooks : Hooks with type 'return_value kind = 'return_value (** Promise-returning hooks, of type [unit -> unit Lwt.t], that are called at process exit. Exceptions raised by these hooks are ignored. @since 4.2.0 *) module Exit_hooks : Hooks with type 'return_value kind = 'return_value Lwt.t [@@@ocaml.warning "-3"] val enter_iter_hooks : (unit -> unit) Lwt_sequence.t [@@ocaml.deprecated " Use module Lwt_main.Enter_iter_hooks."] (** @deprecated Use module {!Enter_iter_hooks}. *) val leave_iter_hooks : (unit -> unit) Lwt_sequence.t [@@ocaml.deprecated " Use module Lwt_main.Leave_iter_hooks."] (** @deprecated Use module {!Leave_iter_hooks}. *) val exit_hooks : (unit -> unit Lwt.t) Lwt_sequence.t [@@ocaml.deprecated " Use module Lwt_main.Exit_hooks."] (** @deprecated Use module {!Exit_hooks}. *) [@@@ocaml.warning "+3"] val at_exit : (unit -> unit Lwt.t) -> unit (** [Lwt_main.at_exit hook] is the same as [ignore (Lwt_main.Exit_hooks.add_first hook)]. *) lwt-5.9.1/src/unix/lwt_preemptive.ml000066400000000000000000000171541476253734400175350ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] open Lwt.Infix (* +-----------------------------------------------------------------+ | Parameters | +-----------------------------------------------------------------+ *) (* Minimum number of preemptive threads: *) let min_threads : int ref = ref 0 (* Maximum number of preemptive threads: *) let max_threads : int ref = ref 0 (* Size of the waiting queue: *) let max_thread_queued = ref 1000 let get_max_number_of_threads_queued _ = !max_thread_queued let set_max_number_of_threads_queued n = if n < 0 then invalid_arg "Lwt_preemptive.set_max_number_of_threads_queued"; max_thread_queued := n (* The total number of preemptive threads currently running: *) let threads_count = ref 0 (* +-----------------------------------------------------------------+ | Preemptive threads management | +-----------------------------------------------------------------+ *) module CELL : sig type 'a t val make : unit -> 'a t val get : 'a t -> 'a val set : 'a t -> 'a -> unit end = struct type 'a t = { m : Mutex.t; cv : Condition.t; mutable cell : 'a option; } let make () = { m = Mutex.create (); cv = Condition.create (); cell = None } let get t = let rec await_value t = match t.cell with | None -> Condition.wait t.cv t.m; await_value t | Some v -> t.cell <- None; Mutex.unlock t.m; v in Mutex.lock t.m; await_value t let set t v = Mutex.lock t.m; t.cell <- Some v; Mutex.unlock t.m; Condition.signal t.cv end type thread = { task_cell: (int * (unit -> unit)) CELL.t; (* Channel used to communicate notification id and tasks to the worker thread. *) mutable thread : Thread.t; (* The worker thread. *) mutable reuse : bool; (* Whether the thread must be re-added to the pool when the work is done. *) } (* Pool of worker threads: *) let workers : thread Queue.t = Queue.create () (* Queue of clients waiting for a worker to be available: *) let waiters : thread Lwt.u Lwt_sequence.t = Lwt_sequence.create () (* Code executed by a worker: *) let rec worker_loop worker = let id, task = CELL.get worker.task_cell in task (); (* If there is too much threads, exit. This can happen if the user decreased the maximum: *) if !threads_count > !max_threads then worker.reuse <- false; (* Tell the main thread that work is done: *) Lwt_unix.send_notification id; if worker.reuse then worker_loop worker (* create a new worker: *) let make_worker () = incr threads_count; let worker = { task_cell = CELL.make (); thread = Thread.self (); reuse = true; } in worker.thread <- Thread.create worker_loop worker; worker (* Add a worker to the pool: *) let add_worker worker = match Lwt_sequence.take_opt_l waiters with | None -> Queue.add worker workers | Some w -> Lwt.wakeup w worker (* Wait for worker to be available, then return it: *) let get_worker () = if not (Queue.is_empty workers) then Lwt.return (Queue.take workers) else if !threads_count < !max_threads then Lwt.return (make_worker ()) else (Lwt.add_task_r [@ocaml.warning "-3"]) waiters (* +-----------------------------------------------------------------+ | Initialisation, and dynamic parameters reset | +-----------------------------------------------------------------+ *) let get_bounds () = (!min_threads, !max_threads) let set_bounds (min, max) = if min < 0 || max < min then invalid_arg "Lwt_preemptive.set_bounds"; let diff = min - !threads_count in min_threads := min; max_threads := max; (* Launch new workers: *) for _i = 1 to diff do add_worker (make_worker ()) done let initialized = ref false let init min max _errlog = initialized := true; set_bounds (min, max) let simple_init () = if not !initialized then begin initialized := true; set_bounds (0, 4) end let nbthreads () = !threads_count let nbthreadsqueued () = Lwt_sequence.fold_l (fun _ x -> x + 1) waiters 0 let nbthreadsbusy () = !threads_count - Queue.length workers (* +-----------------------------------------------------------------+ | Detaching | +-----------------------------------------------------------------+ *) let init_result = Result.Error (Failure "Lwt_preemptive.detach") let detach f args = simple_init (); let result = ref init_result in (* The task for the worker thread: *) let task () = try result := Result.Ok (f args) with exn when Lwt.Exception_filter.run exn -> result := Result.Error exn in get_worker () >>= fun worker -> let waiter, wakener = Lwt.wait () in let id = Lwt_unix.make_notification ~once:true (fun () -> Lwt.wakeup_result wakener !result) in Lwt.finalize (fun () -> (* Send the id and the task to the worker: *) CELL.set worker.task_cell (id, task); waiter) (fun () -> if worker.reuse then (* Put back the worker to the pool: *) add_worker worker else begin decr threads_count; (* Or wait for the thread to terminates, to free its associated resources: *) Thread.join worker.thread end; Lwt.return_unit) (* +-----------------------------------------------------------------+ | Running Lwt threads in the main thread | +-----------------------------------------------------------------+ *) (* Queue of [unit -> unit Lwt.t] functions. *) let jobs = Queue.create () (* Mutex to protect access to [jobs]. *) let jobs_mutex = Mutex.create () let job_notification = Lwt_unix.make_notification (fun () -> (* Take the first job. The queue is never empty at this point. *) Mutex.lock jobs_mutex; let thunk = Queue.take jobs in Mutex.unlock jobs_mutex; ignore (thunk ())) let run_in_main_dont_wait f = (* Add the job to the queue. *) Mutex.lock jobs_mutex; Queue.add f jobs; Mutex.unlock jobs_mutex; (* Notify the main thread. *) Lwt_unix.send_notification job_notification (* There is a potential performance issue from creating a cell every time this function is called. See: https://github.com/ocsigen/lwt/issues/218 https://github.com/ocsigen/lwt/pull/219 https://github.com/ocaml/ocaml/issues/7158 *) let run_in_main f = let cell = CELL.make () in (* Create the job. *) let job () = (* Execute [f] and wait for its result. *) Lwt.try_bind f (fun ret -> Lwt.return (Result.Ok ret)) (fun exn -> Lwt.return (Result.Error exn)) >>= fun result -> (* Send the result. *) CELL.set cell result; Lwt.return_unit in run_in_main_dont_wait job; (* Wait for the result. *) match CELL.get cell with | Result.Ok ret -> ret | Result.Error exn -> raise exn (* This version shadows the one above, adding an exception handler *) let run_in_main_dont_wait f handler = let f () = Lwt.catch f (fun exc -> handler exc; Lwt.return_unit) in run_in_main_dont_wait f lwt-5.9.1/src/unix/lwt_preemptive.mli000066400000000000000000000070611476253734400177020ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** This module allows to mix preemptive threads with [Lwt] cooperative threads. It maintains an extensible pool of preemptive threads to which you can detach computations. See {{:https://github.com/hcarty/mwt} Mwt} for a more modern implementation. *) val detach : ('a -> 'b) -> 'a -> 'b Lwt.t (** [detach f x] runs the computation [f x] in a separate preemptive thread. [detach] evaluates to an Lwt promise, which is pending until the preemptive thread completes. [detach] calls {!simple_init} internally, which means that the number of preemptive threads is capped by default at four. If you would like a higher limit, call {!init} or {!set_bounds} directly. Note that Lwt thread-local storage (i.e., {!Lwt.with_value}) cannot be safely used from within [f]. The same goes for most of the rest of Lwt. If you need to run an Lwt thread in [f], use {!run_in_main}. *) val run_in_main : (unit -> 'a Lwt.t) -> 'a (** [run_in_main f] can be called from a detached computation to execute [f ()] in the main preemptive thread, i.e. the one executing {!Lwt_main.run}. [run_in_main f] blocks until [f ()] completes, then returns its result. If [f ()] raises an exception, [run_in_main f] raises the same exception. {!Lwt.with_value} may be used inside [f ()]. {!Lwt.get} can correctly retrieve values set this way inside [f ()], but not values set using {!Lwt.with_value} outside [f ()]. *) val run_in_main_dont_wait : (unit -> unit Lwt.t) -> (exn -> unit) -> unit (** [run_in_main_dont_wait f h] does the same as [run_in_main f] but a bit faster and lighter as it does not wait for the result of [f]. If [f]'s promise is rejected (or if it raises), then the function [h] is called with the rejection exception. @since 5.7.0 *) val init : int -> int -> (string -> unit) -> unit (** [init min max log] initialises this module. i.e. it launches the minimum number of preemptive threads and starts the {b dispatcher}. @param min is the minimum number of threads @param max is the maximum number of threads @param log is used to log error messages If {!Lwt_preemptive} has already been initialised, this call only modify bounds and the log function. *) val simple_init : unit -> unit (** [simple_init ()] checks if the library is not yet initialized, and if not, does a {i simple initialization}. The minimum number of threads is set to zero, maximum to four, and the log function is left unchanged, i.e. the default built-in logging function is used. See {!Lwt_preemptive.init}. Note: this function is automatically called by {!detach}. *) val get_bounds : unit -> int * int (** [get_bounds ()] returns the minimum and the maximum number of preemptive threads. *) val set_bounds : int * int -> unit (** [set_bounds (min, max)] set the minimum and the maximum number of preemptive threads. *) val set_max_number_of_threads_queued : int -> unit (** Sets the size of the waiting queue, if no more preemptive threads are available. When the queue is full, {!detach} will sleep until a thread is available. *) val get_max_number_of_threads_queued : unit -> int (** Returns the size of the waiting queue, if no more threads are available *) (**/**) val nbthreads : unit -> int val nbthreadsbusy : unit -> int val nbthreadsqueued : unit -> int lwt-5.9.1/src/unix/lwt_process.cppo.ml000066400000000000000000000374071476253734400177760ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix type command = string * string array let shell = if Sys.win32 then fun cmd -> ("", [|"cmd.exe"; "/c"; "\000" ^ cmd|]) else fun cmd -> ("", [|"/bin/sh"; "-c"; cmd|]) type redirection = [ `Keep | `Dev_null | `Close | `FD_copy of Unix.file_descr | `FD_move of Unix.file_descr ] (* +-----------------------------------------------------------------+ | OS-dependent command spawning | +-----------------------------------------------------------------+ *) type proc = { id : int; (* The process id. *) fd : Unix.file_descr; (* A handle on windows, and a dummy value of Unix. *) } let win32_get_fd fd redirection = match redirection with | `Keep -> Some fd | `Dev_null -> Some (Unix.openfile "nul" [Unix.O_RDWR; Unix.O_KEEPEXEC] 0o666) | `Close -> None | `FD_copy fd' -> Some fd' | `FD_move fd' -> Some fd' external win32_create_process : string option -> string -> string option -> string option -> (Unix.file_descr option * Unix.file_descr option * Unix.file_descr option) -> proc = "lwt_process_create_process" let win32_quote arg = if String.length arg > 0 && arg.[0] = '\000' then String.sub arg 1 (String.length arg - 1) else Filename.quote arg let win32_spawn ?cwd ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) (prog, args) env = let cmdline = String.concat " " (List.map win32_quote (Array.to_list args)) in let env = match env with | None -> None | Some env -> let len = Array.fold_left (fun len str -> String.length str + len + 1) 1 env in let res = Bytes.create len in let ofs = Array.fold_left (fun ofs str -> let len = String.length str in String.blit str 0 res ofs len; Bytes.set res (ofs + len) '\000'; ofs + len + 1) 0 env in Bytes.set res ofs '\000'; Some (Bytes.unsafe_to_string res) in let stdin_fd = win32_get_fd Unix.stdin stdin and stdout_fd = win32_get_fd Unix.stdout stdout and stderr_fd = win32_get_fd Unix.stderr stderr in let proc = win32_create_process (if prog = "" then None else Some prog) cmdline env cwd (stdin_fd, stdout_fd, stderr_fd) in let close fd fd' = match fd with | `FD_move _ | `Dev_null -> Unix.close (match fd' with Some fd' -> fd' | _ -> assert false) | _ -> () in close stdin stdin_fd; close stdout stdout_fd; close stderr stderr_fd; proc external win32_wait_job : Unix.file_descr -> int Lwt_unix.job = "lwt_process_wait_job" let win32_waitproc proc = Lwt_unix.run_job (win32_wait_job proc.fd) >>= fun code -> Lwt.return (proc.id, Lwt_unix.WEXITED code, {Lwt_unix.ru_utime = 0.; Lwt_unix.ru_stime = 0.}) external win32_terminate_process : Unix.file_descr -> int -> unit = "lwt_process_terminate_process" let win32_terminate proc = win32_terminate_process proc.fd 1 let unix_redirect fd redirection = match redirection with | `Keep -> () | `Dev_null -> let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR; Unix.O_KEEPEXEC] 0o666 in Unix.dup2 ~cloexec:false dev_null fd; Unix.close dev_null | `Close -> Unix.close fd | `FD_copy fd' -> Unix.dup2 ~cloexec:false fd' fd | `FD_move fd' -> Unix.dup2 ~cloexec:false fd' fd; Unix.close fd' #if OCAML_VERSION >= (5, 0, 0) external unix_exit : int -> 'a = "caml_unix_exit" #else external unix_exit : int -> 'a = "unix_exit" #endif let unix_spawn ?cwd ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) (prog, args) env = let prog = if prog = "" && Array.length args > 0 then args.(0) else prog in match Lwt_unix.fork () with | 0 -> unix_redirect Unix.stdin stdin; unix_redirect Unix.stdout stdout; unix_redirect Unix.stderr stderr; begin try begin match cwd with | None -> () | Some dir -> Sys.chdir dir end; match env with | None -> Unix.execvp prog args | Some env -> Unix.execvpe prog args env with _ -> (* Do not run at_exit hooks *) unix_exit 127 end | id -> let close = function | `FD_move fd -> Unix.close fd | _ -> () in close stdin; close stdout; close stderr; {id; fd = Unix.stdin} let unix_waitproc proc = Lwt_unix.wait4 [] proc.id let unix_terminate proc = Unix.kill proc.id Sys.sigkill let spawn = if Sys.win32 then win32_spawn else unix_spawn let waitproc = if Sys.win32 then win32_waitproc else unix_waitproc let terminate = if Sys.win32 then win32_terminate else unix_terminate (* +-----------------------------------------------------------------+ | Objects | +-----------------------------------------------------------------+ *) type state = | Running | Exited of Unix.process_status let status (_pid, status, _rusage) = status let rusage (_pid, _status, rusage) = rusage external cast_chan : 'a Lwt_io.channel -> unit Lwt_io.channel = "%identity" (* Transform a channel into a channel that only support closing. *) let ignore_close chan = ignore (Lwt_io.close chan) class virtual common timeout proc channels = let wait = waitproc proc in object(self) val mutable closed = false method pid = proc.id method state = match Lwt.poll wait with | None -> Running | Some (_pid, status, _rusage) -> Exited status method kill signum = if Lwt.state wait = Lwt.Sleep then Unix.kill proc.id signum method terminate = if Lwt.state wait = Lwt.Sleep then terminate proc method close = if closed then self#status else ( closed <- true; Lwt.protected (Lwt.join (List.map Lwt_io.close channels)) >>= fun () -> self#status ) method status = Lwt.protected wait >|= status method rusage = Lwt.protected wait >|= rusage initializer (* Ensure channels are closed when no longer used. *) List.iter (Gc.finalise ignore_close) channels; (* Handle timeout. *) match timeout with | None -> () | Some dt -> ignore ( (* Ignore errors since they can be obtained by self#close. *) Lwt.try_bind (fun () -> Lwt.choose [(Lwt_unix.sleep dt >>= fun () -> Lwt.return_false); (wait >>= fun _ -> Lwt.return_true)]) (function | true -> Lwt.return_unit | false -> self#terminate; self#close >>= fun _ -> Lwt.return_unit) (fun _ -> (* The exception is dropped because it can be obtained with self#close. *) Lwt.return_unit) ) end class process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd = let proc = spawn cmd env ?cwd ?stdin ?stdout ?stderr in object inherit common timeout proc [] end class process_in ?timeout ?env ?cwd ?stdin ?stderr cmd = let stdout_r, stdout_w = Lwt_unix.pipe_in ~cloexec:true () in let proc = spawn cmd env ?cwd ?stdin ~stdout:(`FD_move stdout_w) ?stderr in let stdout = Lwt_io.of_fd ~mode:Lwt_io.input stdout_r in object inherit common timeout proc [cast_chan stdout] method stdout = stdout end class process_out ?timeout ?env ?cwd ?stdout ?stderr cmd = let stdin_r, stdin_w = Lwt_unix.pipe_out ~cloexec:true () in let proc = spawn cmd env ?cwd ~stdin:(`FD_move stdin_r) ?stdout ?stderr in let stdin = Lwt_io.of_fd ~mode:Lwt_io.output stdin_w in object inherit common timeout proc [cast_chan stdin] method stdin = stdin end class process ?timeout ?env ?cwd ?stderr cmd = let stdin_r, stdin_w = Lwt_unix.pipe_out ~cloexec:true () and stdout_r, stdout_w = Lwt_unix.pipe_in ~cloexec:true () in let proc = spawn cmd env ?cwd ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ?stderr in let stdin = Lwt_io.of_fd ~mode:Lwt_io.output stdin_w and stdout = Lwt_io.of_fd ~mode:Lwt_io.input stdout_r in object inherit common timeout proc [cast_chan stdin; cast_chan stdout] method stdin = stdin method stdout = stdout end class process_full ?timeout ?env ?cwd cmd = let stdin_r, stdin_w = Lwt_unix.pipe_out ~cloexec:true () and stdout_r, stdout_w = Lwt_unix.pipe_in ~cloexec:true () and stderr_r, stderr_w = Lwt_unix.pipe_in ~cloexec:true () in let proc = spawn cmd env ?cwd ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ~stderr:(`FD_move stderr_w) in let stdin = Lwt_io.of_fd ~mode:Lwt_io.output stdin_w and stdout = Lwt_io.of_fd ~mode:Lwt_io.input stdout_r and stderr = Lwt_io.of_fd ~mode:Lwt_io.input stderr_r in object inherit common timeout proc [cast_chan stdin; cast_chan stdout; cast_chan stderr] method stdin = stdin method stdout = stdout method stderr = stderr end let open_process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd = new process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd let open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd = new process_in ?timeout ?env ?cwd ?stdin ?stderr cmd let open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd = new process_out ?timeout ?env ?cwd ?stdout ?stderr cmd let open_process ?timeout ?env ?cwd ?stderr cmd = new process ?timeout ?env ?cwd ?stderr cmd let open_process_full ?timeout ?env ?cwd cmd = new process_full ?timeout ?env ?cwd cmd let make_with backend ?timeout ?env ?cwd cmd f = let process = backend ?timeout ?env ?cwd cmd in Lwt.finalize (fun () -> f process) (fun () -> process#close >>= fun _ -> Lwt.return_unit) let with_process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd f = make_with (open_process_none ?stdin ?stdout ?stderr) ?timeout ?env ?cwd cmd f let with_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd f = make_with (open_process_in ?stdin ?stderr) ?timeout ?env ?cwd cmd f let with_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd f = make_with (open_process_out ?stdout ?stderr) ?timeout ?env ?cwd cmd f let with_process ?timeout ?env ?cwd ?stderr cmd f = make_with (open_process ?stderr) ?timeout ?env ?cwd cmd f let with_process_full ?timeout ?env ?cwd cmd f = make_with open_process_full ?timeout ?env ?cwd cmd f (* +-----------------------------------------------------------------+ | High-level functions | +-----------------------------------------------------------------+ *) let exec ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd = (open_process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd)#close let ignore_close ch = ignore (Lwt_io.close ch) let read_opt read ic = Lwt.catch (fun () -> read ic >|= fun x -> Some x) (function | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> Lwt.return_none | exn -> Lwt.reraise exn) [@ocaml.warning "-4"] let recv_chars pr = let ic = pr#stdout in Gc.finalise ignore_close ic; Lwt_stream.from (fun _ -> read_opt Lwt_io.read_char ic >>= fun x -> if x = None then begin Lwt_io.close ic >>= fun () -> Lwt.return x end else Lwt.return x) let recv_lines pr = let ic = pr#stdout in Gc.finalise ignore_close ic; Lwt_stream.from (fun _ -> read_opt Lwt_io.read_line ic >>= fun x -> if x = None then begin Lwt_io.close ic >>= fun () -> Lwt.return x end else Lwt.return x) let recv pr = let ic = pr#stdout in Lwt.finalize (fun () -> Lwt_io.read ic) (fun () -> Lwt_io.close ic) let recv_line pr = let ic = pr#stdout in Lwt.finalize (fun () -> Lwt_io.read_line ic) (fun () -> Lwt_io.close ic) let send f pr data = let oc = pr#stdin in Lwt.finalize (fun () -> f oc data) (fun () -> Lwt_io.close oc) (* Receiving *) let pread ?timeout ?env ?cwd ?stdin ?stderr cmd = recv (open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd) let pread_chars ?timeout ?env ?cwd ?stdin ?stderr cmd = recv_chars (open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd) let pread_line ?timeout ?env ?cwd ?stdin ?stderr cmd = recv_line (open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd) let pread_lines ?timeout ?env ?cwd ?stdin ?stderr cmd = recv_lines (open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd) (* Sending *) let pwrite ?timeout ?env ?cwd ?stdout ?stderr cmd text = send Lwt_io.write (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) text let pwrite_chars ?timeout ?env ?cwd ?stdout ?stderr cmd chars = send Lwt_io.write_chars (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) chars let pwrite_line ?timeout ?env ?cwd ?stdout ?stderr cmd line = send Lwt_io.write_line (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) line let pwrite_lines ?timeout ?env ?cwd ?stdout ?stderr cmd lines = send Lwt_io.write_lines (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) lines (* Mapping *) type 'a map_state = | Init | Save of 'a option Lwt.t | Done (* Monitor the thread [sender] in the stream [st] so write errors are reported. *) let monitor sender st = let sender = sender >|= fun () -> None in let state = ref Init in Lwt_stream.from (fun () -> match !state with | Init -> let getter = Lwt.apply Lwt_stream.get st in let result _ = match Lwt.state sender with | Lwt.Sleep -> (* The sender is still sleeping, behave as the getter. *) getter | Lwt.Return _ -> (* The sender terminated successfully, we are done monitoring it. *) state := Done; getter | Lwt.Fail _ -> (* The sender failed, behave as the sender for this element and save current getter. *) state := Save getter; sender in Lwt.try_bind (fun () -> Lwt.choose [sender; getter]) result result | Save t -> state := Done; t | Done -> Lwt_stream.get st) let pmap ?timeout ?env ?cwd ?stderr cmd text = let pr = open_process ?timeout ?env ?cwd ?stderr cmd in (* Start the sender and getter at the same time. *) let sender = send Lwt_io.write pr text in let getter = recv pr in Lwt.catch (fun () -> (* Wait for both to terminate, returning the result of the getter. *) sender >>= fun () -> getter) (function | Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; Lwt.reraise exn | exn -> Lwt.reraise exn) let pmap_chars ?timeout ?env ?cwd ?stderr cmd chars = let pr = open_process ?timeout ?env ?cwd ?stderr cmd in let sender = send Lwt_io.write_chars pr chars in monitor sender (recv_chars pr) let pmap_line ?timeout ?env ?cwd ?stderr cmd line = let pr = open_process ?timeout ?env ?cwd ?stderr cmd in (* Start the sender and getter at the same time. *) let sender = send Lwt_io.write_line pr line in let getter = recv_line pr in Lwt.catch (fun () -> (* Wait for both to terminate, returning the result of the getter. *) sender >>= fun () -> getter) (function | Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; Lwt.reraise exn | exn -> Lwt.reraise exn) let pmap_lines ?timeout ?env ?cwd ?stderr cmd lines = let pr = open_process ?timeout ?env ?cwd ?stderr cmd in let sender = send Lwt_io.write_lines pr lines in monitor sender (recv_lines pr) lwt-5.9.1/src/unix/lwt_process.mli000066400000000000000000000212221476253734400171730ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Process management *) (** This module allows you to spawn processes and communicate with them. *) type command = string * string array (** A command. The first field is the name of the executable and the second is the list of arguments. For example: {[ ("ls", [|"ls"; "-l"|]) ]} Notes: - if the name is the empty string, then the first argument will be used. You should specify a name only if you do not want the executable to be searched in the PATH. On Windows the only way to enable automatic search in PATH is to pass an empty name. - it is possible to ``inline'' an argument, i.e. split it into multiple arguments. To do that prefix it with ["\000"]. For example: {[ ("", [|"echo"; "\000foo bar"|]) ]} is the same as: {[ ("", [|"echo"; "foo"; "bar"|]) ]} *) val shell : string -> command (** A command executed with the shell. (with ["/bin/sh -c "] on Unix and ["cmd.exe /c "] on Windows). *) (** All the following functions take an optional argument [timeout], in seconds. If specified, after expiration, the process will be sent a {!Unix.sigkill} signal and channels will be closed. When the channels are closed, any pending I/O operations on them (such as {!Lwt_io.read_chars}) fail with exception {!Lwt_io.Channel_closed}. *) (** {2 High-level functions} *) (** {3 Redirections} *) type redirection = [ `Keep (** Point to the same file as in the parent. *) | `Dev_null (** Redirect to [/dev/null] (POSIX) or [nul] (Win32). *) | `Close (** Close the file descriptor. *) | `FD_copy of Unix.file_descr (** Redirect to the file pointed to by [fd]. [fd] remains open in the parent. *) | `FD_move of Unix.file_descr (** Redirect to the file pointed to by [fd]. [fd] is then closed in the parent. *) ] (** File descriptor redirections. These are used with the [~stdin], [~stdout], and [~stderr] arguments below to specify how the standard file descriptors should be redirected in the child process. All optional redirection arguments default to [`Keep]. *) (** {3 Executing} *) val exec : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stdout : redirection -> ?stderr : redirection -> command -> Unix.process_status Lwt.t (** Executes the given command and returns its exit status. *) (** {3 Receiving} *) val pread : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stderr : redirection -> command -> string Lwt.t val pread_chars : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stderr : redirection -> command -> char Lwt_stream.t val pread_line : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stderr : redirection -> command -> string Lwt.t val pread_lines : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stderr : redirection -> command -> string Lwt_stream.t (** {3 Sending} *) val pwrite : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdout : redirection -> ?stderr : redirection -> command -> string -> unit Lwt.t val pwrite_chars : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdout : redirection -> ?stderr : redirection -> command -> char Lwt_stream.t -> unit Lwt.t val pwrite_line : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdout : redirection -> ?stderr : redirection -> command -> string -> unit Lwt.t val pwrite_lines : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdout : redirection -> ?stderr : redirection -> command -> string Lwt_stream.t -> unit Lwt.t (** {3 Mapping} *) val pmap : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stderr : redirection -> command -> string -> string Lwt.t val pmap_chars : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stderr : redirection -> command -> char Lwt_stream.t -> char Lwt_stream.t val pmap_line : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stderr : redirection -> command -> string -> string Lwt.t val pmap_lines : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stderr : redirection -> command -> string Lwt_stream.t -> string Lwt_stream.t (** {2 Spawning processes} *) (** State of a sub-process *) type state = | Running (** The process is still running *) | Exited of Unix.process_status (** The process has exited *) class process_none : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stdout : redirection -> ?stderr : redirection -> command -> object method pid : int (** Pid of the sub-process *) method state : state (** Return the state of the process *) method kill : int -> unit (** [kill signum] sends [signum] to the process if it is still running. *) method terminate : unit (** Terminates the process. It is equivalent to [kill Sys.sigkill] on Unix but also works on Windows (unlike {!Lwt_process.process_none.kill}). *) method status : Unix.process_status Lwt.t (** Threads which wait for the sub-process to exit then returns its exit status *) method rusage : Lwt_unix.resource_usage Lwt.t (** Threads which wait for the sub-process to exit then returns its resource usages *) method close : Unix.process_status Lwt.t (** Closes the process and returns its exit status. This closes all channels used to communicate with the process *) end val open_process_none : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stdout : redirection -> ?stderr : redirection -> command -> process_none val with_process_none : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stdout : redirection -> ?stderr : redirection -> command -> (process_none -> 'a Lwt.t) -> 'a Lwt.t class process_in : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stderr : redirection -> command -> object inherit process_none method stdout : Lwt_io.input_channel (** The standard output of the process *) end val open_process_in : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stderr : redirection -> command -> process_in val with_process_in : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdin : redirection -> ?stderr : redirection -> command -> (process_in -> 'a Lwt.t) -> 'a Lwt.t class process_out : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdout : redirection -> ?stderr : redirection -> command -> object inherit process_none method stdin : Lwt_io.output_channel (** The standard input of the process *) end val open_process_out : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdout : redirection -> ?stderr : redirection -> command -> process_out val with_process_out : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stdout : redirection -> ?stderr : redirection -> command -> (process_out -> 'a Lwt.t) -> 'a Lwt.t class process : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stderr : redirection -> command -> object inherit process_none method stdin : Lwt_io.output_channel method stdout : Lwt_io.input_channel end val open_process : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stderr : redirection -> command -> process val with_process : ?timeout : float -> ?env : string array -> ?cwd : string -> ?stderr : redirection -> command -> (process -> 'a Lwt.t) -> 'a Lwt.t class process_full : ?timeout : float -> ?env : string array -> ?cwd : string -> command -> object inherit process_none method stdin : Lwt_io.output_channel method stdout : Lwt_io.input_channel method stderr : Lwt_io.input_channel end val open_process_full : ?timeout : float -> ?env : string array -> ?cwd : string -> command -> process_full val with_process_full : ?timeout : float -> ?env : string array -> ?cwd : string -> command -> (process_full -> 'a Lwt.t) -> 'a Lwt.t lwt-5.9.1/src/unix/lwt_process_stubs.c000066400000000000000000000111261476253734400200560ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include "lwt_unix.h" #if OCAML_VERSION < 41300 #define CAML_INTERNALS #endif #include #include #include #include static HANDLE get_handle(value opt) { value fd; if (Is_some(opt)) { fd = Some_val(opt); if (Descr_kind_val(fd) == KIND_SOCKET) { win32_maperr(ERROR_INVALID_HANDLE); uerror("CreateProcess", Nothing); return NULL; } else return Handle_val(fd); } else return INVALID_HANDLE_VALUE; } /* Ensures the handle [h] is inheritable. Returns the handle for the child process in [hStd] and in [to_close] if it needs to be closed after CreateProcess. */ static int ensure_inheritable(HANDLE h /* in */, HANDLE * hStd /* out */, HANDLE * to_close /* out */) { DWORD flags; HANDLE hp; if (h == INVALID_HANDLE_VALUE || h == NULL) return 1; if (! GetHandleInformation(h, &flags)) return 0; hp = GetCurrentProcess(); if (! (flags & HANDLE_FLAG_INHERIT)) { if (! DuplicateHandle(hp, h, hp, hStd, 0, TRUE, DUPLICATE_SAME_ACCESS)) return 0; *to_close = *hStd; } else { *hStd = h; } return 1; } CAMLprim value lwt_process_create_process(value prog, value cmdline, value env, value cwd, value fds) { CAMLparam5(prog, cmdline, env, cwd, fds); CAMLlocal1(result); STARTUPINFO si; PROCESS_INFORMATION pi; DWORD flags = 0, err; HANDLE hp, fd0, fd1, fd2; HANDLE to_close0 = INVALID_HANDLE_VALUE, to_close1 = INVALID_HANDLE_VALUE, to_close2 = INVALID_HANDLE_VALUE; fd0 = get_handle(Field(fds, 0)); fd1 = get_handle(Field(fds, 1)); fd2 = get_handle(Field(fds, 2)); err = ERROR_SUCCESS; ZeroMemory(&si, sizeof(si)); ZeroMemory(&pi, sizeof(pi)); si.cb = sizeof(si); si.dwFlags = STARTF_USESTDHANDLES; /* If needed, duplicate the handles fd1, fd2, fd3 to make sure they are inheritable. */ if (! ensure_inheritable(fd0, &si.hStdInput, &to_close0) || ! ensure_inheritable(fd1, &si.hStdOutput, &to_close1) || ! ensure_inheritable(fd2, &si.hStdError, &to_close2)) { err = GetLastError(); goto ret; } #define string_option(opt) \ (Is_block(opt) ? caml_stat_strdup_to_os(String_val(Field(opt, 0))) : NULL) char_os *progs = string_option(prog), *cmdlines = caml_stat_strdup_to_os(String_val(cmdline)), *envs = string_option(env), *cwds = string_option(cwd); #undef string_option flags |= CREATE_UNICODE_ENVIRONMENT; if (! CreateProcess(progs, cmdlines, NULL, NULL, TRUE, flags, envs, cwds, &si, &pi)) { err = GetLastError(); } caml_stat_free(progs); caml_stat_free(cmdlines); caml_stat_free(envs); caml_stat_free(cwds); ret: /* Close the handles if we duplicated them above. */ if (to_close0 != INVALID_HANDLE_VALUE) CloseHandle(to_close0); if (to_close1 != INVALID_HANDLE_VALUE) CloseHandle(to_close1); if (to_close2 != INVALID_HANDLE_VALUE) CloseHandle(to_close2); if (err != ERROR_SUCCESS) { win32_maperr(err); uerror("CreateProcess", Nothing); } CloseHandle(pi.hThread); result = caml_alloc_tuple(2); Store_field(result, 0, Val_int(pi.dwProcessId)); Store_field(result, 1, win_alloc_handle(pi.hProcess)); CAMLreturn(result); } struct job_wait { struct lwt_unix_job job; HANDLE handle; }; static void worker_wait(struct job_wait *job) { WaitForSingleObject(job->handle, INFINITE); } static value result_wait(struct job_wait *job) { DWORD code, error; if (!GetExitCodeProcess(job->handle, &code)) { error = GetLastError(); CloseHandle(job->handle); lwt_unix_free_job(&job->job); win32_maperr(error); uerror("GetExitCodeProcess", Nothing); } CloseHandle(job->handle); lwt_unix_free_job(&job->job); return Val_int(code); } CAMLprim value lwt_process_wait_job(value handle) { LWT_UNIX_INIT_JOB(job, wait, 0); job->handle = Handle_val(handle); return lwt_unix_alloc_job(&(job->job)); } CAMLprim value lwt_process_terminate_process(value handle, value code) { if (!TerminateProcess(Handle_val(handle), Int_val(code))) { win32_maperr(GetLastError()); uerror("TerminateProcess", Nothing); } return Val_unit; } #else /* defined(LWT_ON_WINDOWS) */ /* This is used to suppress a warning from ranlib about the object file having no symbols. */ void lwt_process_dummy_symbol() {} #endif /* defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/lwt_sys.ml000066400000000000000000000020671476253734400161700ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) exception Not_available of string let () = Callback.register_exception "lwt:not-available" (Not_available "") let windows = Sys.win32 type feature = [ `wait4 | `get_cpu | `get_affinity | `set_affinity | `recv_msg | `send_msg | `fd_passing | `get_credentials | `mincore | `madvise | `fdatasync | `libev ] let have = function | `wait4 | `recv_msg | `send_msg | `madvise -> not Sys.win32 | `mincore -> not (Sys.win32 || Sys.cygwin) | `get_cpu -> Lwt_config._HAVE_GETCPU | `get_affinity | `set_affinity -> Lwt_config._HAVE_AFFINITY | `fd_passing -> Lwt_config._HAVE_FD_PASSING | `get_credentials -> Lwt_config._HAVE_GET_CREDENTIALS | `fdatasync -> Lwt_config._HAVE_FDATASYNC | `libev -> Lwt_config._HAVE_LIBEV type byte_order = Little_endian | Big_endian external get_byte_order : unit -> byte_order = "lwt_unix_system_byte_order" let byte_order = get_byte_order () lwt-5.9.1/src/unix/lwt_sys.mli000066400000000000000000000017361476253734400163430ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** System informations. *) exception Not_available of string (** [Not_available(feature)] is an exception that may be raised when a feature is not available on the current system. *) (** Features that can be tested. *) type feature = [ `wait4 | `get_cpu | `get_affinity | `set_affinity | `recv_msg | `send_msg | `fd_passing | `get_credentials | `mincore | `madvise | `fdatasync | `libev ] val have : feature -> bool (** Test whether the given feature is available on the current system. *) type byte_order = Little_endian | Big_endian (** Type of byte order *) val byte_order : byte_order (** The byte order used by the computer running the program. *) val windows : bool [@@ocaml.deprecated " Use Sys.win32."] (** @deprecated Use [Sys.win32]. *) lwt-5.9.1/src/unix/lwt_throttle.ml000066400000000000000000000057241476253734400172220ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix module type S = sig type key type t val create : rate:int -> max:int -> n:int -> t val wait : t -> key -> bool Lwt.t end module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct module MH = Hashtbl.Make(H) type key = H.t type elt = { mutable consumed : int; queue : bool Lwt.u Queue.t; } type t = { rate : int; max : int; (* maximum number of waiting threads *) mutable waiting : int; table : elt MH.t; mutable cleaning : unit Lwt.t option; } let create ~rate ~max ~n = if rate < 1 || max < 1 || n < 0 then invalid_arg "Lwt_throttle.S.create" else { rate = rate; max = max; waiting = 0; table = MH.create n; cleaning = None; } let update_key t key elt (old_waiting,to_run) = let rec update to_run = function | 0 -> 0, Queue.length elt.queue, to_run | i -> try let to_run = (Queue.take elt.queue)::to_run in update to_run (i-1) with | Queue.Empty -> i, 0, to_run in let not_consumed, waiting, to_run = update to_run t.rate in let consumed = t.rate - not_consumed in if consumed = 0 then (* there is no waiting threads for this key: we can clean the table *) MH.remove t.table key else elt.consumed <- consumed; (old_waiting+waiting, to_run) let rec clean_table t = let waiting,to_run = MH.fold (update_key t) t.table (0,[]) in t.waiting <- waiting; if waiting = 0 && to_run = [] then (* the table is empty: we do not need to clean in 1 second *) t.cleaning <- None else launch_cleaning t; List.iter (fun u -> Lwt.wakeup u true) to_run and launch_cleaning t = t.cleaning <- let t = Lwt_unix.sleep 1. >>= fun () -> Lwt.catch (fun () -> clean_table t; Lwt.return_unit) (fun _exn -> (* Not good practice, but not worse than the code it is replacing. *) prerr_endline "internal error"; Printexc.print_backtrace stderr; Lwt.return_unit) in Some t let really_wait t elt = let w,u = Lwt.task () in if t.max > t.waiting then (Queue.add u elt.queue; t.waiting <- succ t.waiting; w) else Lwt.return_false let wait t key = let res = try let elt = MH.find t.table key in if elt.consumed >= t.rate then really_wait t elt else (elt.consumed <- succ elt.consumed; Lwt.return_true) with | Not_found -> let elt = { consumed = 1; queue = Queue.create () } in MH.add t.table key elt; Lwt.return_true in (match t.cleaning with | None -> launch_cleaning t | Some _ -> ()); res end lwt-5.9.1/src/unix/lwt_throttle.mli000066400000000000000000000031031476253734400173600ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Rate limiters. A rate limiter allows generating sets of promises that will be resolved in the future, at a maximum rate of N promises per second. The rate limiters in this module support multiple {e channels}, each given a different key by the user. The rate limit applies to each channel independently. *) module type S = sig type key type t val create : rate:int -> max:int -> n:int -> t (** Creates a rate limiter. @param rate Maximum number of promise resolutions per second, per channel. @param max Maximum number of pending promises allowed at once, over all channels. @param n Initial size of the internal channel hash table. This should be approximately the number of different channels that will be used. *) val wait : t -> key -> bool Lwt.t (** [Lwt_throttle.wait limiter channel] returns a new promise associated with the given rate limiter and channel. If the maximum number of pending promises for [limiter] has {e not} been reached, the promise starts pending. It will be resolved with [true] at some future time, such that the rate limit of [limiter] is not exceeded, with respect to other promises in the same [channel]. If the maximum number of pending promises has been reached, the returned promise is already resolved with [false]. *) end module Make (H : Hashtbl.HashedType) : S with type key = H.t lwt-5.9.1/src/unix/lwt_timeout.ml000066400000000000000000000044441476253734400170410ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) type t = { mutable delay : int; action : unit -> unit; mutable prev : t; mutable next : t } let make delay action = let rec x = { delay = delay; action = action; prev = x; next = x } in x let lst_empty () = make (-1) (fun () -> ()) let lst_remove x = let p = x.prev in let n = x.next in p.next <- n; n.prev <- p; x.next <- x; x.prev <- x let lst_insert p x = let n = p.next in p.next <- x; x.prev <- p; x.next <- n; n.prev <- x let lst_in_list x = x.next != x let lst_is_empty set = set.next == set let lst_peek s = let x = s.next in lst_remove x; x (****) let count = ref 0 let buckets = ref [||] let curr = ref 0 let stopped = ref true let size l = let len = Array.length !buckets in if l >= len then begin let b = Array.init (l + 1) (fun _ -> lst_empty ()) in Array.blit !buckets !curr b 0 (len - !curr); Array.blit !buckets 0 b (len - !curr) !curr; buckets := b; curr := 0; end (****) let handle_exn = ref (fun exn -> !Lwt.async_exception_hook exn) let set_exn_handler f = handle_exn := f let rec loop () = stopped := false; Lwt.bind (Lwt_unix.sleep 1.) (fun () -> let s = !buckets.(!curr) in while not (lst_is_empty s) do let x = lst_peek s in decr count; (*XXX Should probably report any exception *) try x.action () with e when Lwt.Exception_filter.run e -> !handle_exn e done; curr := (!curr + 1) mod (Array.length !buckets); if !count > 0 then loop () else begin stopped := true; Lwt.return_unit end) let start x = let in_list = lst_in_list x in let slot = (!curr + x.delay) mod (Array.length !buckets) in lst_remove x; lst_insert !buckets.(slot) x; if not in_list then begin incr count; if !count = 1 && !stopped then ignore (loop ()) end let create delay action = if delay < 1 then invalid_arg "Lwt_timeout.create"; let x = make delay action in size delay; x let stop x = if lst_in_list x then begin lst_remove x; decr count end let change x delay = if delay < 1 then invalid_arg "Lwt_timeout.change"; x.delay <- delay; size delay; if lst_in_list x then start x lwt-5.9.1/src/unix/lwt_timeout.mli000066400000000000000000000035251476253734400172110ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Cancelable timeouts. *) type t val create : int -> (unit -> unit) -> t (** [Lwt_timeout.create n f] creates a new timeout object with duration [n] seconds. [f] is the {e action}, a function to be called once the timeout expires. [f] should not raise exceptions. The timeout is not started until {!Lwt_timeout.start} is called on it. *) val start : t -> unit (** Starts the given timeout. Starting a timeout that has already been started has the same effect as stopping it, and then restarting it with its original duration. So, suppose you have [timeout] with a duration of three seconds, which was started two seconds ago. The next call to its action is scheduled for one second in the future. Calling [Lwt_timeout.start timeout] at this point cancels this upcoming action call, and schedules a call three seconds from now. *) val stop : t -> unit (** Stops (cancels) the given timeout. *) val change : t -> int -> unit (** Changes the duration of the given timeout. If the timeout has already been started, it is stopped, and restarted with its new duration. This is similar to how {!Lwt_timeout.start} works on a timeout that has already been started. *) val set_exn_handler : (exn -> unit) -> unit (** [Lwt_timeout.set_exn_handler f] sets the handler to be used for exceptions raised by timeout actions. Recall that actions are not allowed to raise exceptions. If they do raise an exception [exn] despite this, [f exn] is called. The default behavior of [f exn], set by [Lwt_timeout] on program startup, is to pass [exn] to [!]{!Lwt.async_exception_hook}. The default behavior of {e that} is to terminate the process. *) lwt-5.9.1/src/unix/lwt_unix.cppo.ml000066400000000000000000002252031476253734400172740ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] open Lwt.Infix (* +-----------------------------------------------------------------+ | Configuration | +-----------------------------------------------------------------+ *) type async_method = | Async_none | Async_detach | Async_switch let default_async_method_var = ref Async_detach let () = try match Sys.getenv "LWT_ASYNC_METHOD" with | "none" -> default_async_method_var := Async_none | "detach" -> default_async_method_var := Async_detach | "switch" -> default_async_method_var := Async_switch | str -> Printf.eprintf "%s: invalid lwt async method: '%s', must be 'none', 'detach' or 'switch'\n%!" (Filename.basename Sys.executable_name) str with Not_found -> () let default_async_method () = !default_async_method_var let set_default_async_method am = default_async_method_var := am let async_method_key = Lwt.new_key () let async_method () = match Lwt.get async_method_key with | Some am -> am | None -> !default_async_method_var let with_async_none f = Lwt.with_value async_method_key (Some Async_none) f let with_async_detach f = Lwt.with_value async_method_key (Some Async_detach) f let with_async_switch f = Lwt.with_value async_method_key (Some Async_switch) f (* +-----------------------------------------------------------------+ | Notifications management | +-----------------------------------------------------------------+ *) (* Informations about a notifier *) type notifier = { notify_handler : unit -> unit; (* The callback *) notify_once : bool; (* Whether to remove the notifier after the reception of the first notification *) } module Notifiers = Hashtbl.Make(struct type t = int let equal (x : int) (y : int) = x = y let hash (x : int) = x end) let notifiers = Notifiers.create 1024 (* See https://github.com/ocsigen/lwt/issues/277 and https://github.com/ocsigen/lwt/pull/278. *) let current_notification_id = ref (0x7FFFFFFF - 1000) let rec find_free_id id = if Notifiers.mem notifiers id then find_free_id (id + 1) else id let make_notification ?(once=false) f = let id = find_free_id (!current_notification_id + 1) in current_notification_id := id; Notifiers.add notifiers id { notify_once = once; notify_handler = f }; id let stop_notification id = Notifiers.remove notifiers id let set_notification id f = let notifier = Notifiers.find notifiers id in Notifiers.replace notifiers id { notifier with notify_handler = f } let call_notification id = match Notifiers.find notifiers id with | exception Not_found -> () | notifier -> if notifier.notify_once then stop_notification id; notifier.notify_handler () (* +-----------------------------------------------------------------+ | Sleepers | +-----------------------------------------------------------------+ *) let sleep delay = let waiter, wakener = Lwt.task () in let ev = Lwt_engine.on_timer delay false (fun ev -> Lwt_engine.stop_event ev; Lwt.wakeup wakener ()) in Lwt.on_cancel waiter (fun () -> Lwt_engine.stop_event ev); waiter let yield = Lwt.pause let auto_yield timeout = let limit = ref (Unix.gettimeofday () +. timeout) in fun () -> let current = Unix.gettimeofday () in if current >= !limit then begin limit := current +. timeout; yield (); end else Lwt.return_unit let auto_pause timeout = let limit = ref (Unix.gettimeofday () +. timeout) in fun () -> let current = Unix.gettimeofday () in if current >= !limit then begin limit := current +. timeout; Lwt.pause (); end else Lwt.return_unit exception Timeout let timeout d = sleep d >>= fun () -> raise Timeout let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()] (* +-----------------------------------------------------------------+ | Jobs | +-----------------------------------------------------------------+ *) type 'a job external start_job : 'a job -> async_method -> bool = "lwt_unix_start_job" (* Starts the given job with given parameters. It returns [true] if the job is already terminated. *) [@@@ocaml.warning "-3"] external check_job : 'a job -> int -> bool = "lwt_unix_check_job" "noalloc" (* Check whether that a job has terminated or not. If it has not yet terminated, it is marked so it will send a notification when it finishes. *) [@@@ocaml.warning "+3"] (* For all running job, a waiter and a function to abort it. *) let jobs = Lwt_sequence.create () let rec abort_jobs exn = match Lwt_sequence.take_opt_l jobs with | Some (_, f) -> f exn; abort_jobs exn | None -> () let cancel_jobs () = abort_jobs Lwt.Canceled let wait_for_jobs () = Lwt.join (Lwt_sequence.fold_l (fun (w, _) l -> w :: l) jobs []) let wrap_result f x = try Result.Ok (f x) with exn when Lwt.Exception_filter.run exn -> Result.Error exn let run_job_aux async_method job result = (* Starts the job. *) if start_job job async_method then (* The job has already terminated, read and return the result immediately. *) Lwt.of_result (result job) else begin (* Thread for the job. *) let waiter, wakener = Lwt.wait () in (* Add the job to the sequence of all jobs. *) let node = Lwt_sequence.add_l ( (waiter >>= fun _ -> Lwt.return_unit), (fun exn -> if Lwt.state waiter = Lwt.Sleep then Lwt.wakeup_exn wakener exn)) jobs in ignore begin (* Create the notification for asynchronous wakeup. *) let id = make_notification ~once:true (fun () -> Lwt_sequence.remove node; let result = result job in if Lwt.state waiter = Lwt.Sleep then Lwt.wakeup_result wakener result) in (* Give the job some time before we fallback to asynchronous notification. *) Lwt.pause () >>= fun () -> (* The job has terminated, send the result immediately. *) if check_job job id then call_notification id; Lwt.return_unit end; waiter end let choose_async_method = function | Some async_method -> async_method | None -> match Lwt.get async_method_key with | Some am -> am | None -> !default_async_method_var [@@@ocaml.warning "-16"] let execute_job ?async_method ~job ~result ~free = let async_method = choose_async_method async_method in run_job_aux async_method job (fun job -> let x = wrap_result result job in free job; x) [@@@ocaml.warning "+16"] external self_result : 'a job -> 'a = "lwt_unix_self_result" (* returns the result of a job using the [result] field of the C job structure. *) external run_job_sync : 'a job -> 'a = "lwt_unix_run_job_sync" (* Exeuctes a job synchronously and returns its result. *) let self_result job = try Result.Ok (self_result job) with exn when Lwt.Exception_filter.run exn -> Result.Error exn let in_retention_test = ref false let retained o = let retained = ref true in Gc.finalise (fun _ -> if !in_retention_test then retained := false) o; in_retention_test := true; retained let run_job ?async_method job = if !in_retention_test then begin Gc.full_major (); in_retention_test := false end; let async_method = choose_async_method async_method in if async_method = Async_none then try Lwt.return (run_job_sync job) with exn when Lwt.Exception_filter.run exn -> Lwt.fail exn else run_job_aux async_method job self_result (* +-----------------------------------------------------------------+ | File descriptor wrappers | +-----------------------------------------------------------------+ *) type state = Opened | Closed | Aborted of exn type file_descr = { fd : Unix.file_descr; (* The underlying unix file descriptor *) mutable state: state; (* The state of the file descriptor *) mutable set_flags : bool; (* Whether to set file flags *) mutable blocking : bool Lwt.t Lazy.t; (* Is the file descriptor in blocking or non-blocking mode *) mutable event_readable : Lwt_engine.event option; (* The event used to check the file descriptor for readability. *) mutable event_writable : Lwt_engine.event option; (* The event used to check the file descriptor for writability. *) hooks_readable : (unit -> unit) Lwt_sequence.t; (* Hooks to call when the file descriptor becomes readable. *) hooks_writable : (unit -> unit) Lwt_sequence.t; (* Hooks to call when the file descriptor becomes writable. *) } [@@@ocaml.warning "-3"] external is_socket : Unix.file_descr -> bool = "lwt_unix_is_socket" "noalloc" [@@@ocaml.warning "+3"] external guess_blocking_job : Unix.file_descr -> bool job = "lwt_unix_guess_blocking_job" let guess_blocking fd = run_job (guess_blocking_job fd) let is_blocking ?blocking ?(set_flags=true) fd = if Sys.win32 then begin if is_socket fd then match blocking, set_flags with | Some state, false -> lazy(Lwt.return state) | Some true, true -> lazy(Unix.clear_nonblock fd; Lwt.return_true) | Some false, true -> lazy(Unix.set_nonblock fd; Lwt.return_false) | None, false -> lazy(Lwt.return_false) | None, true -> lazy(Unix.set_nonblock fd; Lwt.return_false) else match blocking with | Some state -> lazy(Lwt.return state) | None -> lazy(Lwt.return_true) end else begin match blocking, set_flags with | Some state, false -> lazy(Lwt.return state) | Some true, true -> lazy(Unix.clear_nonblock fd; Lwt.return_true) | Some false, true -> lazy(Unix.set_nonblock fd; Lwt.return_false) | None, false -> lazy(guess_blocking fd) | None, true -> lazy(guess_blocking fd >>= function | true -> Unix.clear_nonblock fd; Lwt.return_true | false -> Unix.set_nonblock fd; Lwt.return_false) end let mk_ch ?blocking ?(set_flags=true) fd = { fd = fd; state = Opened; set_flags = set_flags; blocking = is_blocking ?blocking ~set_flags fd; event_readable = None; event_writable = None; hooks_readable = Lwt_sequence.create (); hooks_writable = Lwt_sequence.create (); } let check_descriptor ch = match ch.state with | Opened -> () | Aborted e -> raise e | Closed -> raise (Unix.Unix_error (Unix.EBADF, "check_descriptor", "")) let state ch = ch.state let blocking ch = check_descriptor ch; Lazy.force ch.blocking let set_blocking ?(set_flags=true) ch blocking = check_descriptor ch; ch.set_flags <- set_flags; ch.blocking <- is_blocking ~blocking ~set_flags ch.fd external unix_stub_readable : Unix.file_descr -> bool = "lwt_unix_readable" external unix_stub_writable : Unix.file_descr -> bool = "lwt_unix_writable" let rec unix_readable fd = try if Sys.win32 then Unix.select [fd] [] [] 0.0 <> ([], [], []) else unix_stub_readable fd with Unix.Unix_error (Unix.EINTR, _, _) -> unix_readable fd let rec unix_writable fd = try if Sys.win32 then Unix.select [] [fd] [] 0.0 <> ([], [], []) else unix_stub_writable fd with Unix.Unix_error (Unix.EINTR, _, _) -> unix_writable fd let readable ch = check_descriptor ch; unix_readable ch.fd let writable ch = check_descriptor ch; unix_writable ch.fd let set_state ch st = ch.state <- st let clear_events ch = Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_readable; Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_writable; begin match ch.event_readable with | Some ev -> ch.event_readable <- None; Lwt_engine.stop_event ev | None -> () end; begin match ch.event_writable with | Some ev -> ch.event_writable <- None; Lwt_engine.stop_event ev | None -> () end let abort ch e = if ch.state <> Closed then begin set_state ch (Aborted e); clear_events ch end let unix_file_descr ch = ch.fd let of_unix_file_descr = mk_ch let stdin = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stdin let stdout = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stdout let stderr = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stderr (* +-----------------------------------------------------------------+ | Actions on file descriptors | +-----------------------------------------------------------------+ *) type io_event = Read | Write exception Retry exception Retry_write exception Retry_read type 'a outcome = | Success of 'a | Exn of exn | Requeued of io_event (* Wait a bit, then stop events that are no more used. *) let stop_events ch = Lwt.on_success (Lwt.pause ()) (fun () -> if Lwt_sequence.is_empty ch.hooks_readable then begin match ch.event_readable with | Some ev -> ch.event_readable <- None; Lwt_engine.stop_event ev | None -> () end; if Lwt_sequence.is_empty ch.hooks_writable then begin match ch.event_writable with | Some ev -> ch.event_writable <- None; Lwt_engine.stop_event ev | None -> () end) let register_readable ch = if ch.event_readable = None then ch.event_readable <- Some(Lwt_engine.on_readable ch.fd (fun _ -> Lwt_sequence.iter_l (fun f -> f ()) ch.hooks_readable)) let register_writable ch = if ch.event_writable = None then ch.event_writable <- Some(Lwt_engine.on_writable ch.fd (fun _ -> Lwt_sequence.iter_l (fun f -> f ()) ch.hooks_writable)) (* Retry a queued syscall, [wakener] is the thread to wakeup if the action succeeds: *) let rec retry_syscall node event ch wakener action = let res = try check_descriptor ch; Success(action ()) with | Retry | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Sys_blocked_io -> (* EINTR because we are catching SIG_CHLD hence the system call might be interrupted to handle the signal; this lets us restart the system call eventually. *) Requeued event | Retry_read -> Requeued Read | Retry_write -> Requeued Write | e when Lwt.Exception_filter.run e -> Exn e in match res with | Success v -> Lwt_sequence.remove !node; stop_events ch; Lwt.wakeup wakener v | Exn e -> Lwt_sequence.remove !node; stop_events ch; Lwt.wakeup_exn wakener e | Requeued event' -> if event <> event' then begin Lwt_sequence.remove !node; stop_events ch; match event' with | Read -> node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable ; register_readable ch | Write -> node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; register_writable ch end let dummy = Lwt_sequence.add_r ignore (Lwt_sequence.create ()) let register_action event ch action = let waiter, wakener = Lwt.task () in match event with | Read -> let node = ref dummy in node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable; Lwt.on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); register_readable ch; waiter | Write -> let node = ref dummy in node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; Lwt.on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); register_writable ch; waiter (* Wraps a system call *) let wrap_syscall event ch action = check_descriptor ch; Lazy.force ch.blocking >>= fun blocking -> try if not blocking || (event = Read && unix_readable ch.fd) || (event = Write && unix_writable ch.fd) then Lwt.return (action ()) else register_action event ch action with | Retry | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Sys_blocked_io -> (* The action could not be completed immediately, register it: *) register_action event ch action | Retry_read -> register_action Read ch action | Retry_write -> register_action Write ch action | e when Lwt.Exception_filter.run e -> Lwt.reraise e (* +-----------------------------------------------------------------+ | Basic file input/output | +-----------------------------------------------------------------+ *) type open_flag = Unix.open_flag = | O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE | O_CLOEXEC | O_KEEPEXEC external open_job : string -> Unix.open_flag list -> int -> (Unix.file_descr * bool) job = "lwt_unix_open_job" let openfile name flags perms = if Sys.win32 then Lwt.return (of_unix_file_descr (Unix.openfile name flags perms)) else run_job (open_job name flags perms) >>= fun (fd, blocking) -> Lwt.return (of_unix_file_descr ~blocking fd) external close_job : Unix.file_descr -> unit job = "lwt_unix_close_job" let close ch = if ch.state = Closed then check_descriptor ch; set_state ch Closed; clear_events ch; if Sys.win32 then Lwt.return (Unix.close ch.fd) else run_job (close_job ch.fd) type bigarray = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t let wait_read ch = Lwt.catch (fun () -> if readable ch then Lwt.return_unit else register_action Read ch ignore) Lwt.reraise external stub_read : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_read" external read_job : Unix.file_descr -> Bytes.t -> int -> int -> int job = "lwt_unix_read_job" external stub_pread : Unix.file_descr -> Bytes.t -> file_offset:int -> int -> int -> int = "lwt_unix_pread" external pread_job : Unix.file_descr -> Bytes.t -> file_offset:int -> int -> int -> int job = "lwt_unix_pread_job" let read ch buf pos len = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.read" else Lazy.force ch.blocking >>= function | true -> wait_read ch >>= fun () -> run_job (read_job ch.fd buf pos len) | false -> wrap_syscall Read ch (fun () -> stub_read ch.fd buf pos len) let pread ch buf ~file_offset pos len = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.pread" else Lazy.force ch.blocking >>= function | true -> wait_read ch >>= fun () -> run_job (pread_job ch.fd buf ~file_offset pos len) | false -> wrap_syscall Read ch (fun () -> stub_pread ch.fd buf ~file_offset pos len) external stub_read_bigarray : Unix.file_descr -> bigarray -> int -> int -> int = "lwt_unix_bytes_read" external read_bigarray_job : Unix.file_descr -> bigarray -> int -> int -> int job = "lwt_unix_bytes_read_job" let read_bigarray function_name fd buf pos len = if pos < 0 || len < 0 || pos > Bigarray.Array1.dim buf - len then invalid_arg function_name else blocking fd >>= function | true -> wait_read fd >>= fun () -> run_job (read_bigarray_job (unix_file_descr fd) buf pos len) | false -> wrap_syscall Read fd (fun () -> stub_read_bigarray (unix_file_descr fd) buf pos len) let wait_write ch = Lwt.catch (fun () -> if writable ch then Lwt.return_unit else register_action Write ch ignore) Lwt.reraise external stub_write : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_write" external write_job : Unix.file_descr -> Bytes.t -> int -> int -> int job = "lwt_unix_write_job" external stub_pwrite : Unix.file_descr -> Bytes.t -> file_offset:int -> int -> int -> int = "lwt_unix_pwrite" external pwrite_job : Unix.file_descr -> Bytes.t -> file_offset:int -> int -> int -> int job = "lwt_unix_pwrite_job" let write ch buf pos len = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.write" else Lazy.force ch.blocking >>= function | true -> wait_write ch >>= fun () -> run_job (write_job ch.fd buf pos len) | false -> wrap_syscall Write ch (fun () -> stub_write ch.fd buf pos len) let pwrite ch buf ~file_offset pos len = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.pwrite" else Lazy.force ch.blocking >>= function | true -> wait_write ch >>= fun () -> run_job (pwrite_job ch.fd buf ~file_offset pos len) | false -> wrap_syscall Write ch (fun () -> stub_pwrite ch.fd buf ~file_offset pos len) let write_string ch buf pos len = let buf = Bytes.unsafe_of_string buf in write ch buf pos len let pwrite_string ch buf ~file_offset pos len = let buf = Bytes.unsafe_of_string buf in pwrite ch buf ~file_offset pos len external stub_write_bigarray : Unix.file_descr -> bigarray -> int -> int -> int = "lwt_unix_bytes_write" external write_bigarray_job : Unix.file_descr -> bigarray -> int -> int -> int job = "lwt_unix_bytes_write_job" let write_bigarray function_name fd buf pos len = if pos < 0 || len < 0 || pos > Bigarray.Array1.dim buf - len then invalid_arg function_name else blocking fd >>= function | true -> wait_write fd >>= fun () -> run_job (write_bigarray_job (unix_file_descr fd) buf pos len) | false -> wrap_syscall Write fd (fun () -> stub_write_bigarray (unix_file_descr fd) buf pos len) module IO_vectors = struct type _bigarray = bigarray type buffer = | Bytes of bytes | Bigarray of _bigarray type io_vector = {buffer : buffer; mutable offset : int; mutable length : int} (* This representation does not give constant amortized time append across all possible operation sequences, but it does for expected typical usage, in which some number of append operations is followed by some number of flatten operations. *) type t = {mutable prefix : io_vector list; mutable reversed_suffix : io_vector list; mutable count : int} let create () = {prefix = []; reversed_suffix = []; count = 0} let byte_count {prefix; reversed_suffix; _} = let count_buff = List.fold_left (fun acc {length; _} -> acc + length) 0 in count_buff prefix + count_buff reversed_suffix let append io_vectors io_vector = io_vectors.reversed_suffix <- io_vector::io_vectors.reversed_suffix; io_vectors.count <- io_vectors.count + 1 let append_bytes io_vectors buffer offset length = append io_vectors {buffer = Bytes buffer; offset; length} let append_bigarray io_vectors buffer offset length = append io_vectors {buffer = Bigarray buffer; offset; length} let flatten io_vectors = match io_vectors.reversed_suffix with | [] -> () | _ -> io_vectors.prefix <- io_vectors.prefix @ (List.rev io_vectors.reversed_suffix); io_vectors.reversed_suffix <- [] let drop io_vectors count = flatten io_vectors; let rec loop count prefix = if count <= 0 then prefix else match prefix with | [] -> [] | {length; _}::rest when length <= count -> io_vectors.count <- io_vectors.count - 1; loop (count - length) rest | first::_ -> first.offset <- first.offset + count; first.length <- first.length - count; prefix in io_vectors.prefix <- loop count io_vectors.prefix let is_empty io_vectors = flatten io_vectors; let rec loop = function | [] -> true | {length = 0; _}::rest -> loop rest | _ -> false in loop io_vectors.prefix external stub_iov_max : unit -> int option = "lwt_unix_iov_max" let system_limit = if Sys.win32 then None else stub_iov_max () let check tag io_vector = let buffer_length = match io_vector.buffer with | Bytes s -> Bytes.length s | Bigarray a -> Bigarray.Array1.dim a in if io_vector.length < 0 || io_vector.offset < 0 || io_vector.offset + io_vector.length > buffer_length then invalid_arg tag end (* Flattens the I/O vectors into a single list, checks their bounds, and evaluates to the minimum of: the number of vectors and the system's IOV_MAX. *) let check_io_vectors function_name io_vectors = IO_vectors.flatten io_vectors; List.iter (IO_vectors.check function_name) io_vectors.IO_vectors.prefix; match IO_vectors.system_limit with | Some limit when io_vectors.IO_vectors.count > limit -> limit | _ -> io_vectors.IO_vectors.count external stub_readv : Unix.file_descr -> IO_vectors.io_vector list -> int -> int = "lwt_unix_readv" external readv_job : Unix.file_descr -> IO_vectors.t -> int -> int job = "lwt_unix_readv_job" let readv fd io_vectors = let count = check_io_vectors "Lwt_unix.readv" io_vectors in if Sys.win32 then match io_vectors.IO_vectors.prefix with | [] -> Lwt.return 0 | first::_ -> match first.buffer with | Bytes buffer -> read fd buffer first.offset first.length | Bigarray buffer -> read_bigarray "Lwt_unix.readv" fd buffer first.offset first.length else Lazy.force fd.blocking >>= function | true -> wait_read fd >>= fun () -> run_job (readv_job fd.fd io_vectors count) | false -> wrap_syscall Read fd (fun () -> stub_readv fd.fd io_vectors.IO_vectors.prefix count) external stub_writev : Unix.file_descr -> IO_vectors.io_vector list -> int -> int = "lwt_unix_writev" external writev_job : Unix.file_descr -> IO_vectors.t -> int -> int job = "lwt_unix_writev_job" let writev fd io_vectors = let count = check_io_vectors "Lwt_unix.writev" io_vectors in if Sys.win32 then match io_vectors.IO_vectors.prefix with | [] -> Lwt.return 0 | first::_ -> match first.buffer with | Bytes buffer -> write fd buffer first.offset first.length | Bigarray buffer -> write_bigarray "Lwt_unix.writev" fd buffer first.offset first.length else Lazy.force fd.blocking >>= function | true -> wait_write fd >>= fun () -> run_job (writev_job fd.fd io_vectors count) | false -> wrap_syscall Write fd (fun () -> stub_writev fd.fd io_vectors.IO_vectors.prefix count) (* +-----------------------------------------------------------------+ | Seeking and truncating | +-----------------------------------------------------------------+ *) type seek_command = Unix.seek_command = | SEEK_SET | SEEK_CUR | SEEK_END external lseek_job : Unix.file_descr -> int -> Unix.seek_command -> int job = "lwt_unix_lseek_job" let lseek ch offset whence = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.lseek ch.fd offset whence) else run_job (lseek_job ch.fd offset whence) external truncate_job : string -> int -> unit job = "lwt_unix_truncate_job" let truncate name offset = if Sys.win32 then Lwt.return (Unix.truncate name offset) else run_job (truncate_job name offset) external ftruncate_job : Unix.file_descr -> int -> unit job = "lwt_unix_ftruncate_job" let ftruncate ch offset = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.ftruncate ch.fd offset) else run_job (ftruncate_job ch.fd offset) (* +-----------------------------------------------------------------+ | File system synchronisation | +-----------------------------------------------------------------+ *) external fdatasync_job : Unix.file_descr -> unit job = "lwt_unix_fdatasync_job" let fdatasync ch = check_descriptor ch; run_job (fdatasync_job ch.fd) external fsync_job : Unix.file_descr -> unit job = "lwt_unix_fsync_job" let fsync ch = check_descriptor ch; run_job (fsync_job ch.fd) (* +-----------------------------------------------------------------+ | File status | +-----------------------------------------------------------------+ *) type file_perm = Unix.file_perm type file_kind = Unix.file_kind = | S_REG | S_DIR | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK type stats = Unix.stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int; st_atime : float; st_mtime : float; st_ctime : float; } external stat_job : string -> Unix.stats job = "lwt_unix_stat_job" let stat name = if Sys.win32 then Lwt.return (Unix.stat name) else run_job (stat_job name) external lstat_job : string -> Unix.stats job = "lwt_unix_lstat_job" let lstat name = if Sys.win32 then Lwt.return (Unix.lstat name) else run_job (lstat_job name) external fstat_job : Unix.file_descr -> Unix.stats job = "lwt_unix_fstat_job" let fstat ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.fstat ch.fd) else run_job (fstat_job ch.fd) let file_exists name = Lwt.try_bind (fun () -> stat name) (fun _ -> Lwt.return_true) (fun e -> match e with | Unix.Unix_error _ -> Lwt.return_false | _ -> Lwt.reraise e) [@ocaml.warning "-4"] external utimes_job : string -> float -> float -> unit job = "lwt_unix_utimes_job" let utimes path atime mtime = if Sys.win32 then Lwt.return (Unix.utimes path atime mtime) else run_job (utimes_job path atime mtime) external isatty_job : Unix.file_descr -> bool job = "lwt_unix_isatty_job" let isatty ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.isatty ch.fd) else run_job (isatty_job ch.fd) (* +-----------------------------------------------------------------+ | File operations on large files | +-----------------------------------------------------------------+ *) module LargeFile = struct type stats = Unix.LargeFile.stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int64; st_atime : float; st_mtime : float; st_ctime : float; } external lseek_64_job : Unix.file_descr -> int64 -> Unix.seek_command -> int64 job = "lwt_unix_lseek_64_job" let lseek ch offset whence = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.LargeFile.lseek ch.fd offset whence) else run_job (lseek_64_job ch.fd offset whence) external truncate_64_job : string -> int64 -> unit job = "lwt_unix_truncate_64_job" let truncate name offset = if Sys.win32 then Lwt.return (Unix.LargeFile.truncate name offset) else run_job (truncate_64_job name offset) external ftruncate_64_job : Unix.file_descr -> int64 -> unit job = "lwt_unix_ftruncate_64_job" let ftruncate ch offset = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.LargeFile.ftruncate ch.fd offset) else run_job (ftruncate_64_job ch.fd offset) external stat_job : string -> Unix.LargeFile.stats job = "lwt_unix_stat_64_job" let stat name = if Sys.win32 then Lwt.return (Unix.LargeFile.stat name) else run_job (stat_job name) external lstat_job : string -> Unix.LargeFile.stats job = "lwt_unix_lstat_64_job" let lstat name = if Sys.win32 then Lwt.return (Unix.LargeFile.lstat name) else run_job (lstat_job name) external fstat_job : Unix.file_descr -> Unix.LargeFile.stats job = "lwt_unix_fstat_64_job" let fstat ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.LargeFile.fstat ch.fd) else run_job (fstat_job ch.fd) let file_exists name = Lwt.try_bind (fun () -> stat name) (fun _ -> Lwt.return_true) (fun e -> match e with | Unix.Unix_error _ -> Lwt.return_false | _ -> Lwt.reraise e) [@ocaml.warning "-4"] end (* +-----------------------------------------------------------------+ | Operations on file names | +-----------------------------------------------------------------+ *) external unlink_job : string -> unit job = "lwt_unix_unlink_job" let unlink name = if Sys.win32 then Lwt.return (Unix.unlink name) else run_job (unlink_job name) external rename_job : string -> string -> unit job = "lwt_unix_rename_job" let rename name1 name2 = if Sys.win32 then Lwt.return (Unix.rename name1 name2) else run_job (rename_job name1 name2) external link_job : string -> string -> unit job = "lwt_unix_link_job" let link oldpath newpath = if Sys.win32 then Lwt.return (Unix.link oldpath newpath) else run_job (link_job oldpath newpath) (* +-----------------------------------------------------------------+ | File permissions and ownership | +-----------------------------------------------------------------+ *) external chmod_job : string -> int -> unit job = "lwt_unix_chmod_job" let chmod name mode = if Sys.win32 then Lwt.return (Unix.chmod name mode) else run_job (chmod_job name mode) external fchmod_job : Unix.file_descr -> int -> unit job = "lwt_unix_fchmod_job" let fchmod ch mode = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.fchmod ch.fd mode) else run_job (fchmod_job ch.fd mode) external chown_job : string -> int -> int -> unit job = "lwt_unix_chown_job" let chown name uid gid = if Sys.win32 then Lwt.return (Unix.chown name uid gid) else run_job (chown_job name uid gid) external fchown_job : Unix.file_descr -> int -> int -> unit job = "lwt_unix_fchown_job" let fchown ch uid gid = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.fchown ch.fd uid gid) else run_job (fchown_job ch.fd uid gid) type access_permission = Unix.access_permission = | R_OK | W_OK | X_OK | F_OK external access_job : string -> Unix.access_permission list -> unit job = "lwt_unix_access_job" let access name mode = if Sys.win32 then Lwt.return (Unix.access name mode) else run_job (access_job name mode) (* +-----------------------------------------------------------------+ | Operations on file descriptors | +-----------------------------------------------------------------+ *) let dup ?cloexec ch = check_descriptor ch; let fd = Unix.dup ?cloexec ch.fd in { fd = fd; state = Opened; set_flags = ch.set_flags; blocking = if ch.set_flags then lazy(Lazy.force ch.blocking >>= function blocking -> Lazy.force (is_blocking ~blocking fd)) else ch.blocking; event_readable = None; event_writable = None; hooks_readable = Lwt_sequence.create (); hooks_writable = Lwt_sequence.create (); } let dup2 ?cloexec ch1 ch2 = check_descriptor ch1; Unix.dup2 ?cloexec ch1.fd ch2.fd; ch2.set_flags <- ch1.set_flags; ch2.blocking <- ( if ch2.set_flags then lazy(Lazy.force ch1.blocking >>= function blocking -> Lazy.force (is_blocking ~blocking ch2.fd)) else ch1.blocking ) let set_close_on_exec ch = check_descriptor ch; Unix.set_close_on_exec ch.fd let clear_close_on_exec ch = check_descriptor ch; Unix.clear_close_on_exec ch.fd (* +-----------------------------------------------------------------+ | Directories | +-----------------------------------------------------------------+ *) external mkdir_job : string -> int -> unit job = "lwt_unix_mkdir_job" let mkdir name perms = if Sys.win32 then Lwt.return (Unix.mkdir name perms) else run_job (mkdir_job name perms) external rmdir_job : string -> unit job = "lwt_unix_rmdir_job" let rmdir name = if Sys.win32 then Lwt.return (Unix.rmdir name) else run_job (rmdir_job name) external chdir_job : string -> unit job = "lwt_unix_chdir_job" let chdir name = if Sys.win32 then Lwt.return (Unix.chdir name) else run_job (chdir_job name) external getcwd_job : unit -> string job = "lwt_unix_getcwd_job" let getcwd () = if Sys.win32 then Lwt.return (Unix.getcwd ()) else run_job (getcwd_job ()) external chroot_job : string -> unit job = "lwt_unix_chroot_job" let chroot name = if Sys.win32 then Lwt.return (Unix.chroot name) else run_job (chroot_job name) type dir_handle = Unix.dir_handle external opendir_job : string -> Unix.dir_handle job = "lwt_unix_opendir_job" let opendir name = if Sys.win32 then Lwt.return (Unix.opendir name) else run_job (opendir_job name) external valid_dir : Unix.dir_handle -> bool = "lwt_unix_valid_dir" external readdir_job : Unix.dir_handle -> string job = "lwt_unix_readdir_job" let readdir handle = if Sys.win32 then Lwt.return (Unix.readdir handle) else if valid_dir handle then run_job (readdir_job handle) else Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.readdir", ""))) external readdir_n_job : Unix.dir_handle -> int -> string array job = "lwt_unix_readdir_n_job" let readdir_n handle count = if count < 0 then Lwt.fail (Invalid_argument "Lwt_unix.readdir_n") else if Sys.win32 then let array = Array.make count "" in let rec fill i = if i = count then Lwt.return array else match array.(i) <- Unix.readdir handle with | exception End_of_file -> Lwt.return (Array.sub array 0 i) | () -> fill (i + 1) in fill 0 else if valid_dir handle then run_job (readdir_n_job handle count) else Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.readdir_n", ""))) external rewinddir_job : Unix.dir_handle -> unit job = "lwt_unix_rewinddir_job" let rewinddir handle = if Sys.win32 then Lwt.return (Unix.rewinddir handle) else if valid_dir handle then run_job (rewinddir_job handle) else Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.rewinddir", ""))) external closedir_job : Unix.dir_handle -> unit job = "lwt_unix_closedir_job" external invalidate_dir : Unix.dir_handle -> unit = "lwt_unix_invalidate_dir" let closedir handle = if Sys.win32 then Lwt.return (Unix.closedir handle) else if valid_dir handle then run_job (closedir_job handle) >>= fun () -> invalidate_dir handle; Lwt.return_unit else Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.closedir", ""))) type list_directory_state = | LDS_not_started | LDS_listing of Unix.dir_handle | LDS_done let cleanup_dir_handle state = match !state with | LDS_listing handle -> ignore (closedir handle) | LDS_not_started | LDS_done -> () let files_of_directory path = let chunk_size = 1024 in let state = ref LDS_not_started in Lwt_stream.concat (Lwt_stream.from (fun () -> match !state with | LDS_not_started -> opendir path >>= fun handle -> Lwt.catch (fun () -> readdir_n handle chunk_size) (fun exn -> closedir handle >>= fun () -> Lwt.reraise exn) >>= fun entries -> if Array.length entries < chunk_size then begin state := LDS_done; closedir handle >>= fun () -> Lwt.return (Some(Lwt_stream.of_array entries)) end else begin state := LDS_listing handle; Gc.finalise cleanup_dir_handle state; Lwt.return (Some(Lwt_stream.of_array entries)) end | LDS_listing handle -> Lwt.catch (fun () -> readdir_n handle chunk_size) (fun exn -> closedir handle >>= fun () -> Lwt.reraise exn) >>= fun entries -> if Array.length entries < chunk_size then begin state := LDS_done; closedir handle >>= fun () -> Lwt.return (Some(Lwt_stream.of_array entries)) end else Lwt.return (Some(Lwt_stream.of_array entries)) | LDS_done -> Lwt.return_none)) (* +-----------------------------------------------------------------+ | Pipes and redirections | +-----------------------------------------------------------------+ *) let pipe ?cloexec () = let (out_fd, in_fd) = Unix.pipe ?cloexec () in (mk_ch ~blocking:Sys.win32 out_fd, mk_ch ~blocking:Sys.win32 in_fd) let pipe_in ?cloexec () = let (out_fd, in_fd) = Unix.pipe ?cloexec () in (mk_ch ~blocking:Sys.win32 out_fd, in_fd) let pipe_out ?cloexec () = let (out_fd, in_fd) = Unix.pipe ?cloexec () in (out_fd, mk_ch ~blocking:Sys.win32 in_fd) external mkfifo_job : string -> int -> unit job = "lwt_unix_mkfifo_job" let mkfifo name perms = if Sys.win32 then Lwt.return (Unix.mkfifo name perms) else run_job (mkfifo_job name perms) (* +-----------------------------------------------------------------+ | Symbolic links | +-----------------------------------------------------------------+ *) external symlink_job : string -> string -> unit job = "lwt_unix_symlink_job" let symlink ?to_dir name1 name2 = if Sys.win32 then Lwt.return (Unix.symlink ?to_dir name1 name2) else run_job (symlink_job name1 name2) external readlink_job : string -> string job = "lwt_unix_readlink_job" let readlink name = if Sys.win32 then Lwt.return (Unix.readlink name) else run_job (readlink_job name) (* +-----------------------------------------------------------------+ | Locking | +-----------------------------------------------------------------+ *) type lock_command = Unix.lock_command = | F_ULOCK | F_LOCK | F_TLOCK | F_TEST | F_RLOCK | F_TRLOCK external lockf_job : Unix.file_descr -> Unix.lock_command -> int -> unit job = "lwt_unix_lockf_job" let lockf ch cmd size = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.lockf ch.fd cmd size) else run_job (lockf_job ch.fd cmd size) (* +-----------------------------------------------------------------+ | User id, group id | +-----------------------------------------------------------------+ *) type passwd_entry = Unix.passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string } type group_entry = Unix.group_entry = { gr_name : string; gr_passwd : string; gr_gid : int; gr_mem : string array } external getlogin_job : unit -> string job = "lwt_unix_getlogin_job" let getlogin () = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getlogin ()) else run_job (getlogin_job ()) external getpwnam_job : string -> Unix.passwd_entry job = "lwt_unix_getpwnam_job" let getpwnam name = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getpwnam name) else run_job (getpwnam_job name) external getgrnam_job : string -> Unix.group_entry job = "lwt_unix_getgrnam_job" let getgrnam name = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getgrnam name) else run_job (getgrnam_job name) external getpwuid_job : int -> Unix.passwd_entry job = "lwt_unix_getpwuid_job" let getpwuid uid = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getpwuid uid) else run_job (getpwuid_job uid) external getgrgid_job : int -> Unix.group_entry job = "lwt_unix_getgrgid_job" let getgrgid gid = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getgrgid gid) else run_job (getgrgid_job gid) (* +-----------------------------------------------------------------+ | Sockets | +-----------------------------------------------------------------+ *) type msg_flag = Unix.msg_flag = | MSG_OOB | MSG_DONTROUTE | MSG_PEEK external stub_recv : Unix.file_descr -> Bytes.t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_recv" let recv ch buf pos len flags = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.recv" else let do_recv = if Sys.win32 then Unix.recv else stub_recv in wrap_syscall Read ch (fun () -> do_recv ch.fd buf pos len flags) external stub_send : Unix.file_descr -> Bytes.t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_send" let send ch buf pos len flags = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.send" else let do_send = if Sys.win32 then Unix.send else stub_send in wrap_syscall Write ch (fun () -> do_send ch.fd buf pos len flags) external stub_recvfrom : Unix.file_descr -> Bytes.t -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_recvfrom" let recvfrom ch buf pos len flags = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.recvfrom" else let do_recvfrom = if Sys.win32 then Unix.recvfrom else stub_recvfrom in wrap_syscall Read ch (fun () -> do_recvfrom ch.fd buf pos len flags) external stub_sendto : Unix.file_descr -> Bytes.t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_sendto_byte" "lwt_unix_sendto" let sendto ch buf pos len flags addr = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.sendto" else let do_sendto = if Sys.win32 then Unix.sendto else stub_sendto in wrap_syscall Write ch (fun () -> do_sendto ch.fd buf pos len flags addr) external stub_recv_msg : Unix.file_descr -> int -> IO_vectors.io_vector list -> int * Unix.file_descr list = "lwt_unix_recv_msg" let recv_msg ~socket ~io_vectors = let count = check_io_vectors "Lwt_unix.recv_msg" io_vectors in wrap_syscall Read socket (fun () -> stub_recv_msg socket.fd count io_vectors.IO_vectors.prefix) external stub_send_msg : Unix.file_descr -> int -> IO_vectors.io_vector list -> int -> Unix.file_descr list -> Unix.sockaddr option -> int = "lwt_unix_send_msg_byte" "lwt_unix_send_msg" let send_msg ~socket ~io_vectors ~fds = let vector_count = check_io_vectors "Lwt_unix.send_msg" io_vectors in let fd_count = List.length fds in wrap_syscall Write socket (fun () -> stub_send_msg socket.fd vector_count io_vectors.IO_vectors.prefix fd_count fds None) let send_msgto ~socket ~io_vectors ~fds ~dest = let vector_count = check_io_vectors "Lwt_unix.send_msgto" io_vectors in let fd_count = List.length fds in wrap_syscall Write socket (fun () -> stub_send_msg socket.fd vector_count io_vectors.IO_vectors.prefix fd_count fds (Some dest)) type inet_addr = Unix.inet_addr type socket_domain = Unix.socket_domain = | PF_UNIX | PF_INET | PF_INET6 type socket_type = Unix.socket_type = | SOCK_STREAM | SOCK_DGRAM | SOCK_RAW | SOCK_SEQPACKET type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int let socket ?cloexec dom typ proto = let s = Unix.socket ?cloexec dom typ proto in mk_ch ~blocking:false s type shutdown_command = Unix.shutdown_command = | SHUTDOWN_RECEIVE | SHUTDOWN_SEND | SHUTDOWN_ALL let shutdown ch shutdown_command = check_descriptor ch; Unix.shutdown ch.fd shutdown_command external stub_socketpair : ?cloexec:bool -> socket_domain -> socket_type -> int -> Unix.file_descr * Unix.file_descr = "lwt_unix_socketpair_stub" let socketpair ?cloexec dom typ proto = let (s1, s2) = #if OCAML_VERSION >= (4, 14, 0) if Sys.win32 && (dom <> Unix.PF_UNIX) then stub_socketpair ?cloexec dom typ proto else Unix.socketpair ?cloexec dom typ proto in #else if Sys.win32 then stub_socketpair ?cloexec dom typ proto else begin let (s1, s2) = Unix.socketpair dom typ proto in if cloexec = Some true then begin Unix.set_close_on_exec s1; Unix.set_close_on_exec s2 end; (s1, s2) end in #endif (mk_ch ~blocking:false s1, mk_ch ~blocking:false s2) external accept4 : ?cloexec:bool -> nonblock:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr = "lwt_unix_accept4" let accept_and_set_nonblock ?cloexec ch_fd = if Lwt_config._HAVE_ACCEPT4 then let (fd, addr) = accept4 ?cloexec ~nonblock:true ch_fd in (mk_ch ~blocking:false ~set_flags:false fd, addr) else let (fd, addr) = Unix.accept ?cloexec ch_fd in (mk_ch ~blocking:false fd, addr) let accept ?cloexec ch = wrap_syscall Read ch (fun _ -> accept_and_set_nonblock ?cloexec ch.fd) let accept_n ?cloexec ch n = let l = ref [] in Lazy.force ch.blocking >>= fun blocking -> Lwt.catch (fun () -> wrap_syscall Read ch begin fun () -> begin try for _i = 1 to n do if blocking && not (unix_readable ch.fd) then raise Retry; l := accept_and_set_nonblock ?cloexec ch.fd :: !l done with | (Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Retry) when !l <> [] -> (* Ignore blocking errors if we have at least one file-descriptor: *) () end; (List.rev !l, None) end) (fun exn -> Lwt.return (List.rev !l, Some exn)) let connect ch addr = if Sys.win32 then (* [in_progress] tell whether connection has started but not terminated: *) let in_progress = ref false in wrap_syscall Write ch begin fun () -> if !in_progress then (* Nothing works without this test and i have no idea why... *) if writable ch then try Unix.connect ch.fd addr with | Unix.Unix_error (Unix.EISCONN, _, _) -> (* This is the windows way of telling that the connection has completed. *) () else raise Retry else try Unix.connect ch.fd addr with | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> in_progress := true; raise Retry end else (* [in_progress] tell whether connection has started but not terminated: *) let in_progress = ref false in wrap_syscall Write ch begin fun () -> if !in_progress then (* If the connection is in progress, [getsockopt_error] tells whether it succceed: *) match Unix.getsockopt_error ch.fd with | None -> (* The socket is connected *) () | Some err -> (* An error happened: *) raise (Unix.Unix_error(err, "connect", "")) else try (* We should pass only one time here, unless the system call is interrupted by a signal: *) Unix.connect ch.fd addr with | Unix.Unix_error (Unix.EINPROGRESS, _, _) -> in_progress := true; raise Retry end external bind_job : Unix.file_descr -> Unix.sockaddr -> unit job = "lwt_unix_bind_job" let bind fd addr = check_descriptor fd; match Sys.win32, addr with | true, _ | false, Unix.ADDR_INET _ -> Lwt.return (Unix.bind fd.fd addr) | false, Unix.ADDR_UNIX _ -> run_job (bind_job fd.fd addr) let listen ch cnt = check_descriptor ch; Unix.listen ch.fd cnt external somaxconn : unit -> int = "lwt_unix_somaxconn" let getpeername ch = check_descriptor ch; Unix.getpeername ch.fd let getsockname ch = check_descriptor ch; Unix.getsockname ch.fd type credentials = { cred_pid : int; cred_uid : int; cred_gid : int; } external stub_get_credentials : Unix.file_descr -> credentials = "lwt_unix_get_credentials" let get_credentials ch = check_descriptor ch; stub_get_credentials ch.fd (* +-----------------------------------------------------------------+ | Socket options | +-----------------------------------------------------------------+ *) type socket_bool_option = Unix.socket_bool_option = | SO_DEBUG | SO_BROADCAST | SO_REUSEADDR | SO_KEEPALIVE | SO_DONTROUTE | SO_OOBINLINE | SO_ACCEPTCONN | TCP_NODELAY | IPV6_ONLY #if OCAML_VERSION >= (4, 12, 0) | SO_REUSEPORT #endif type socket_int_option = Unix.socket_int_option = | SO_SNDBUF | SO_RCVBUF | SO_ERROR [@ocaml.deprecated "Use Unix.getsockopt_error instead."] | SO_TYPE | SO_RCVLOWAT | SO_SNDLOWAT type socket_optint_option = Unix.socket_optint_option = SO_LINGER type socket_float_option = Unix.socket_float_option = | SO_RCVTIMEO | SO_SNDTIMEO let getsockopt ch opt = check_descriptor ch; Unix.getsockopt ch.fd opt let setsockopt ch opt x = check_descriptor ch; Unix.setsockopt ch.fd opt x let getsockopt_int ch opt = check_descriptor ch; Unix.getsockopt_int ch.fd opt let setsockopt_int ch opt x = check_descriptor ch; Unix.setsockopt_int ch.fd opt x let getsockopt_optint ch opt = check_descriptor ch; Unix.getsockopt_optint ch.fd opt let setsockopt_optint ch opt x = check_descriptor ch; Unix.setsockopt_optint ch.fd opt x let getsockopt_float ch opt = check_descriptor ch; Unix.getsockopt_float ch.fd opt let setsockopt_float ch opt x = check_descriptor ch; Unix.setsockopt_float ch.fd opt x let getsockopt_error ch = check_descriptor ch; Unix.getsockopt_error ch.fd (* +-----------------------------------------------------------------+ | Multicast functions | +-----------------------------------------------------------------+ *) external stub_mcast_set_loop : Unix.file_descr -> bool -> unit = "lwt_unix_mcast_set_loop" external stub_mcast_set_ttl : Unix.file_descr -> int -> unit = "lwt_unix_mcast_set_ttl" type mcast_action = Add | Drop external stub_mcast_modify_membership : Unix.file_descr -> mcast_action -> Unix.inet_addr -> Unix.inet_addr -> unit = "lwt_unix_mcast_modify_membership" let mcast_set_loop ch flag = check_descriptor ch; stub_mcast_set_loop ch.fd flag let mcast_set_ttl ch ttl = check_descriptor ch; stub_mcast_set_ttl ch.fd ttl let mcast_add_membership ch ?(ifname = Unix.inet_addr_any) addr = check_descriptor ch; stub_mcast_modify_membership ch.fd Add ifname addr let mcast_drop_membership ch ?(ifname = Unix.inet_addr_any) addr = check_descriptor ch; stub_mcast_modify_membership ch.fd Drop ifname addr (* +-----------------------------------------------------------------+ | Host and protocol databases | +-----------------------------------------------------------------+ *) type host_entry = Unix.host_entry = { h_name : string; h_aliases : string array; h_addrtype : socket_domain; h_addr_list : inet_addr array } type protocol_entry = Unix.protocol_entry = { p_name : string; p_aliases : string array; p_proto : int } type service_entry = Unix.service_entry = { s_name : string; s_aliases : string array; s_port : int; s_proto : string } external gethostname_job : unit -> string job = "lwt_unix_gethostname_job" let gethostname () = if Sys.win32 then Lwt.return (Unix.gethostname ()) else run_job (gethostname_job ()) let hostent_mutex = Lwt_mutex.create () external gethostbyname_job : string -> Unix.host_entry job = "lwt_unix_gethostbyname_job" let gethostbyname name = if Sys.win32 then Lwt.return (Unix.gethostbyname name) else if Lwt_config._HAVE_REENTRANT_HOSTENT then run_job (gethostbyname_job name) else Lwt_mutex.with_lock hostent_mutex ( fun () -> run_job (gethostbyname_job name) ) external gethostbyaddr_job : Unix.inet_addr -> Unix.host_entry job = "lwt_unix_gethostbyaddr_job" let gethostbyaddr addr = if Sys.win32 then Lwt.return (Unix.gethostbyaddr addr) else if Lwt_config._HAVE_REENTRANT_HOSTENT then run_job (gethostbyaddr_job addr) else Lwt_mutex.with_lock hostent_mutex ( fun () -> run_job (gethostbyaddr_job addr) ) let protoent_mutex = if Sys.win32 || Lwt_config._HAVE_NETDB_REENTRANT then hostent_mutex else Lwt_mutex.create () external getprotobyname_job : string -> Unix.protocol_entry job = "lwt_unix_getprotobyname_job" let getprotobyname name = if Sys.win32 then Lwt.return (Unix.getprotobyname name) else if Lwt_config._HAVE_NETDB_REENTRANT then run_job (getprotobyname_job name) else Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getprotobyname_job name)) external getprotobynumber_job : int -> Unix.protocol_entry job = "lwt_unix_getprotobynumber_job" let getprotobynumber number = if Sys.win32 then Lwt.return (Unix.getprotobynumber number) else if Lwt_config._HAVE_NETDB_REENTRANT then run_job (getprotobynumber_job number) else Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getprotobynumber_job number)) (* TODO: Not used anywhere, and that might be a bug. *) let _servent_mutex = if Sys.win32 || Lwt_config._HAVE_NETDB_REENTRANT then hostent_mutex else Lwt_mutex.create () external getservbyname_job : string -> string -> Unix.service_entry job = "lwt_unix_getservbyname_job" let getservbyname name x = if Sys.win32 then Lwt.return (Unix.getservbyname name x) else if Lwt_config._HAVE_NETDB_REENTRANT then run_job (getservbyname_job name x) else Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getservbyname_job name x) ) external getservbyport_job : int -> string -> Unix.service_entry job = "lwt_unix_getservbyport_job" let getservbyport port x = if Sys.win32 then Lwt.return (Unix.getservbyport port x) else if Lwt_config._HAVE_NETDB_REENTRANT then run_job (getservbyport_job port x) else Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getservbyport_job port x) ) type addr_info = Unix.addr_info = { ai_family : socket_domain; ai_socktype : socket_type; ai_protocol : int; ai_addr : sockaddr; ai_canonname : string; } type getaddrinfo_option = Unix.getaddrinfo_option = | AI_FAMILY of socket_domain | AI_SOCKTYPE of socket_type | AI_PROTOCOL of int | AI_NUMERICHOST | AI_CANONNAME | AI_PASSIVE external getaddrinfo_job : string -> string -> Unix.getaddrinfo_option list -> Unix.addr_info list job = "lwt_unix_getaddrinfo_job" let getaddrinfo host service opts = if Sys.win32 then Lwt.return (Unix.getaddrinfo host service opts) else run_job (getaddrinfo_job host service opts) >>= fun l -> Lwt.return (List.rev l) type name_info = Unix.name_info = { ni_hostname : string; ni_service : string; } type getnameinfo_option = Unix.getnameinfo_option = | NI_NOFQDN | NI_NUMERICHOST | NI_NAMEREQD | NI_NUMERICSERV | NI_DGRAM external getnameinfo_job : Unix.sockaddr -> Unix.getnameinfo_option list -> Unix.name_info job = "lwt_unix_getnameinfo_job" let getnameinfo addr opts = if Sys.win32 then Lwt.return (Unix.getnameinfo addr opts) else run_job (getnameinfo_job addr opts) (* +-----------------------------------------------------------------+ | Terminal interface | +-----------------------------------------------------------------+ *) type terminal_io = Unix.terminal_io = { mutable c_ignbrk : bool; mutable c_brkint : bool; mutable c_ignpar : bool; mutable c_parmrk : bool; mutable c_inpck : bool; mutable c_istrip : bool; mutable c_inlcr : bool; mutable c_igncr : bool; mutable c_icrnl : bool; mutable c_ixon : bool; mutable c_ixoff : bool; mutable c_opost : bool; mutable c_obaud : int; mutable c_ibaud : int; mutable c_csize : int; mutable c_cstopb : int; mutable c_cread : bool; mutable c_parenb : bool; mutable c_parodd : bool; mutable c_hupcl : bool; mutable c_clocal : bool; mutable c_isig : bool; mutable c_icanon : bool; mutable c_noflsh : bool; mutable c_echo : bool; mutable c_echoe : bool; mutable c_echok : bool; mutable c_echonl : bool; mutable c_vintr : char; mutable c_vquit : char; mutable c_verase : char; mutable c_vkill : char; mutable c_veof : char; mutable c_veol : char; mutable c_vmin : int; mutable c_vtime : int; mutable c_vstart : char; mutable c_vstop : char; } type setattr_when = Unix.setattr_when = | TCSANOW | TCSADRAIN | TCSAFLUSH type flush_queue = Unix.flush_queue = | TCIFLUSH | TCOFLUSH | TCIOFLUSH type flow_action = Unix.flow_action = | TCOOFF | TCOON | TCIOFF | TCION external tcgetattr_job : Unix.file_descr -> Unix.terminal_io job = "lwt_unix_tcgetattr_job" let tcgetattr ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcgetattr ch.fd) else run_job (tcgetattr_job ch.fd) external tcsetattr_job : Unix.file_descr -> Unix.setattr_when -> Unix.terminal_io -> unit job = "lwt_unix_tcsetattr_job" let tcsetattr ch when_ attrs = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcsetattr ch.fd when_ attrs) else run_job (tcsetattr_job ch.fd when_ attrs) external tcsendbreak_job : Unix.file_descr -> int -> unit job = "lwt_unix_tcsendbreak_job" let tcsendbreak ch delay = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcsendbreak ch.fd delay) else run_job (tcsendbreak_job ch.fd delay) external tcdrain_job : Unix.file_descr -> unit job = "lwt_unix_tcdrain_job" let tcdrain ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcdrain ch.fd) else run_job (tcdrain_job ch.fd) external tcflush_job : Unix.file_descr -> Unix.flush_queue -> unit job = "lwt_unix_tcflush_job" let tcflush ch q = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcflush ch.fd q) else run_job (tcflush_job ch.fd q) external tcflow_job : Unix.file_descr -> Unix.flow_action -> unit job = "lwt_unix_tcflow_job" let tcflow ch act = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcflow ch.fd act) else run_job (tcflow_job ch.fd act) (* +-----------------------------------------------------------------+ | Reading notifications | +-----------------------------------------------------------------+ *) external init_notification : unit -> Unix.file_descr = "lwt_unix_init_notification" external send_notification : int -> unit = "lwt_unix_send_notification_stub" external recv_notifications : unit -> int array = "lwt_unix_recv_notifications" let handle_notifications _ = (* Process available notifications. *) Array.iter call_notification (recv_notifications ()) let event_notifications = ref (Lwt_engine.on_readable (init_notification ()) handle_notifications) (* +-----------------------------------------------------------------+ | Signals | +-----------------------------------------------------------------+ *) external set_signal : int -> int -> bool -> unit = "lwt_unix_set_signal" external remove_signal : int -> bool -> unit = "lwt_unix_remove_signal" external init_signals : unit -> unit = "lwt_unix_init_signals" external handle_signal : int -> unit = "lwt_unix_handle_signal" let () = init_signals () let set_signal signum notification = set_signal signum notification (Lwt_engine.forwards_signal signum) let remove_signal signum = remove_signal signum (Lwt_engine.forwards_signal signum) module Signal_map = Map.Make(struct type t = int let compare a b = a - b end) type signal_handler = { sh_num : int; sh_node : (signal_handler_id -> int -> unit) Lwt_sequence.node; } and signal_handler_id = signal_handler option ref let signals = ref Signal_map.empty let signal_count () = Signal_map.fold (fun _signum (_id, actions) len -> len + Lwt_sequence.length actions) !signals 0 let on_signal_full signum handler = let id = ref None in let _, actions = try Signal_map.find signum !signals with Not_found -> let actions = Lwt_sequence.create () in let notification = make_notification (fun () -> Lwt_sequence.iter_l (fun f -> f id signum) actions) in (try set_signal signum notification with exn when Lwt.Exception_filter.run exn -> stop_notification notification; raise exn); signals := Signal_map.add signum (notification, actions) !signals; (notification, actions) in let node = Lwt_sequence.add_r handler actions in id := Some { sh_num = signum; sh_node = node }; id let on_signal signum f = on_signal_full signum (fun _id num -> f num) let disable_signal_handler id = match !id with | None -> () | Some sh -> id := None; Lwt_sequence.remove sh.sh_node; let notification, actions = Signal_map.find sh.sh_num !signals in if Lwt_sequence.is_empty actions then begin remove_signal sh.sh_num; signals := Signal_map.remove sh.sh_num !signals; stop_notification notification end let reinstall_signal_handler signum = match Signal_map.find signum !signals with | exception Not_found -> () | notification, _ -> set_signal signum notification (* +-----------------------------------------------------------------+ | Processes | +-----------------------------------------------------------------+ *) external reset_after_fork : unit -> unit = "lwt_unix_reset_after_fork" let fork () = match Unix.fork () with | 0 -> (* Let the engine handle the fork *) Lwt_engine.fork (); (* Reset threading. *) reset_after_fork (); (* Stop the old event for notifications. *) Lwt_engine.stop_event !event_notifications; (* Reinitialise the notification system. *) event_notifications := Lwt_engine.on_readable (init_notification ()) handle_notifications; (* Collect all pending jobs. *) let l = Lwt_sequence.fold_l (fun (_, f) l -> f :: l) jobs [] in (* Remove them all. *) Lwt_sequence.iter_node_l Lwt_sequence.remove jobs; (* And cancel them all. We yield first so that if the program do an exec just after, it won't be executed. *) Lwt.on_termination (Lwt_main.yield () [@warning "-3"]) (fun () -> List.iter (fun f -> f Lwt.Canceled) l); 0 | pid -> pid type process_status = Unix.process_status = | WEXITED of int | WSIGNALED of int | WSTOPPED of int type wait_flag = Unix.wait_flag = | WNOHANG | WUNTRACED type resource_usage = { ru_utime : float; ru_stime : float } let has_wait4 = not Sys.win32 external stub_wait4 : Unix.wait_flag list -> int -> int * Unix.process_status * resource_usage = "lwt_unix_wait4" let do_wait4 flags pid = if Sys.win32 || Lwt_config.android then let pid, status = Unix.waitpid flags pid in (pid, status, { ru_utime = 0.0; ru_stime = 0.0 }) else stub_wait4 flags pid let wait_children = Lwt_sequence.create () let wait_count () = Lwt_sequence.length wait_children let sigchld_handler_installed = ref false let install_sigchld_handler () = if not Sys.win32 && not !sigchld_handler_installed then begin sigchld_handler_installed := true; ignore begin on_signal Sys.sigchld (fun _ -> Lwt_sequence.iter_node_l begin fun node -> let wakener, flags, pid = Lwt_sequence.get node in try let (pid', _, _) as v = do_wait4 flags pid in if pid' <> 0 then begin Lwt_sequence.remove node; Lwt.wakeup wakener v end with e when Lwt.Exception_filter.run e -> Lwt_sequence.remove node; Lwt.wakeup_exn wakener e end wait_children) end end (* The callback of Lwt.pause will only be run if Lwt_main.run is called by the user. In that case, the process is positively using Lwt, and we want to install the SIGCHLD handler, in order to cause any EINTR-unsafe code to fail (as it should). *) let () = Lwt.async (fun () -> Lwt.pause () >|= fun () -> install_sigchld_handler ()) let _waitpid flags pid = Lwt.catch (fun () -> Lwt.return (Unix.waitpid flags pid)) Lwt.reraise let waitpid = if Sys.win32 then _waitpid else fun flags pid -> install_sigchld_handler (); if List.mem Unix.WNOHANG flags then _waitpid flags pid else let flags = Unix.WNOHANG :: flags in _waitpid flags pid >>= fun ((pid', _) as res) -> if pid' <> 0 then Lwt.return res else begin let (res, w) = Lwt.task () in let node = Lwt_sequence.add_l (w, flags, pid) wait_children in Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); res >>= fun (pid, status, _) -> Lwt.return (pid, status) end let wait4 flags pid = install_sigchld_handler (); if Sys.win32 || Lwt_config.android then Lwt.return (do_wait4 flags pid) else if List.mem Unix.WNOHANG flags then Lwt.return (do_wait4 flags pid) else let flags = Unix.WNOHANG :: flags in let (pid', _, _) as res = do_wait4 flags pid in if pid' <> 0 then Lwt.return res else begin let (res, w) = Lwt.task () in let node = Lwt_sequence.add_l (w, flags, pid) wait_children in Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); res end let wait () = waitpid [] (-1) external system_job : string -> int job = "lwt_unix_system_job" #if OCAML_VERSION >= (5, 0, 0) external unix_exit : int -> 'a = "caml_unix_exit" #else external unix_exit : int -> 'a = "unix_exit" #endif let system cmd = if Sys.win32 then run_job (system_job ("cmd.exe /c " ^ cmd)) >>= fun code -> Lwt.return (Unix.WEXITED code) else match fork () with | 0 -> begin try Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] with _ -> (* Do not run at_exit hooks *) unix_exit 127 end | id -> waitpid [] id >|= snd (* +-----------------------------------------------------------------+ | Misc | +-----------------------------------------------------------------+ *) let run = Lwt_main.run let handle_unix_error f x = Lwt.catch (fun () -> f x) (fun exn -> Unix.handle_unix_error (fun () -> raise exn) ()) (* +-----------------------------------------------------------------+ | System thread pool | +-----------------------------------------------------------------+ *) [@@@ocaml.warning "-3"] external pool_size : unit -> int = "lwt_unix_pool_size" "noalloc" external set_pool_size : int -> unit = "lwt_unix_set_pool_size" "noalloc" external thread_count : unit -> int = "lwt_unix_thread_count" "noalloc" external thread_waiting_count : unit -> int = "lwt_unix_thread_waiting_count" "noalloc" [@@@ocaml.warning "+3"] (* +-----------------------------------------------------------------+ | CPUs | +-----------------------------------------------------------------+ *) external get_cpu : unit -> int = "lwt_unix_get_cpu" external stub_get_affinity : int -> int list = "lwt_unix_get_affinity" external stub_set_affinity : int -> int list -> unit = "lwt_unix_set_affinity" let get_affinity ?(pid=0) () = stub_get_affinity pid let set_affinity ?(pid=0) l = stub_set_affinity pid l (* +-----------------------------------------------------------------+ | Error printing | +-----------------------------------------------------------------+ *) let () = Printexc.register_printer (function | Unix.Unix_error(error, func, arg) -> let error = match error with | Unix.E2BIG -> "E2BIG" | Unix.EACCES -> "EACCES" | Unix.EAGAIN -> "EAGAIN" | Unix.EBADF -> "EBADF" | Unix.EBUSY -> "EBUSY" | Unix.ECHILD -> "ECHILD" | Unix.EDEADLK -> "EDEADLK" | Unix.EDOM -> "EDOM" | Unix.EEXIST -> "EEXIST" | Unix.EFAULT -> "EFAULT" | Unix.EFBIG -> "EFBIG" | Unix.EINTR -> "EINTR" | Unix.EINVAL -> "EINVAL" | Unix.EIO -> "EIO" | Unix.EISDIR -> "EISDIR" | Unix.EMFILE -> "EMFILE" | Unix.EMLINK -> "EMLINK" | Unix.ENAMETOOLONG -> "ENAMETOOLONG" | Unix.ENFILE -> "ENFILE" | Unix.ENODEV -> "ENODEV" | Unix.ENOENT -> "ENOENT" | Unix.ENOEXEC -> "ENOEXEC" | Unix.ENOLCK -> "ENOLCK" | Unix.ENOMEM -> "ENOMEM" | Unix.ENOSPC -> "ENOSPC" | Unix.ENOSYS -> "ENOSYS" | Unix.ENOTDIR -> "ENOTDIR" | Unix.ENOTEMPTY -> "ENOTEMPTY" | Unix.ENOTTY -> "ENOTTY" | Unix.ENXIO -> "ENXIO" | Unix.EPERM -> "EPERM" | Unix.EPIPE -> "EPIPE" | Unix.ERANGE -> "ERANGE" | Unix.EROFS -> "EROFS" | Unix.ESPIPE -> "ESPIPE" | Unix.ESRCH -> "ESRCH" | Unix.EXDEV -> "EXDEV" | Unix.EWOULDBLOCK -> "EWOULDBLOCK" | Unix.EINPROGRESS -> "EINPROGRESS" | Unix.EALREADY -> "EALREADY" | Unix.ENOTSOCK -> "ENOTSOCK" | Unix.EDESTADDRREQ -> "EDESTADDRREQ" | Unix.EMSGSIZE -> "EMSGSIZE" | Unix.EPROTOTYPE -> "EPROTOTYPE" | Unix.ENOPROTOOPT -> "ENOPROTOOPT" | Unix.EPROTONOSUPPORT -> "EPROTONOSUPPORT" | Unix.ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT" | Unix.EOPNOTSUPP -> "EOPNOTSUPP" | Unix.EPFNOSUPPORT -> "EPFNOSUPPORT" | Unix.EAFNOSUPPORT -> "EAFNOSUPPORT" | Unix.EADDRINUSE -> "EADDRINUSE" | Unix.EADDRNOTAVAIL -> "EADDRNOTAVAIL" | Unix.ENETDOWN -> "ENETDOWN" | Unix.ENETUNREACH -> "ENETUNREACH" | Unix.ENETRESET -> "ENETRESET" | Unix.ECONNABORTED -> "ECONNABORTED" | Unix.ECONNRESET -> "ECONNRESET" | Unix.ENOBUFS -> "ENOBUFS" | Unix.EISCONN -> "EISCONN" | Unix.ENOTCONN -> "ENOTCONN" | Unix.ESHUTDOWN -> "ESHUTDOWN" | Unix.ETOOMANYREFS -> "ETOOMANYREFS" | Unix.ETIMEDOUT -> "ETIMEDOUT" | Unix.ECONNREFUSED -> "ECONNREFUSED" | Unix.EHOSTDOWN -> "EHOSTDOWN" | Unix.EHOSTUNREACH -> "EHOSTUNREACH" | Unix.ELOOP -> "ELOOP" | Unix.EOVERFLOW -> "EOVERFLOW" | Unix.EUNKNOWNERR n -> Printf.sprintf "EUNKNOWNERR %d" n in Some(Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" error func arg) | _ -> None) module Versioned = struct let bind_1 ch addr = check_descriptor ch; Unix.bind ch.fd addr let bind_2 = bind let recv_msg_2 = recv_msg let send_msg_2 = send_msg end lwt-5.9.1/src/unix/lwt_unix.cppo.mli000066400000000000000000001476231476253734400174560ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Cooperative system calls *) (** This modules maps system calls, like those of the standard library's {!Unix} module, to cooperative ones, which will not block the program. The semantics of all operations is the following: if the action (for example reading from a {b file descriptor}) can be performed immediately, it is performed and returns an already resolved promise, otherwise it returns a pending promise which is resolved when the operation completes. Most operations on sockets and pipes (on Windows it is only sockets) are {b cancelable}, meaning you can cancel them with {!Lwt.cancel}. For example if you want to read something from a {b file descriptor} with a timeout, you can cancel the action after the timeout and the reading will not be performed if not already done. For example, consider that you have two sockets [sock1] and [sock2]. You want to read something from [sock1] or exclusively from [sock2] and fail with an exception if a timeout of 1 second expires, without reading anything from [sock1] and [sock2], even if they become readable in the future. Then you can do: {[ Lwt.pick [Lwt_unix.timeout 1.0; read sock1 buf1 ofs1 len1; read sock2 buf2 ofs2 len2] ]} In this case, it is guaranteed that exactly one of the three operations will complete, and the others will be cancelled. *) val handle_unix_error : ('a -> 'b Lwt.t) -> 'a -> 'b Lwt.t (** Same as {!Unix.handle_unix_error} but catches lwt-level exceptions *) (** {2 Sleeping} *) val sleep : float -> unit Lwt.t (** [sleep d] is a promise that remains in a pending state for [d] seconds after which it is resolved with value [()]. *) val yield : unit -> unit Lwt.t [@@deprecated "Use Lwt.pause instead"] (** [yield ()] is a promise in a pending state. It resumes itself as soon as possible and resolves with value [()]. @deprecated Since 5.5.0 [yield] is deprecated. Use the more general {!Lwt.pause} instead. See {!Lwt_main.yield} for additional details. *) val auto_yield : float -> (unit -> unit Lwt.t) [@@deprecated "Use Lwt_unix.auto_pause instead"] (** @deprecated Since 5.5.0. Use {!auto_pause} instead. *) val auto_pause : float -> (unit -> unit Lwt.t) (** [auto_pause timeout] returns a function [f], and [f ()] has the following behavior: - If it has been more than [timeout] seconds since the last time [f ()] behaved like {!Lwt.pause}, [f ()] calls {!Lwt.pause}. - Otherwise, if it has been less than [timeout] seconds, [f ()] behaves like {!Lwt.return_unit}, i.e. it does not yield. *) exception Timeout (** Exception raised by timeout operations *) val timeout : float -> 'a Lwt.t (** [timeout d] is a promise that remains pending for [d] seconds and then is rejected with {!Timeout}. @raise Timeout The promise [timeout d] is rejected with {!Timeout} unless it is cancelled. *) val with_timeout : float -> (unit -> 'a Lwt.t) -> 'a Lwt.t (** [with_timeout d f] is a short-hand for: {[ Lwt.pick [Lwt_unix.timeout d; f ()] ]} @raise Timeout The promise [with_timeout d f] raises {!Timeout} if the promise returned by [f ()] takes more than [d] seconds to resolve. *) (** {2 Operations on file-descriptors} *) type file_descr (** The abstract type for {b file descriptor}s. A Lwt {b file descriptor} is a pair of a unix {b file descriptor} (of type {!Unix.file_descr}) and a {b state}. A {b file descriptor} may be: - {b opened}, in which case it is fully usable - {b closed} or {b aborted}, in which case it is no longer usable *) (** State of a {b file descriptor} *) type state = | Opened (** The {b file descriptor} is opened *) | Closed (** The {b file descriptor} has been closed by {!close}. It must not be used for any operation. *) | Aborted of exn (** The {b file descriptor} has been aborted, the only operation possible is {!close}, all others will fail. *) val state : file_descr -> state (** [state fd] returns the {!type:state} of [fd]. *) val unix_file_descr : file_descr -> Unix.file_descr (** Returns the underlying unix {b file descriptor}. It always succeeds, even if the {b file descriptor}'s state is not [Opened]. *) val of_unix_file_descr : ?blocking : bool -> ?set_flags : bool -> Unix.file_descr -> file_descr (** Wraps a [Unix] file descriptor [fd] in an Lwt {!file_descr} [fd']. [~blocking] controls the {e internal} strategy Lwt uses to perform I/O on the underlying [fd]. Regardless of [~blocking], at the API level, [Lwt_unix.read], [Lwt_unix.write], etc. on [fd'] {e always} block the Lwt promise, but {e never} block the whole process. However, for performance reasons, it is important that [~blocking] match the actual blocking mode of [fd]. If [~blocking] is not specified, [of_unix_file_descr] chooses non-blocking mode for Unix sockets, Unix pipes, and Windows sockets, and blocking mode for everything else. {b Note:} not specifying [~blocking] causes [fstat] to be lazily called on [fd], the first time your code performs I/O on [fd']. This [fstat] call can be expensive, so if you use [of_unix_file_descr] a lot, be sure to specify [~blocking] explicitly. [of_unix_file_descr] runs a system call to set the specified or chosen blocking mode on the underlying [fd]. To prevent [of_unix_file_descr] from running this system call, you can pass [~set_flags:false]. Note that, in this case, if [~blocking], whether passed explicitly or chosen by Lwt, does not match the true blocking mode of the underlying [fd], I/O on [fd'] will suffer performance degradation. Note that [~set_flags] is effectively always [false] if running on Windows and [fd] is not a socket. Generally, non-blocking I/O is faster: for blocking I/O, Lwt typically has to run system calls in worker threads to avoid blocking the process. See your system documentation for whether particular kinds of file descriptors support non-blocking I/O. *) val blocking : file_descr -> bool Lwt.t (** [blocking fd] indicates whether Lwt is internally using blocking or non-blocking I/O with [fd]. Note that this may differ from the blocking mode of the underlying Unix file descriptor (i.e. [unix_file_descr fd]). See {!of_unix_file_descr} for details. *) val set_blocking : ?set_flags : bool -> file_descr -> bool -> unit (** [set_blocking fd b] causes Lwt to internally use blocking or non-blocking I/O with [fd], according to the value of [b]. If [~set_flags] is [true] (the default), Lwt also makes a system call to set the underlying file descriptor's blocking mode to match. Otherwise, [set_blocking] is only informational for Lwt. It is important that the underlying file descriptor actually have the same blocking mode as that indicated by [b]. See {!of_unix_file_descr} for details. *) val abort : file_descr -> exn -> unit (** [abort fd exn] makes all current and further uses of the file descriptor fail with the given exception. This put the {b file descriptor} into the [Aborted] state. If the {b file descriptor} is closed, this does nothing, if it is aborted, this replace the abort exception by [exn]. Note that this only works for reading and writing operations on file descriptors supporting non-blocking mode. *) (** {2 Process handling} *) val fork : unit -> int (** [fork ()] does the same as {!Unix.fork}. You must use this function instead of {!Unix.fork} when you want to use Lwt in the child process, even if you have not started using Lwt before the fork. Notes: - In the child process all pending [Lwt_unix] I/O jobs are abandoned. This may cause the child's copy of their associated promises to remain forever pending. - If you are going to use Lwt in the parent and the child, it is a good idea to call {!Lwt_io.flush_all} before callling {!fork} to avoid double-flush. - Otherwise, if you will not use Lwt in the child, call {!Lwt_main.Exit_hooks.remove_all} to avoid Lwt calling {!Lwt_main.run} during process exit. - None of the above is necessary if you intend to call [exec]. Indeed, in that case, it is not even necessary to use [Lwt_unix.fork]. You can use {!Unix.fork}. - To abandon some more promises, see {!Lwt_main.abandon_yielded_and_paused}. *) type process_status = Unix.process_status = | WEXITED of int | WSIGNALED of int | WSTOPPED of int type wait_flag = Unix.wait_flag = | WNOHANG | WUNTRACED val wait : unit -> (int * process_status) Lwt.t (** Wrapper for {!Unix.wait} *) val waitpid : wait_flag list -> int -> (int * process_status) Lwt.t (** A promise-returning analog to {!Unix.waitpid}. This call is non-blocking on Unix-like systems, but is always blocking on Windows. *) (** Resource usages *) type resource_usage = { ru_utime : float; (** User time used *) ru_stime : float; (** System time used *) } val wait4 : wait_flag list -> int -> (int * process_status * resource_usage) Lwt.t (** [wait4 flags pid] returns [(pid, status, rusage)] where [(pid, status)] is the same result as [Unix.waitpid flags pid], and [rusage] contains accounting information about the child. On windows it will always returns [{ utime = 0.0; stime = 0.0 }]. *) val wait_count : unit -> int (** Returns the number of promises waiting for a child process to terminate. *) val system : string -> process_status Lwt.t (** Executes the given command, waits until it terminates, and return its termination status. The string is interpreted by the shell [/bin/sh] on Unix and [cmd.exe] on Windows. The result [WEXITED 127] indicates that the shell couldn't be executed. *) (** {2 Basic file input/output} *) val stdin : file_descr (** The {b file descriptor} for standard input. *) val stdout : file_descr (** The {b file descriptor} for standard output. *) val stderr : file_descr (** The {b file descriptor} for standard error. *) type file_perm = Unix.file_perm type open_flag = Unix.open_flag = | O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE | O_CLOEXEC | O_KEEPEXEC val openfile : string -> open_flag list -> file_perm -> file_descr Lwt.t (** Wrapper for {!Unix.openfile}. *) val close : file_descr -> unit Lwt.t (** Close a {b file descriptor}. This close the underlying unix {b file descriptor} and set its state to [Closed]. *) val read : file_descr -> bytes -> int -> int -> int Lwt.t (** [read fd buf ofs len] reads up to [len] bytes from [fd], and writes them to [buf], starting at offset [ofs]. The function immediately evaluates to an Lwt promise which waits for the operation to complete. If it completes successfully, the promise resolves to the number of bytes actually read, or zero if the end of file has been reached. Note that the Lwt promise waits for data (or end of file) even if the underlying file descriptor is in non-blocking mode. See {!of_unix_file_descr} for a discussion of non-blocking I/O and Lwt. If Lwt is using blocking I/O on [fd], [read] writes data into a temporary buffer, then copies it into [buf]. The promise can be rejected with any exception that can be raised by {!Unix.read}, except [Unix.Unix_error Unix.EAGAIN], [Unix.Unix_error Unix.EWOULDBLOCK] or [Unix.Unix_error Unix.EINTR]. *) val pread : file_descr -> bytes -> file_offset:int -> int -> int -> int Lwt.t (** [pread fd buf ~file_offset ofs len] on file descriptors allowing seek, reads up to [len] bytes from [fd] at offset [file_offset] from the beginning of the file, and writes them to [buf], starting at offset [ofs]. On Unix systems, the file descriptor position is unaffected. On Windows it is changed to be just after the last read position. The promise can be rejected with any exception that can be raised by [read] or [lseek]. *) val write : file_descr -> bytes -> int -> int -> int Lwt.t (** [write fd buf ofs len] writes up to [len] bytes to [fd] from [buf], starting at buffer offset [ofs]. The function immediately evaluates to an Lwt promise which waits for the operation to complete. If the operation completes successfully, the promise resolves to the number of bytes actually written, which may be less than [len]. Note that the Lwt promise waits to write even if the underlying file descriptor is in non-blocking mode. See {!of_unix_file_descr} for a discussion of non-blocking I/O and Lwt. If Lwt is using blocking I/O on [fd], [buf] is copied before writing. The promise can be rejected with any exception that can be raised by {!Unix.single_write}, except [Unix.Unix_error Unix.EAGAIN], [Unix.Unix_error Unix.EWOULDBLOCK] or [Unix.Unix_error Unix.EINTR]. *) val pwrite : file_descr -> bytes -> file_offset:int -> int -> int -> int Lwt.t (** [pwrite fd buf ~file_offset ofs len] on file descriptors allowing seek, writes up to [len] bytes to [fd] from [buf], starting at buffer offset [ofs]. The data is written at offset [file_offset] from the beginning of [fd]. On Unix systems, the file descriptor position is unaffected. On Windows it is changed to be just after the last written position. The promise can be rejected with any exception that can be raised by [write] or [lseek]. *) val write_string : file_descr -> string -> int -> int -> int Lwt.t (** See {!write}. *) val pwrite_string : file_descr -> string -> file_offset:int -> int -> int -> int Lwt.t (** See {!pwrite}. *) (** Sequences of buffer slices for {!writev}. *) module IO_vectors : sig type t (** Mutable sequences of I/O vectors. An I/O vector describes a slice of a [bytes] or [Bigarray] buffer. Each I/O vector is a triple containing a reference to the buffer, an offset into the buffer where the slice begins, and the length of the slice. *) type _bigarray = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t (** Type abbreviation equivalent to {!Lwt_bytes.t}. Do not use this type name directly; use {!Lwt_bytes.t} instead. *) val create : unit -> t (** Creates an empty I/O vector sequence. *) val append_bytes : t -> bytes -> int -> int -> unit (** [append_bytes vs buffer offset length] appends a slice of the [bytes] buffer [buffer] beginning at [offset] and with length [length] to the I/O vector sequence [vs]. *) val append_bigarray : t -> _bigarray -> int -> int -> unit (** [append_bigarray vs buffer offset length] appends a slice of the [Bigarray] buffer [buffer] beginning at [offset] and with length [length] to the I/O vector sequence [vs]. *) val drop : t -> int -> unit (** [drop vs n] adjusts the I/O vector sequence [vs] so that it no longer includes its first [n] bytes. *) val is_empty : t -> bool (** [is_empty vs] is [true] if and only if [vs] has no I/O vectors, or all I/O vectors in [vs] have zero bytes. *) val byte_count : t -> int (** [byte_count vs] is the total number of bytes in [vs]. @since 4.2.0 *) val system_limit : int option (** Some systems limit the number of I/O vectors that can be passed in a single call to their [writev] or [readv] system calls. On those systems, if the limit is [n], this value is equal to [Some n]. On systems without such a limit, the value is equal to [None]. Unless you need atomic I/O operations, you can ignore this limit. The Lwt binding automatically respects it internally. See {!Lwt_unix.writev}. A typical limit is 1024 vectors. *) end val readv : file_descr -> IO_vectors.t -> int Lwt.t (** [readv fd vs] reads bytes from [fd] into the buffer slices [vs]. If the operation completes successfully, the resulting promise resolves to the number of bytes read. Data is always read directly into [Bigarray] slices. If the Unix file descriptor underlying [fd] is in non-blocking mode, data is also read directly into [bytes] slices. Otherwise, data for [bytes] slices is first read into temporary buffers, then copied. Note that the returned Lwt promise is pending until failure or a successful read, even if the underlying file descriptor is in non-blocking mode. See {!of_unix_file_descr} for a discussion of non-blocking I/O and Lwt. If {!IO_vectors.system_limit} is [Some n] and the count of slices in [vs] exceeds [n], then [Lwt_unix.readv] reads only into the first [n] slices of [vs]. Not implemented on Windows. It should be possible to implement, upon request, for Windows sockets only. See {{:https://man7.org/linux/man-pages/man3/readv.3p.html} [readv(3p)]}. @since 2.7.0 *) val writev : file_descr -> IO_vectors.t -> int Lwt.t (** [writev fd vs] writes the bytes in the buffer slices [vs] to the file descriptor [fd]. If the operation completes successfully, the resulting promise resolves to the number of bytes written. If the Unix file descriptor underlying [fd] is in non-blocking mode, [writev] does not make a copy the bytes before writing. Otherwise, it copies [bytes] slices, but not [Bigarray] slices. Note that the returned Lwt promise is pending until failure or a successful write, even if the underlying descriptor is in non-blocking mode. See {!of_unix_file_descr} for a discussion of non-blocking I/O and Lwt. If {!IO_vectors.system_limit} is [Some n] and the count of slices in [vs] exceeds [n], then [Lwt_unix.writev] passes only the first [n] slices in [vs] to the underlying [writev] system call. Not implemented on Windows. It should be possible to implement, upon request, for Windows sockets only. The behavior of [writev] when [vs] has zero slices depends on the system, and may change in future versions of Lwt. On Linux, [writev] will succeed and write zero bytes. On BSD (including macOS), [writev] will fail with [Unix.Unix_error (Unix.EINVAL, "writev", ...)]. See {{:https://man7.org/linux/man-pages/man3/writev.3p.html} [writev(3p)]}. @since 2.7.0 *) val readable : file_descr -> bool (** Returns whether the given file descriptor is currently readable. *) val writable : file_descr -> bool (** Returns whether the given file descriptor is currently writable. *) val wait_read : file_descr -> unit Lwt.t (** Waits (without blocking other promises) until there is something to read from the file descriptor. Note that you don't need to use this function if you are using Lwt I/O functions for reading, since they provide non-blocking waiting automatically. The intended use case for this function is interfacing with existing libraries that are known to be blocking. *) val wait_write : file_descr -> unit Lwt.t (** Waits (without blocking other promises) until it is possible to write on the file descriptor. Note that you don't need to use this function if you are using Lwt I/O functions for writing, since they provide non-blocking waiting automatically. The intended use case for this function is interfacing with existing libraries that are known to be blocking. *) (** {2 Seeking and truncating} *) type seek_command = Unix.seek_command = | SEEK_SET | SEEK_CUR | SEEK_END val lseek : file_descr -> int -> seek_command -> int Lwt.t (** Wrapper for {!Unix.lseek} *) val truncate : string -> int -> unit Lwt.t (** Wrapper for {!Unix.truncate} *) val ftruncate : file_descr -> int -> unit Lwt.t (** Wrapper for {!Unix.ftruncate} *) (** {2 Syncing} *) val fsync : file_descr -> unit Lwt.t (** Synchronise all data and metadata of the file descriptor with the disk. On Windows it uses [FlushFileBuffers]. *) val fdatasync : file_descr -> unit Lwt.t (** Synchronise all data (but not metadata) of the file descriptor with the disk. Note that [fdatasync] is not available on Windows and OS X. *) (** {2 File status} *) type file_kind = Unix.file_kind = | S_REG | S_DIR | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK type stats = Unix.stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int; st_atime : float; st_mtime : float; st_ctime : float; } val stat : string -> stats Lwt.t (** Wrapper for {!Unix.stat} *) val lstat : string -> stats Lwt.t (** Wrapper for {!Unix.lstat} *) val fstat : file_descr -> stats Lwt.t (** Wrapper for {!Unix.fstat} *) val file_exists : string -> bool Lwt.t (** [file_exists name] tests if a file named [name] exists. Note that [file_exists] behaves similarly to {!Sys.file_exists}: - “file” is interpreted as “directory entry” in this context - [file_exists name] will return [false] in circumstances that would make {!stat} raise a {!Unix.Unix_error} exception. *) val utimes : string -> float -> float -> unit Lwt.t (** [utimes path atime mtime] updates the access and modification times of the file at [path]. The access time is set to [atime] and the modification time to [mtime]. To set both to the current time, call [utimes path 0. 0.]. This function corresponds to {!Unix.utimes}. See also {{:https://man7.org/linux/man-pages/man3/utimes.3p.html} [utimes(3p)]}. @since 2.6.0 *) val isatty : file_descr -> bool Lwt.t (** Wrapper for {!Unix.isatty} *) (** {2 File operations on large files} *) module LargeFile : sig val lseek : file_descr -> int64 -> seek_command -> int64 Lwt.t (** Wrapper for {!Unix.LargeFile.lseek} *) val truncate : string -> int64 -> unit Lwt.t (** Wrapper for {!Unix.LargeFile.truncate} *) val ftruncate : file_descr -> int64 -> unit Lwt.t (** Wrapper for {!Unix.LargeFile.ftruncate} *) type stats = Unix.LargeFile.stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int64; st_atime : float; st_mtime : float; st_ctime : float; } val stat : string -> stats Lwt.t (** Wrapper for {!Unix.LargeFile.stat} *) val lstat : string -> stats Lwt.t (** Wrapper for {!Unix.LargeFile.lstat} *) val fstat : file_descr -> stats Lwt.t (** Wrapper for {!Unix.LargeFile.fstat} *) val file_exists : string -> bool Lwt.t (** [file_exists name] tests if a file named [name] exists. Note that [file_exists] behaves similarly to {!Sys.file_exists}: - “file” is interpreted as “directory entry” in this context - [file_exists name] will return [false] in circumstances that would make {!stat} raise a {!Unix.Unix_error} exception. *) end (** {2 Operations on file names} *) val unlink : string -> unit Lwt.t (** Wrapper for {!Unix.unlink} *) val rename : string -> string -> unit Lwt.t (** Wrapper for {!Unix.rename} *) val link : string -> string -> unit Lwt.t (** Wrapper for {!Unix.link} *) (** {2 File permissions and ownership} *) val chmod : string -> file_perm -> unit Lwt.t (** Wrapper for {!Unix.chmod} *) val fchmod : file_descr -> file_perm -> unit Lwt.t (** Wrapper for {!Unix.fchmod} *) val chown : string -> int -> int -> unit Lwt.t (** Wrapper for {!Unix.chown} *) val fchown : file_descr -> int -> int -> unit Lwt.t (** Wrapper for {!Unix.fchown} *) type access_permission = Unix.access_permission = | R_OK | W_OK | X_OK | F_OK val access : string -> access_permission list -> unit Lwt.t (** Wrapper for {!Unix.access} *) (** {2 Operations on file descriptors} *) val dup : ?cloexec:bool -> file_descr -> file_descr (** Wrapper for {!Unix.dup} *) val dup2 : ?cloexec:bool -> file_descr -> file_descr -> unit (** Wrapper for {!Unix.dup2} *) val set_close_on_exec : file_descr -> unit (** Wrapper for {!Unix.set_close_on_exec} *) val clear_close_on_exec : file_descr -> unit (** Wrapper for {!Unix.clear_close_on_exec} *) (** {2 Directories} *) val mkdir : string -> file_perm -> unit Lwt.t (** Wrapper for {!Unix.mkdir} *) val rmdir : string -> unit Lwt.t (** Wrapper for {!Unix.rmdir} *) val chdir : string -> unit Lwt.t (** Wrapper for {!Unix.chdir} *) val getcwd : unit -> string Lwt.t (** Wrapper for {!Unix.getcwd} @since 3.1.0 *) val chroot : string -> unit Lwt.t (** Wrapper for {!Unix.chroot} *) type dir_handle = Unix.dir_handle val opendir : string -> dir_handle Lwt.t (** Opens a directory for listing. Directories opened with this function must be explicitly closed with {!closedir}. This is a cooperative analog of {!Unix.opendir}. *) val readdir : dir_handle -> string Lwt.t (** Reads the next directory entry from the given directory. Special entries such as [.] and [..] are included. If all entries have been read, raises [End_of_file]. This is a cooperative analog of {!Unix.readdir}. *) val readdir_n : dir_handle -> int -> string array Lwt.t (** [readdir_n handle count] reads at most [count] entries from the given directory. It is more efficient than calling [readdir] [count] times. If the length of the returned array is smaller than [count], this means that the end of the directory has been reached. *) val rewinddir : dir_handle -> unit Lwt.t (** Resets the given directory handle, so that directory listing can be restarted. Cooperative analog of {!Unix.rewinddir}. *) val closedir : dir_handle -> unit Lwt.t (** Closes a directory handle. Cooperative analog of {!Unix.closedir}. *) val files_of_directory : string -> string Lwt_stream.t (** [files_of_directory dir] returns the stream of all files of [dir]. *) (** {2 Pipes and redirections} *) val pipe : ?cloexec:bool -> unit -> file_descr * file_descr (** [pipe ()] creates pipe using {!Unix.pipe} and returns two lwt {b file descriptor}s created from unix {b file_descriptor} *) val pipe_in : ?cloexec:bool -> unit -> file_descr * Unix.file_descr (** [pipe_in ()] is the same as {!pipe} but maps only the unix {b file descriptor} for reading into a lwt one. The second is not put into non-blocking mode. You usually want to use this before forking to receive data from the child process. *) val pipe_out : ?cloexec:bool -> unit -> Unix.file_descr * file_descr (** [pipe_out ()] is the inverse of {!pipe_in}. You usually want to use this before forking to send data to the child process *) val mkfifo : string -> file_perm -> unit Lwt.t (** Wrapper for {!Unix.mkfifo} *) (** {2 Symbolic links} *) val symlink : ?to_dir:bool -> string -> string -> unit Lwt.t (** Wrapper for {!Unix.symlink} *) val readlink : string -> string Lwt.t (** Wrapper for {!Unix.readlink} *) (** {2 Locking} *) type lock_command = Unix.lock_command = | F_ULOCK | F_LOCK | F_TLOCK | F_TEST | F_RLOCK | F_TRLOCK val lockf : file_descr -> lock_command -> int -> unit Lwt.t (** Wrapper for {!Unix.lockf} *) (** {2 User id, group id} *) type passwd_entry = Unix.passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string } type group_entry = Unix.group_entry = { gr_name : string; gr_passwd : string; gr_gid : int; gr_mem : string array } val getlogin : unit -> string Lwt.t (** Wrapper for {!Unix.getlogin} *) val getpwnam : string -> passwd_entry Lwt.t (** Wrapper for {!Unix.getpwnam} *) val getgrnam : string -> group_entry Lwt.t (** Wrapper for {!Unix.getgrnam} *) val getpwuid : int -> passwd_entry Lwt.t (** Wrapper for {!Unix.getpwuid} *) val getgrgid : int -> group_entry Lwt.t (** Wrapper for {!Unix.getgrgid} *) (** {2 Signals} *) type signal_handler_id (** Id of a signal handler, used to cancel it *) val on_signal : int -> (int -> unit) -> signal_handler_id (** [on_signal signum f] calls [f] each time the signal with numnber [signum] is received by the process. It returns a signal handler identifier that can be used to stop monitoring [signum]. *) val on_signal_full : int -> (signal_handler_id -> int -> unit) -> signal_handler_id (** [on_signal_full f] is the same as [on_signal f] except that [f] also receive the signal handler identifier as argument so it can disable it. *) val disable_signal_handler : signal_handler_id -> unit (** Stops receiving this signal *) val signal_count : unit -> int (** Returns the number of registered signal handler. *) val reinstall_signal_handler : int -> unit (** [reinstall_signal_handler signum] if any signal handler is registered for this signal with {!on_signal}, it reinstall the signal handler (with [Sys.set_signal]). This is useful in case another part of the program install another signal handler. *) val handle_signal : int -> unit (** [handle_signal signum] acts as if Lwt had received the [signum] signal. This allows another IO library to install the handler, perform its own handling, but still notify Lwt. It is particularly useful for SIGCHLD, where several IO libraries may be spawning sub-processes. This function is thread-safe. *) (** {2 Sockets} *) type inet_addr = Unix.inet_addr type socket_domain = Unix.socket_domain = | PF_UNIX | PF_INET | PF_INET6 type socket_type = Unix.socket_type = | SOCK_STREAM | SOCK_DGRAM | SOCK_RAW | SOCK_SEQPACKET type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int val socket : ?cloexec:bool -> socket_domain -> socket_type -> int -> file_descr (** [socket domain type proto] is the same as {!Unix.socket} but maps the result into a lwt {b file descriptor} *) val socketpair : ?cloexec:bool -> socket_domain -> socket_type -> int -> file_descr * file_descr (** Wrapper for {!Unix.socketpair} *) val bind : file_descr -> sockaddr -> unit Lwt.t (** Binds an address to the given socket. This is the cooperative analog of {!Unix.bind}. See also {{:https://man7.org/linux/man-pages/man3/bind.3p.html} [bind(3p)]}. @since 3.0.0 *) val listen : file_descr -> int -> unit (** Wrapper for {!Unix.listen} *) val accept : ?cloexec:bool -> file_descr -> (file_descr * sockaddr) Lwt.t (** Wrapper for {!Unix.accept} *) val accept_n : ?cloexec:bool -> file_descr -> int -> ((file_descr * sockaddr) list * exn option) Lwt.t (** [accept_n fd count] accepts up to [count] connections at one time. - if no connection is available right now, it returns a pending promise - if more than 1 and less than [count] are available, it returns all of them - if more than [count] are available, it returns the next [count] of them - if an error happens, it returns the connections that have been successfully accepted so far and the error [accept_n] has the advantage of improving performance. If you want a more detailed description, you can have a look at: {{:https://dl.acm.org/doi/10.5555/1247415.1247435}Acceptable strategies for improving web server performance} *) val connect : file_descr -> sockaddr -> unit Lwt.t (** Wrapper for {!Unix.connect} *) type shutdown_command = Unix.shutdown_command = | SHUTDOWN_RECEIVE | SHUTDOWN_SEND | SHUTDOWN_ALL val shutdown : file_descr -> shutdown_command -> unit (** Wrapper for {!Unix.shutdown} *) val getsockname : file_descr -> sockaddr (** Wrapper for {!Unix.getsockname} *) val getpeername : file_descr -> sockaddr (** Wrapper for {!Unix.getpeername} *) type msg_flag = Unix.msg_flag = | MSG_OOB | MSG_DONTROUTE | MSG_PEEK val recv : file_descr -> bytes -> int -> int -> msg_flag list -> int Lwt.t (** Wrapper for {!Unix.recv}. On Windows, [recv] writes data into a temporary buffer, then copies it into the given one. *) val recvfrom : file_descr -> bytes -> int -> int -> msg_flag list -> (int * sockaddr) Lwt.t (** Wrapper for {!Unix.recvfrom}. On Windows, [recvfrom] writes data into a temporary buffer, then copies it into the given one. *) val send : file_descr -> bytes -> int -> int -> msg_flag list -> int Lwt.t (** Wrapper for {!Unix.send}. On Windows, [send] copies the given buffer before writing. *) val sendto : file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int Lwt.t (** Wrapper for {!Unix.sendto}. On Windows, [sendto] copies the given buffer before writing. *) val recv_msg : socket:file_descr -> io_vectors:IO_vectors.t -> (int * Unix.file_descr list) Lwt.t (** [recv_msg ~socket ~io_vectors] receives data into a list of io-vectors, plus any file-descriptors that may accompany the messages. It returns a tuple whose first field is the number of bytes received and second is a list of received file descriptors. The messages themselves will be recorded in the provided [io_vectors] list. Data is written directly into the [iov_buffer] buffers. Not implemented on Windows. @since 5.0.0 *) val send_msg : socket:file_descr -> io_vectors:IO_vectors.t -> fds:Unix.file_descr list -> int Lwt.t (** [send_msg ~socket ~io_vectors ~fds] sends data from a list of io-vectors, accompanied with a list of file-descriptors. It returns the number of bytes sent. If fd-passing is not possible on the current system and [fds] is not empty, it raises [Lwt_sys.Not_available "fd_passing"]. Data is written directly from the [io_vectors] buffers. Not implemented on Windows. @since 5.0.0 *) val send_msgto : socket:file_descr -> io_vectors:IO_vectors.t -> fds:Unix.file_descr list -> dest:Unix.sockaddr -> int Lwt.t (** [send_msgto ~socket ~io_vectors ~fds ~dest] is similar to [send_msg] but takes an additional [dest] argument to set the address when using a connection-less socket. Not implemented on Windows. @since 5.4.0 *) type credentials = { cred_pid : int; cred_uid : int; cred_gid : int; } val get_credentials : file_descr -> credentials (** [get_credentials fd] returns credentials information from the given socket. On some platforms, obtaining the peer pid is not possible and it will be set to [-1]. If obtaining credentials is not possible on the current system, it raises [Lwt_sys.Not_available "get_credentials"]. This call is not available on windows. *) (** {3 Socket options} *) type socket_bool_option = Unix.socket_bool_option = | SO_DEBUG | SO_BROADCAST | SO_REUSEADDR | SO_KEEPALIVE | SO_DONTROUTE | SO_OOBINLINE | SO_ACCEPTCONN | TCP_NODELAY | IPV6_ONLY #if OCAML_VERSION >= (4, 12, 0) | SO_REUSEPORT #endif type socket_int_option = Unix.socket_int_option = | SO_SNDBUF | SO_RCVBUF | SO_ERROR [@ocaml.deprecated "Use Unix.getsockopt_error instead."] | SO_TYPE | SO_RCVLOWAT | SO_SNDLOWAT type socket_optint_option = Unix.socket_optint_option = SO_LINGER type socket_float_option = Unix.socket_float_option = | SO_RCVTIMEO | SO_SNDTIMEO (** Note: these options are provided for the sake of completeness only. Lwt places all sockets in non-blocking mode, for which these options are meaningless. Use {!Lwt.pick} with {!Lwt_unix.sleep} or {!Lwt_unix.timeout} for timeouts. *) val getsockopt : file_descr -> socket_bool_option -> bool (** Wrapper for {!Unix.getsockopt} *) val setsockopt : file_descr -> socket_bool_option -> bool -> unit (** Wrapper for {!Unix.setsockopt} *) val getsockopt_int : file_descr -> socket_int_option -> int (** Wrapper for {!Unix.getsockopt_int} *) val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Wrapper for {!Unix.setsockopt_int} *) val getsockopt_optint : file_descr -> socket_optint_option -> int option (** Wrapper for {!Unix.getsockopt_optint} *) val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit (** Wrapper for {!Unix.setsockopt_optint} *) val getsockopt_float : file_descr -> socket_float_option -> float (** Wrapper for {!Unix.getsockopt_float} *) val setsockopt_float : file_descr -> socket_float_option -> float -> unit (** Wrapper for {!Unix.setsockopt_float} *) val getsockopt_error : file_descr -> Unix.error option (** Wrapper for {!Unix.getsockopt_error} *) (** {3 Multicast functions} *) val mcast_set_loop : file_descr -> bool -> unit (** Whether sent multicast messages are received by the sending host *) val mcast_set_ttl : file_descr -> int -> unit (** Set TTL/hops value *) val mcast_add_membership : file_descr -> ?ifname:Unix.inet_addr -> Unix.inet_addr -> unit (** [mcast_add_membership fd ~ifname addr] joins the multicast group [addr] on the network interface [ifname]. *) val mcast_drop_membership : file_descr -> ?ifname:Unix.inet_addr -> Unix.inet_addr -> unit (** [mcast_drop_membership fd ~ifname addr] leaves the multicast group [addr] on the network interface [ifname]. *) (** {2 Host and protocol databases} *) type host_entry = Unix.host_entry = { h_name : string; h_aliases : string array; h_addrtype : socket_domain; h_addr_list : inet_addr array } type protocol_entry = Unix.protocol_entry = { p_name : string; p_aliases : string array; p_proto : int } type service_entry = Unix.service_entry = { s_name : string; s_aliases : string array; s_port : int; s_proto : string } val gethostname : unit -> string Lwt.t (** Wrapper for {!Unix.gethostname} *) val gethostbyname : string -> host_entry Lwt.t (** Wrapper for {!Unix.gethostbyname} *) val gethostbyaddr : inet_addr -> host_entry Lwt.t (** Wrapper for {!Unix.gethostbyaddr} *) val getprotobyname : string -> protocol_entry Lwt.t (** Wrapper for {!Unix.getprotobyname} *) val getprotobynumber : int -> protocol_entry Lwt.t (** Wrapper for {!Unix.getprotobynumber} *) val getservbyname : string -> string -> service_entry Lwt.t (** Wrapper for {!Unix.getservbyname} *) val getservbyport : int -> string -> service_entry Lwt.t (** Wrapper for {!Unix.getservbyport} *) type addr_info = Unix.addr_info = { ai_family : socket_domain; ai_socktype : socket_type; ai_protocol : int; ai_addr : sockaddr; ai_canonname : string; } type getaddrinfo_option = Unix.getaddrinfo_option = | AI_FAMILY of socket_domain | AI_SOCKTYPE of socket_type | AI_PROTOCOL of int | AI_NUMERICHOST | AI_CANONNAME | AI_PASSIVE val getaddrinfo : string -> string -> getaddrinfo_option list -> addr_info list Lwt.t (** Wrapper for {!Unix.getaddrinfo} *) type name_info = Unix.name_info = { ni_hostname : string; ni_service : string; } type getnameinfo_option = Unix.getnameinfo_option = | NI_NOFQDN | NI_NUMERICHOST | NI_NAMEREQD | NI_NUMERICSERV | NI_DGRAM val getnameinfo : sockaddr -> getnameinfo_option list -> name_info Lwt.t (** Wrapper for {!Unix.getnameinfo} *) (** {2 Terminal interface} *) type terminal_io = Unix.terminal_io = { mutable c_ignbrk : bool; mutable c_brkint : bool; mutable c_ignpar : bool; mutable c_parmrk : bool; mutable c_inpck : bool; mutable c_istrip : bool; mutable c_inlcr : bool; mutable c_igncr : bool; mutable c_icrnl : bool; mutable c_ixon : bool; mutable c_ixoff : bool; mutable c_opost : bool; mutable c_obaud : int; mutable c_ibaud : int; mutable c_csize : int; mutable c_cstopb : int; mutable c_cread : bool; mutable c_parenb : bool; mutable c_parodd : bool; mutable c_hupcl : bool; mutable c_clocal : bool; mutable c_isig : bool; mutable c_icanon : bool; mutable c_noflsh : bool; mutable c_echo : bool; mutable c_echoe : bool; mutable c_echok : bool; mutable c_echonl : bool; mutable c_vintr : char; mutable c_vquit : char; mutable c_verase : char; mutable c_vkill : char; mutable c_veof : char; mutable c_veol : char; mutable c_vmin : int; mutable c_vtime : int; mutable c_vstart : char; mutable c_vstop : char; } val tcgetattr : file_descr -> terminal_io Lwt.t (** Wrapper for {!Unix.tcgetattr} *) type setattr_when = Unix.setattr_when = | TCSANOW | TCSADRAIN | TCSAFLUSH val tcsetattr : file_descr -> setattr_when -> terminal_io -> unit Lwt.t (** Wrapper for {!Unix.tcsetattr} *) val tcsendbreak : file_descr -> int -> unit Lwt.t (** Wrapper for {!Unix.tcsendbreak} *) val tcdrain : file_descr -> unit Lwt.t (** Wrapper for {!Unix.tcdrain} *) type flush_queue = Unix.flush_queue = | TCIFLUSH | TCOFLUSH | TCIOFLUSH val tcflush : file_descr -> flush_queue -> unit Lwt.t (** Wrapper for {!Unix.tcflush} *) type flow_action = Unix.flow_action = | TCOOFF | TCOON | TCIOFF | TCION val tcflow : file_descr -> flow_action -> unit Lwt.t (** Wrapper for {!Unix.tcflow} *) (** {2 Configuration (deprecated)} *) (** For system calls that cannot be made asynchronously, Lwt uses one of the following method: *) type async_method = | Async_none (** System calls are made synchronously, and may block the entire program. *) | Async_detach (** System calls are made in another system thread, thus without blocking other Lwt promises. The drawback is that it may degrade performance in some cases. This is the default. *) | Async_switch [@ocaml.deprecated " Use Lwt_unix.Async_detach."] (** @deprecated A synonym for [Async_detach]. This was a different method in the past. *) val default_async_method : unit -> async_method [@@ocaml.deprecated " Will always return Async_detach in Lwt >= 5.0.0. See https://github.com/ocsigen/lwt/issues/572"] (** Returns the default async method. This can be initialized using the environment variable ["LWT_ASYNC_METHOD"] with possible values ["none"], ["detach"] and ["switch"]. @deprecated Will always return [Async_detach] in Lwt 5.0.0. *) val set_default_async_method : async_method -> unit [@@ocaml.deprecated " Will be a no-op in Lwt >= 5.0.0. See https://github.com/ocsigen/lwt/issues/572"] (** Sets the default async method. @deprecated Will be a no-op in Lwt 5.0.0. *) val async_method : unit -> async_method [@@ocaml.deprecated " Will always return Async_detach in Lwt >= 5.0.0. See https://github.com/ocsigen/lwt/issues/572"] (** [async_method ()] returns the async method used in the current thread. @deprecated Will always return [Async_detach] in Lwt 5.0.0. *) val async_method_key : async_method Lwt.key [@@ocaml.deprecated " Will be ignored in Lwt >= 5.0.0. See https://github.com/ocsigen/lwt/issues/572"] (** The key for storing the local async method. @deprecated Will be ignored in Lwt 5.0.0. *) val with_async_none : (unit -> 'a) -> 'a [@@ocaml.deprecated " Will have no effect in Lwt >= 5.0.0. See https://github.com/ocsigen/lwt/issues/572"] (** [with_async_none f] is a shorthand for: {[ Lwt.with_value async_method_key (Some Async_none) f ]} @deprecated Will have no effect in Lwt 5.0.0. *) val with_async_detach : (unit -> 'a) -> 'a [@@ocaml.deprecated " Will have no effect in Lwt >= 5.0.0. See https://github.com/ocsigen/lwt/issues/572"] (** [with_async_detach f] is a shorthand for: {[ Lwt.with_value async_method_key (Some Async_detach) f ]} @deprecated Will have no effect in Lwt 5.0.0. *) val with_async_switch : (unit -> 'a) -> 'a [@@ocaml.deprecated " Will have no effect in Lwt >= 5.0.0. See https://github.com/ocsigen/lwt/issues/572"] (** [with_async_switch f] is a shorthand for: {[ Lwt.with_value async_method_key (Some Async_switch) f ]} @deprecated Will have no effect in Lwt 5.0.0. *) (** {2 Low-level interaction} *) exception Retry (** If an action raises {!Retry}, it will be requeued until the {b file descriptor} becomes readable/writable again. *) exception Retry_read (** If an action raises {!Retry_read}, it will be requeued until the {b file descriptor} becomes readable. *) exception Retry_write (** If an action raises {!Retry_read}, it will be requeued until the {b file descriptor} becomes writables. *) type io_event = Read | Write val wrap_syscall : io_event -> file_descr -> (unit -> 'a) -> 'a Lwt.t (** [wrap_syscall set fd action] wrap an action on a {b file descriptor}. It tries to execute action, and if it can not be performed immediately without blocking, it is registered for later. In the latter case, if the promise is canceled, [action] is removed from [set]. *) val check_descriptor : file_descr -> unit (** [check_descriptor fd] raise an exception if [fd] is not in the state [Open]. *) val register_action : io_event -> file_descr -> (unit -> 'a) -> 'a Lwt.t (** [register_action set fd action] registers [action] on [fd]. When [fd] becomes [readable]/[writable] [action] is called. Note: - you must call [check_descriptor fd] before calling [register_action] - you should prefer using {!wrap_syscall} *) type 'a job (** Type of job descriptions. A job description describe how to call a C function and how to get its result. The C function may be executed in another system thread. *) val run_job : ?async_method : async_method -> 'a job -> 'a Lwt.t (** [run_job ?async_method job] starts [job] and wait for its termination. The [~async_method] argument will be ignored in Lwt 5.0.0, and this function will always act as if [~async_method:Async_detach] is passed. The async method is chosen follow: - if the optional parameter [async_method] is specified, it is used, - otherwise if the local key {!async_method_key} is set in the current thread, it is used, - otherwise the default method (returned by {!default_async_method}) is used. If the method is [Async_none] then the job is run synchronously and may block the current system thread, thus blocking all Lwt threads. If the method is [Async_detach] then the job is run in another system thread, unless the the maximum number of worker threads has been reached (as given by {!pool_size}). If the method is [Async_switch] then the job is run synchronously and if it blocks, execution will continue in another system thread (unless the limit is reached). *) val abort_jobs : exn -> unit (** [abort_jobs exn] make all pending jobs to fail with exn. Note that this does not abort the real job (i.e. the C function executing it), just the lwt thread for it. *) val cancel_jobs : unit -> unit (** [cancel_jobs ()] is the same as [abort_jobs Lwt.Canceled]. *) val wait_for_jobs : unit -> unit Lwt.t (** Wait for all pending jobs to terminate. *) val execute_job : ?async_method : async_method -> job : 'a job -> result : ('a job -> 'b) -> free : ('a job -> unit) -> 'b Lwt.t [@@ocaml.deprecated " Use Lwt_unix.run_job."] (** @deprecated Use [run_job]. *) (** {2 Notifications} *) (** Lwt internally use a pipe to send notification to the main thread. The following functions allow to use this pipe. *) val make_notification : ?once : bool -> (unit -> unit) -> int (** [make_notification ?once f] registers a new notifier. It returns the id of the notifier. Each time a notification with this id is received, [f] is called. if [once] is specified, then the notification is stopped after the first time it is received. It defaults to [false]. *) val send_notification : int -> unit (** [send_notification id] sends a notification. This function is thread-safe. *) val stop_notification : int -> unit (** Stop the given notification. Note that you should not reuse the id after the notification has been stopped, the result is unspecified if you do so. *) val call_notification : int -> unit (** Call the handler associated to the given notification. Note that if the notification was defined with [once = true] it is removed. *) val set_notification : int -> (unit -> unit) -> unit (** [set_notification id f] replace the function associated to the notification by [f]. It raises [Not_found] if the given notification is not found. *) (** {2 System threads pool} *) (** If the program is using the async method [Async_detach] or [Async_switch], Lwt will launch system threads to execute blocking system calls asynchronously. *) val pool_size : unit -> int (** Maximum number of system threads that can be started. If this limit is reached, jobs will be executed synchronously. *) val set_pool_size : int -> unit (** Change the size of the pool. *) val thread_count : unit -> int (** The number of system threads running (excluding this one). *) val thread_waiting_count : unit -> int (** The number threads waiting for a job. *) (** {2 CPUs} *) val get_cpu : unit -> int (** [get_cpu ()] returns the number of the CPU the current thread is running on. *) val get_affinity : ?pid : int -> unit -> int list (** [get_affinity ?pid ()] returns the list of CPUs the process with pid [pid] is allowed to run on. If [pid] is not specified then the affinity of the current process is returned. *) val set_affinity : ?pid : int -> int list -> unit (** [set_affinity ?pid cpus] sets the list of CPUs the given process is allowed to run on. *) (** {2 Versioned interfaces} *) (** Versioned variants of APIs undergoing breaking changes. *) module Versioned : sig val bind_1 : file_descr -> sockaddr -> unit [@@ocaml.deprecated " Deprecated in favor of Lwt_unix.bind. See https://github.com/ocsigen/lwt/issues/230"] (** Old version of {!Lwt_unix.bind}. The current {!Lwt_unix.bind} evaluates to a promise, because the internal [bind(2)] system call can block if the given socket is a Unix domain socket. @deprecated Use {!Lwt_unix.bind}. @since 2.7.0 *) val bind_2 : file_descr -> sockaddr -> unit Lwt.t [@@ocaml.deprecated " In Lwt >= 3.0.0, this is an alias for Lwt_unix.bind."] (** Since Lwt 3.0.0, this is just an alias for {!Lwt_unix.bind}. @deprecated Use {!Lwt_unix.bind}. @since 2.7.0 *) val recv_msg_2 : socket:file_descr -> io_vectors:IO_vectors.t -> (int * Unix.file_descr list) Lwt.t [@@ocaml.deprecated " In Lwt >= 5.0.0, this is an alias for Lwt_unix.recv_msg."] (** Since Lwt 5.0.0, this is an alias for {!Lwt_unix.recv_msg}. @deprecated Use {!Lwt_unix.recv_msg}. @since 4.3.0 *) val send_msg_2 : socket:file_descr -> io_vectors:IO_vectors.t -> fds:Unix.file_descr list -> int Lwt.t [@@ocaml.deprecated " In Lwt >= 5.0.0, this is an alias for Lwt_unix.send_msg."] (** Since Lwt 5.0.0, this is an alias for {!Lwt_unix.send_msg}. @deprecated Use {!Lwt_unix.send_msg}. @since 4.3.0 *) end (**/**) val run : 'a Lwt.t -> 'a [@@ocaml.deprecated " Use Lwt_main.run."] (** @deprecated Use [Lwt_main.run]. *) val has_wait4 : bool [@@ocaml.deprecated " Use Lwt_sys.have `wait4."] (** @deprecated Use [Lwt_sys.have `wait4]. *) val somaxconn : unit -> int [@@ocaml.deprecated " This is an internal function."] (** @deprecated This is for internal use only. *) val retained : 'a -> bool ref (** @deprecated Used for testing. *) val read_bigarray : string -> file_descr -> IO_vectors._bigarray -> int -> int -> int Lwt.t [@@ocaml.deprecated " This is an internal function."] (** @deprecated This is for internal use only. *) val write_bigarray : string -> file_descr -> IO_vectors._bigarray -> int -> int -> int Lwt.t [@@ocaml.deprecated " This is an internal function."] (** @deprecated This is for internal use only. *) lwt-5.9.1/src/unix/lwt_unix.h000066400000000000000000000302561476253734400161550ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #ifndef __LWT_UNIX_H #define __LWT_UNIX_H #include "lwt_config.h" #include #include #include #include // The following macro is for backwards compatibility. // It is given an `lwt_` prefix to avoid name collisions for code which // include both this file and alloc.h. #if OCAML_VERSION < 50000 #define lwt_convert_flag_list(flags, table) \ caml_convert_flag_list((flags), (int *)(table)) #else #define lwt_convert_flag_list caml_convert_flag_list #endif /* The macro to get the file-descriptor from a value. */ #if defined(LWT_ON_WINDOWS) #define FD_val(value) win_CRT_fd_of_filedescr(value) #else #define FD_val(value) Int_val(value) #endif /* Macro to extract a libev loop from a caml value. */ #define Ev_loop_val(value) *(struct ev_loop **)Data_custom_val(value) /* +-----------------------------------------------------------------+ | Utils | +-----------------------------------------------------------------+ */ /* Allocate the given amount of memory and abort the program if there is no free memory left. */ void *lwt_unix_malloc(size_t size); void *lwt_unix_realloc(void *ptr, size_t size); /* Same as [strdup] and abort the program if there is not memory left. */ char *lwt_unix_strdup(char *string); /* Helpers for allocating structures. */ #define lwt_unix_new(type) (type *)lwt_unix_malloc(sizeof(type)) #define lwt_unix_new_plus(type, size) \ (type *)lwt_unix_malloc(sizeof(type) + size) /* Raise [Lwt_unix.Not_available]. */ void lwt_unix_not_available(char const *feature) Noreturn; #define LWT_NOT_AVAILABLE_BYTE(prim) \ CAMLprim value lwt_##prim(value *a1, int a2) \ { \ lwt_unix_not_available(#prim); \ } #define LWT_NOT_AVAILABLE1(prim) \ CAMLprim value lwt_##prim(value a1) { lwt_unix_not_available(#prim); } #define LWT_NOT_AVAILABLE2(prim) \ CAMLprim value lwt_##prim(value a1, value a2) \ { \ lwt_unix_not_available(#prim); \ } #define LWT_NOT_AVAILABLE3(prim) \ CAMLprim value lwt_##prim(value a1, value a2, value a3) \ { \ lwt_unix_not_available(#prim); \ } #define LWT_NOT_AVAILABLE4(prim) \ CAMLprim value lwt_##prim(value a1, value a2, value a3, value a4) \ { \ lwt_unix_not_available(#prim); \ } #define LWT_NOT_AVAILABLE5(prim) \ CAMLprim value lwt_##prim(value a1, value a2, value a3, value a4, \ value a5) \ { \ lwt_unix_not_available(#prim); \ } #define LWT_NOT_AVAILABLE6(prim) \ CAMLprim value lwt_##prim(value a1, value a2, value a3, value a4, \ value a5, value a6) \ { \ lwt_unix_not_available(#prim); \ } /* +-----------------------------------------------------------------+ | Notifications | +-----------------------------------------------------------------+ */ /* Sends a notification for the given id. */ void lwt_unix_send_notification(intnat id); /* +-----------------------------------------------------------------+ | Threading | +-----------------------------------------------------------------+ */ #if defined(HAVE_PTHREAD) #include typedef pthread_t lwt_unix_thread; typedef pthread_mutex_t lwt_unix_mutex; typedef pthread_cond_t lwt_unix_condition; #elif defined(LWT_ON_WINDOWS) typedef DWORD lwt_unix_thread; typedef CRITICAL_SECTION lwt_unix_mutex; typedef struct lwt_unix_condition lwt_unix_condition; #else #error "lwt.unix requires pthreads on Unix-like systems" #endif /* Launch a thread in detached mode. */ int lwt_unix_launch_thread(void *(*start)(void *), void *data); /* Return a handle to the currently running thread. */ lwt_unix_thread lwt_unix_thread_self(); /* Returns whether two thread handles refer to the same thread. */ int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2); /* Initialises a mutex. */ void lwt_unix_mutex_init(lwt_unix_mutex *mutex); /* Destroy a mutex. */ void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex); /* Lock a mutex. */ void lwt_unix_mutex_lock(lwt_unix_mutex *mutex); /* Unlock a mutex. */ void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex); /* Initialises a condition variable. */ void lwt_unix_condition_init(lwt_unix_condition *condition); /* Destroy a condition variable. */ void lwt_unix_condition_destroy(lwt_unix_condition *condition); /* Signal a condition variable. */ void lwt_unix_condition_signal(lwt_unix_condition *condition); /* Broadcast a signal on a condition variable. */ void lwt_unix_condition_broadcast(lwt_unix_condition *condition); /* Wait for a signal on a condition variable. */ void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex); /* +-----------------------------------------------------------------+ | Detached jobs | +-----------------------------------------------------------------+ */ /* How job are executed. */ enum lwt_unix_async_method { /* Synchronously. */ LWT_UNIX_ASYNC_METHOD_NONE = 0, /* Asynchronously, on another thread. */ LWT_UNIX_ASYNC_METHOD_DETACH = 1, /* Currently a synonym for DETACH. This was a different strategy in the past. */ LWT_UNIX_ASYNC_METHOD_SWITCH = 2 }; /* Type of job execution modes. */ typedef enum lwt_unix_async_method lwt_unix_async_method; /* State of a job. */ enum lwt_unix_job_state { /* The job has not yet started. */ LWT_UNIX_JOB_STATE_PENDING, /* The job is running. */ LWT_UNIX_JOB_STATE_RUNNING, /* The job is done. */ LWT_UNIX_JOB_STATE_DONE }; /* A job descriptor. */ struct lwt_unix_job { /* The next job in the queue. */ struct lwt_unix_job *next; /* Id used to notify the main thread in case the job do not terminate immediately. */ intnat notification_id; /* The function to call to do the work. This function must not: - access or allocate OCaml block values (tuples, strings, ...), - call OCaml code. */ void (*worker)(struct lwt_unix_job *job); /* The function to call to extract the result and free memory allocated by the job. Note: if you want to raise an exception, be sure to free resources before raising it! It has been introduced in Lwt 2.3.3. */ value (*result)(struct lwt_unix_job *job); /* State of the job. */ enum lwt_unix_job_state state; /* Is the main thread still waiting for the job ? */ int fast; /* Mutex to protect access to [state] and [fast]. */ lwt_unix_mutex mutex; /* The async method in used by the job. */ lwt_unix_async_method async_method; }; /* Type of job descriptors. */ typedef struct lwt_unix_job *lwt_unix_job; /* Type of worker functions. */ typedef void (*lwt_unix_job_worker)(lwt_unix_job job); /* Type of result functions. */ typedef value (*lwt_unix_job_result)(lwt_unix_job job); /* Allocate a caml custom value for the given job. */ value lwt_unix_alloc_job(lwt_unix_job job); /* Free resourecs allocated for this job and free it. */ void lwt_unix_free_job(lwt_unix_job job); /* +-----------------------------------------------------------------+ | Helpers for writing jobs | +-----------------------------------------------------------------+ */ /* Allocate a job structure and set its worker and result fields. - VAR is the name of the job variable. It is usually "job". - FUNC is the suffix of the structure name and functions of this job. It is usually the name of the function that is wrapped. - SIZE is the dynamic size to allocate at the end of the structure, in case it ends ends with something of the form: char data[]); */ #define LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE) \ struct job_##FUNC *VAR = lwt_unix_new_plus(struct job_##FUNC, SIZE); \ VAR->job.worker = (lwt_unix_job_worker)worker_##FUNC; \ VAR->job.result = (lwt_unix_job_result)result_##FUNC /* Same as LWT_UNIX_INIT_JOB, but also stores a string argument named ARG at the end of the job structure. The offset of the copied string is assigned to the field VAR->ARG. The structure must ends with: char data[]; */ #define LWT_UNIX_INIT_JOB_STRING(VAR, FUNC, SIZE, ARG) \ mlsize_t __len = caml_string_length(ARG); \ LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE + __len + 1); \ VAR->ARG = VAR->data + SIZE; \ memcpy(VAR->ARG, String_val(ARG), __len + 1) /* Same as LWT_UNIX_INIT_JOB, but also stores two string arguments named ARG1 and ARG2 at the end of the job structure. The offsets of the copied strings are assigned to the fields VAR->ARG1 and VAR->ARG2. The structure definition must ends with: char data[]; */ #define LWT_UNIX_INIT_JOB_STRING2(VAR, FUNC, SIZE, ARG1, ARG2) \ mlsize_t __len1 = caml_string_length(ARG1); \ mlsize_t __len2 = caml_string_length(ARG2); \ LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE + __len1 + __len2 + 2); \ VAR->ARG1 = VAR->data + SIZE; \ VAR->ARG2 = VAR->data + SIZE + __len1 + 1; \ memcpy(VAR->ARG1, String_val(ARG1), __len1 + 1); \ memcpy(VAR->ARG2, String_val(ARG2), __len2 + 1) /* If TEST is true, it frees the job and raises Unix.Unix_error using the value of errno stored in the field error_code. */ #define LWT_UNIX_CHECK_JOB(VAR, TEST, NAME) \ if (TEST) { \ int error_code = VAR->error_code; \ lwt_unix_free_job(&VAR->job); \ unix_error(error_code, NAME, Nothing); \ } /* If TEST is true, it frees the job and raises Unix.Unix_error using the value of errno stored in the field error_code and uses the C string ARG for the third field of Unix.Unix_error. */ #define LWT_UNIX_CHECK_JOB_ARG(VAR, TEST, NAME, ARG) \ if (TEST) { \ int error_code = VAR->error_code; \ value arg = caml_copy_string(ARG); \ lwt_unix_free_job(&VAR->job); \ unix_error(error_code, NAME, arg); \ } /* +-----------------------------------------------------------------+ | Deprecated | +-----------------------------------------------------------------+ */ /* Define not implement methods. Deprecated: it is for the old mechanism with three externals. */ #define LWT_UNIX_JOB_NOT_IMPLEMENTED(name) \ CAMLprim value lwt_unix_##name##_job(value Unit) \ { \ caml_invalid_argument("not implemented"); \ } \ \ CAMLprim value lwt_unix_##name##_result(value Unit) \ { \ caml_invalid_argument("not implemented"); \ } \ \ CAMLprim value lwt_unix_##name##_free(value Unit) \ { \ caml_invalid_argument("not implemented"); \ } #endif /* __LWT_UNIX_H */ lwt-5.9.1/src/unix/lwt_unix_stubs.c000066400000000000000000001035551476253734400173730ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #define _GNU_SOURCE #define _POSIX_PTHREAD_SEMANTICS #include #include #include #include #include #include #include #include #include #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #endif #if defined(HAVE_EVENTFD) #include #endif //#define DEBUG_MODE #if defined(DEBUG_MODE) #include #define DEBUG(fmt, ...) \ { \ fprintf(stderr, "lwt-debug[%d]: %s: " fmt "\n", \ (pid_t)syscall(SYS_gettid), __FUNCTION__, ##__VA_ARGS__); \ fflush(stderr); \ } #else #define DEBUG(fmt, ...) #endif /* +-----------------------------------------------------------------+ | Utils | +-----------------------------------------------------------------+ */ void *lwt_unix_malloc(size_t size) { void *ptr = malloc(size); if (ptr == NULL) { perror("cannot allocate memory"); abort(); } return ptr; } void *lwt_unix_realloc(void *ptr, size_t size) { void *new_ptr = realloc(ptr, size); if (new_ptr == NULL) { perror("cannot allocate memory"); abort(); } return new_ptr; } char *lwt_unix_strdup(char *str) { char *new_str = strdup(str); if (new_str == NULL) { perror("cannot allocate memory"); abort(); } return new_str; } void lwt_unix_not_available(char const *feature) { caml_raise_with_arg(*caml_named_value("lwt:not-available"), caml_copy_string(feature)); } /* +-----------------------------------------------------------------+ | Operation on bigarrays | +-----------------------------------------------------------------+ */ CAMLprim value lwt_unix_blit(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) { memmove((char *)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2), (char *)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1), Long_val(val_len)); return Val_unit; } CAMLprim value lwt_unix_blit_from_bytes(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) { memcpy((char *)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2), Bytes_val(val_buf1) + Long_val(val_ofs1), Long_val(val_len)); return Val_unit; } CAMLprim value lwt_unix_blit_from_string(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) { memcpy((char *)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2), String_val(val_buf1) + Long_val(val_ofs1), Long_val(val_len)); return Val_unit; } CAMLprim value lwt_unix_blit_to_bytes(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) { memcpy(Bytes_val(val_buf2) + Long_val(val_ofs2), (char *)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1), Long_val(val_len)); return Val_unit; } CAMLprim value lwt_unix_fill_bytes(value val_buf, value val_ofs, value val_len, value val_char) { memset((char *)Caml_ba_data_val(val_buf) + Long_val(val_ofs), Int_val(val_char), Long_val(val_len)); return Val_unit; } CAMLprim value lwt_unix_mapped(value v_bstr) { return Val_bool(Caml_ba_array_val(v_bstr)->flags & CAML_BA_MAPPED_FILE); } /* +-----------------------------------------------------------------+ | Byte order | +-----------------------------------------------------------------+ */ value lwt_unix_system_byte_order() { #ifdef ARCH_BIG_ENDIAN return Val_int(1); #else return Val_int(0); #endif } /* +-----------------------------------------------------------------+ | Threading | +-----------------------------------------------------------------+ */ #if defined(HAVE_PTHREAD) int lwt_unix_launch_thread(void *(*start)(void *), void *data) { pthread_t thread; pthread_attr_t attr; sigset_t mask, old_mask; pthread_attr_init(&attr); /* The thread is created in detached state so we do not have to join it when it terminates: */ pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); /* Block all signals, otherwise ocaml handlers defined with the module Sys may be executed in the new thread, oops... */ sigfillset(&mask); pthread_sigmask(SIG_SETMASK, &mask, &old_mask); int zero_if_created_otherwise_errno = pthread_create(&thread, &attr, start, data); /* Restore the signal mask for the calling thread. */ pthread_sigmask(SIG_SETMASK, &old_mask, NULL); pthread_attr_destroy(&attr); return zero_if_created_otherwise_errno; } lwt_unix_thread lwt_unix_thread_self() { return pthread_self(); } int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2) { return pthread_equal(thread1, thread2); } void lwt_unix_mutex_init(lwt_unix_mutex *mutex) { pthread_mutex_init(mutex, NULL); } void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex) { pthread_mutex_destroy(mutex); } void lwt_unix_mutex_lock(lwt_unix_mutex *mutex) { pthread_mutex_lock(mutex); } void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex) { pthread_mutex_unlock(mutex); } void lwt_unix_condition_init(lwt_unix_condition *condition) { pthread_cond_init(condition, NULL); } void lwt_unix_condition_destroy(lwt_unix_condition *condition) { pthread_cond_destroy(condition); } void lwt_unix_condition_signal(lwt_unix_condition *condition) { pthread_cond_signal(condition); } void lwt_unix_condition_broadcast(lwt_unix_condition *condition) { pthread_cond_broadcast(condition); } void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex) { pthread_cond_wait(condition, mutex); } #elif defined(LWT_ON_WINDOWS) int lwt_unix_launch_thread(void *(*start)(void *), void *data) { HANDLE handle = CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start, data, 0, NULL); if (handle) CloseHandle(handle); return 0; } lwt_unix_thread lwt_unix_thread_self() { return GetCurrentThreadId(); } int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2) { return thread1 == thread2; } void lwt_unix_mutex_init(lwt_unix_mutex *mutex) { InitializeCriticalSection(mutex); } void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex) { DeleteCriticalSection(mutex); } void lwt_unix_mutex_lock(lwt_unix_mutex *mutex) { EnterCriticalSection(mutex); } void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex) { LeaveCriticalSection(mutex); } struct wait_list { HANDLE event; struct wait_list *next; }; struct lwt_unix_condition { CRITICAL_SECTION mutex; struct wait_list *waiters; }; void lwt_unix_condition_init(lwt_unix_condition *condition) { InitializeCriticalSection(&condition->mutex); condition->waiters = NULL; } void lwt_unix_condition_destroy(lwt_unix_condition *condition) { DeleteCriticalSection(&condition->mutex); } void lwt_unix_condition_signal(lwt_unix_condition *condition) { struct wait_list *node; EnterCriticalSection(&condition->mutex); node = condition->waiters; if (node) { condition->waiters = node->next; SetEvent(node->event); } LeaveCriticalSection(&condition->mutex); } void lwt_unix_condition_broadcast(lwt_unix_condition *condition) { struct wait_list *node; EnterCriticalSection(&condition->mutex); for (node = condition->waiters; node; node = node->next) SetEvent(node->event); condition->waiters = NULL; LeaveCriticalSection(&condition->mutex); } void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex) { struct wait_list node; /* Create the event for the notification. */ node.event = CreateEvent(NULL, FALSE, FALSE, NULL); /* Add the node to the condition. */ EnterCriticalSection(&condition->mutex); node.next = condition->waiters; condition->waiters = &node; LeaveCriticalSection(&condition->mutex); /* Release the mutex. */ LeaveCriticalSection(mutex); /* Wait for a signal. */ WaitForSingleObject(node.event, INFINITE); /* The event is no more used. */ CloseHandle(node.event); /* Re-acquire the mutex. */ EnterCriticalSection(mutex); } #else #error "no threading library available!" #endif /* +-----------------------------------------------------------------+ | Socketpair on windows | +-----------------------------------------------------------------+ */ #if defined(LWT_ON_WINDOWS) #if OCAML_VERSION < 41400 static int win_set_inherit(HANDLE fd, BOOL inherit) { if (! SetHandleInformation(fd, HANDLE_FLAG_INHERIT, inherit ? HANDLE_FLAG_INHERIT : 0)) { win32_maperr(GetLastError()); return -1; } return 0; } #endif static SOCKET lwt_win_socket(int domain, int type, int protocol, LPWSAPROTOCOL_INFO info, BOOL inherit) { SOCKET s; DWORD flags = WSA_FLAG_OVERLAPPED; #ifndef WSA_FLAG_NO_HANDLE_INHERIT #define WSA_FLAG_NO_HANDLE_INHERIT 0x80 #endif if (! inherit) flags |= WSA_FLAG_NO_HANDLE_INHERIT; s = WSASocket(domain, type, protocol, info, 0, flags); if (s == INVALID_SOCKET) { if (! inherit && WSAGetLastError() == WSAEINVAL) { /* WSASocket probably doesn't suport WSA_FLAG_NO_HANDLE_INHERIT, * retry without. */ flags &= ~(DWORD)WSA_FLAG_NO_HANDLE_INHERIT; s = WSASocket(domain, type, protocol, info, 0, flags); if (s == INVALID_SOCKET) goto err; win_set_inherit((HANDLE) s, FALSE); return s; } goto err; } return s; err: win32_maperr(WSAGetLastError()); return INVALID_SOCKET; } static void lwt_unix_socketpair(int domain, int type, int protocol, SOCKET sockets[2], BOOL inherit) { union { struct sockaddr_in inaddr; struct sockaddr_in6 inaddr6; struct sockaddr addr; } a; SOCKET listener; int addrlen; int reuse = 1; DWORD err; if (domain != PF_INET && domain != PF_INET6) unix_error(ENOPROTOOPT, "socketpair", Nothing); sockets[0] = INVALID_SOCKET; sockets[1] = INVALID_SOCKET; listener = lwt_win_socket(domain, type, protocol, NULL, inherit); if (listener == INVALID_SOCKET) goto failure; memset(&a, 0, sizeof(a)); if (domain == PF_INET) { a.inaddr.sin_family = domain; a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); a.inaddr.sin_port = 0; } else { a.inaddr6.sin6_family = domain; a.inaddr6.sin6_addr = in6addr_loopback; a.inaddr6.sin6_port = 0; } if (setsockopt(listener, SOL_SOCKET, SO_REUSEADDR, (char *)&reuse, sizeof(reuse)) == -1) goto failure; addrlen = domain == PF_INET ? sizeof(a.inaddr) : sizeof(a.inaddr6); if (bind(listener, &a.addr, addrlen) == SOCKET_ERROR) goto failure; memset(&a, 0, sizeof(a)); if (getsockname(listener, &a.addr, &addrlen) == SOCKET_ERROR) goto failure; if (domain == PF_INET) { a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); a.inaddr.sin_family = AF_INET; } else { a.inaddr6.sin6_addr = in6addr_loopback; a.inaddr6.sin6_family = AF_INET6; } if (listen(listener, 1) == SOCKET_ERROR) goto failure; sockets[0] = lwt_win_socket(domain, type, protocol, NULL, inherit); if (sockets[0] == INVALID_SOCKET) goto failure; addrlen = domain == PF_INET ? sizeof(a.inaddr) : sizeof(a.inaddr6); if (connect(sockets[0], &a.addr, addrlen) == SOCKET_ERROR) goto failure; sockets[1] = accept(listener, NULL, NULL); if (sockets[1] == INVALID_SOCKET) goto failure; closesocket(listener); return; failure: err = WSAGetLastError(); closesocket(listener); closesocket(sockets[0]); closesocket(sockets[1]); win32_maperr(err); uerror("socketpair", Nothing); } static const int socket_domain_table[] = {PF_UNIX, PF_INET, PF_INET6}; static const int socket_type_table[] = {SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET}; CAMLprim value lwt_unix_socketpair_stub(value cloexec, value domain, value type, value protocol) { CAMLparam4(cloexec, domain, type, protocol); CAMLlocal1(result); SOCKET sockets[2]; lwt_unix_socketpair(socket_domain_table[Int_val(domain)], socket_type_table[Int_val(type)], Int_val(protocol), sockets, ! unix_cloexec_p(cloexec)); result = caml_alloc_tuple(2); Store_field(result, 0, win_alloc_socket(sockets[0])); Store_field(result, 1, win_alloc_socket(sockets[1])); CAMLreturn(result); } #endif /* +-----------------------------------------------------------------+ | Notifications | +-----------------------------------------------------------------+ */ /* The mutex used to send and receive notifications. */ static lwt_unix_mutex notification_mutex; /* All pending notifications. */ static intnat *notifications = NULL; /* The size of the notification buffer. */ static long notification_count = 0; /* The index to the next available cell in the notification buffer. */ static long notification_index = 0; /* The mode currently used for notifications. */ enum notification_mode { /* Not yet initialized. */ NOTIFICATION_MODE_NOT_INITIALIZED, /* Initialized but no mode defined. */ NOTIFICATION_MODE_NONE, /* Using an eventfd. */ NOTIFICATION_MODE_EVENTFD, /* Using a pipe. */ NOTIFICATION_MODE_PIPE, /* Using a pair of sockets (only on windows). */ NOTIFICATION_MODE_WINDOWS }; /* The current notification mode. */ static enum notification_mode notification_mode = NOTIFICATION_MODE_NOT_INITIALIZED; /* Send one notification. */ static int (*notification_send)(); /* Read one notification. */ static int (*notification_recv)(); static void init_notifications() { lwt_unix_mutex_init(¬ification_mutex); notification_count = 4096; notifications = (intnat *)lwt_unix_malloc(notification_count * sizeof(intnat)); } static void resize_notifications() { long new_notification_count = notification_count * 2; intnat *new_notifications = (intnat *)lwt_unix_malloc(new_notification_count * sizeof(intnat)); memcpy((void *)new_notifications, (void *)notifications, notification_count * sizeof(intnat)); free(notifications); notifications = new_notifications; notification_count = new_notification_count; } void lwt_unix_send_notification(intnat id) { int ret; #if !defined(LWT_ON_WINDOWS) sigset_t new_mask; sigset_t old_mask; int error; sigfillset(&new_mask); pthread_sigmask(SIG_SETMASK, &new_mask, &old_mask); #else DWORD error; #endif lwt_unix_mutex_lock(¬ification_mutex); if (notification_index > 0) { /* There is already a pending notification in the buffer, no need to signal the main thread. */ if (notification_index == notification_count) resize_notifications(); notifications[notification_index++] = id; } else { /* There is none, notify the main thread. */ notifications[notification_index++] = id; ret = notification_send(); #if defined(LWT_ON_WINDOWS) if (ret == SOCKET_ERROR) { error = WSAGetLastError(); if (error != WSANOTINITIALISED) { lwt_unix_mutex_unlock(¬ification_mutex); win32_maperr(error); uerror("send_notification", Nothing); } /* else we're probably shutting down, so ignore the error */ } #else if (ret < 0) { error = errno; lwt_unix_mutex_unlock(¬ification_mutex); pthread_sigmask(SIG_SETMASK, &old_mask, NULL); unix_error(error, "send_notification", Nothing); } #endif } lwt_unix_mutex_unlock(¬ification_mutex); #if !defined(LWT_ON_WINDOWS) pthread_sigmask(SIG_SETMASK, &old_mask, NULL); #endif } value lwt_unix_send_notification_stub(value id) { lwt_unix_send_notification(Long_val(id)); return Val_unit; } value lwt_unix_recv_notifications() { int ret, i, current_index; value result; #if !defined(LWT_ON_WINDOWS) sigset_t new_mask; sigset_t old_mask; int error; sigfillset(&new_mask); pthread_sigmask(SIG_SETMASK, &new_mask, &old_mask); #else DWORD error; #endif lwt_unix_mutex_lock(¬ification_mutex); /* Receive the signal. */ ret = notification_recv(); #if defined(LWT_ON_WINDOWS) if (ret == SOCKET_ERROR) { error = WSAGetLastError(); lwt_unix_mutex_unlock(¬ification_mutex); win32_maperr(error); uerror("recv_notifications", Nothing); } #else if (ret < 0) { error = errno; lwt_unix_mutex_unlock(¬ification_mutex); pthread_sigmask(SIG_SETMASK, &old_mask, NULL); unix_error(error, "recv_notifications", Nothing); } #endif do { /* release the mutex while calling caml_alloc, which may call gc and switch the thread, resulting in a classical deadlock, when thread in question tries another send */ current_index = notification_index; lwt_unix_mutex_unlock(¬ification_mutex); result = caml_alloc_tuple(current_index); lwt_unix_mutex_lock(¬ification_mutex); /* check that no new notifications appeared meanwhile (rare) */ } while (current_index != notification_index); /* Read all pending notifications. */ for (i = 0; i < notification_index; i++) Field(result, i) = Val_long(notifications[i]); /* Reset the index. */ notification_index = 0; lwt_unix_mutex_unlock(¬ification_mutex); #if !defined(LWT_ON_WINDOWS) pthread_sigmask(SIG_SETMASK, &old_mask, NULL); #endif return result; } #if defined(LWT_ON_WINDOWS) static SOCKET socket_r, socket_w; static int windows_notification_send() { char buf = '!'; return send(socket_w, &buf, 1, 0); } static int windows_notification_recv() { char buf; return recv(socket_r, &buf, 1, 0); } value lwt_unix_init_notification() { SOCKET sockets[2]; switch (notification_mode) { case NOTIFICATION_MODE_NOT_INITIALIZED: notification_mode = NOTIFICATION_MODE_NONE; init_notifications(); break; case NOTIFICATION_MODE_WINDOWS: notification_mode = NOTIFICATION_MODE_NONE; closesocket(socket_r); closesocket(socket_w); break; case NOTIFICATION_MODE_NONE: break; default: caml_failwith("notification system in unknown state"); } /* Since pipes do not works with select, we need to use a pair of sockets. */ lwt_unix_socketpair(AF_INET, SOCK_STREAM, IPPROTO_TCP, sockets, FALSE); socket_r = sockets[0]; socket_w = sockets[1]; notification_mode = NOTIFICATION_MODE_WINDOWS; notification_send = windows_notification_send; notification_recv = windows_notification_recv; return win_alloc_socket(socket_r); } #else /* defined(LWT_ON_WINDOWS) */ static void set_close_on_exec(int fd) { int flags = fcntl(fd, F_GETFD, 0); if (flags == -1 || fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1) uerror("set_close_on_exec", Nothing); } #if defined(HAVE_EVENTFD) static int notification_fd; static int eventfd_notification_send() { uint64_t buf = 1; return write(notification_fd, (char *)&buf, 8); } static int eventfd_notification_recv() { uint64_t buf; return read(notification_fd, (char *)&buf, 8); } #endif /* defined(HAVE_EVENTFD) */ static int notification_fds[2]; static int pipe_notification_send() { char buf = 0; return write(notification_fds[1], &buf, 1); } static int pipe_notification_recv() { char buf; return read(notification_fds[0], &buf, 1); } value lwt_unix_init_notification() { switch (notification_mode) { #if defined(HAVE_EVENTFD) case NOTIFICATION_MODE_EVENTFD: notification_mode = NOTIFICATION_MODE_NONE; if (close(notification_fd) == -1) uerror("close", Nothing); break; #endif case NOTIFICATION_MODE_PIPE: notification_mode = NOTIFICATION_MODE_NONE; if (close(notification_fds[0]) == -1) uerror("close", Nothing); if (close(notification_fds[1]) == -1) uerror("close", Nothing); break; case NOTIFICATION_MODE_NOT_INITIALIZED: notification_mode = NOTIFICATION_MODE_NONE; init_notifications(); break; case NOTIFICATION_MODE_NONE: break; default: caml_failwith("notification system in unknown state"); } #if defined(HAVE_EVENTFD) notification_fd = eventfd(0, 0); if (notification_fd != -1) { notification_mode = NOTIFICATION_MODE_EVENTFD; notification_send = eventfd_notification_send; notification_recv = eventfd_notification_recv; set_close_on_exec(notification_fd); return Val_int(notification_fd); } #endif if (pipe(notification_fds) == -1) uerror("pipe", Nothing); set_close_on_exec(notification_fds[0]); set_close_on_exec(notification_fds[1]); notification_mode = NOTIFICATION_MODE_PIPE; notification_send = pipe_notification_send; notification_recv = pipe_notification_recv; return Val_int(notification_fds[0]); } #endif /* defined(LWT_ON_WINDOWS) */ /* +-----------------------------------------------------------------+ | Signals | +-----------------------------------------------------------------+ */ #ifndef NSIG #define NSIG 64 #endif /* Notifications id for each monitored signal. */ static intnat signal_notifications[NSIG]; CAMLextern int caml_convert_signal_number(int); /* Send a notification when a signal is received. */ static void handle_signal(int signum) { if (signum >= 0 && signum < NSIG) { intnat id = signal_notifications[signum]; if (id != -1) { #if defined(LWT_ON_WINDOWS) /* The signal handler must be reinstalled if we use the signal function. */ signal(signum, handle_signal); #endif lwt_unix_send_notification(id); } } } CAMLprim value lwt_unix_handle_signal(value val_signum) { handle_signal(caml_convert_signal_number(Int_val(val_signum))); return Val_unit; } #if defined(LWT_ON_WINDOWS) /* Handle Ctrl+C on windows. */ static BOOL WINAPI handle_break(DWORD event) { intnat id = signal_notifications[SIGINT]; if (id == -1 || (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT)) return FALSE; lwt_unix_send_notification(id); return TRUE; } #endif /* Install a signal handler. */ CAMLprim value lwt_unix_set_signal(value val_signum, value val_notification, value val_forwarded) { #if !defined(LWT_ON_WINDOWS) struct sigaction sa; #endif int signum = caml_convert_signal_number(Int_val(val_signum)); intnat notification = Long_val(val_notification); if (signum < 0 || signum >= NSIG) caml_invalid_argument("Lwt_unix.on_signal: unavailable signal"); signal_notifications[signum] = notification; if (Bool_val(val_forwarded)) return Val_unit; #if defined(LWT_ON_WINDOWS) if (signum == SIGINT) { if (!SetConsoleCtrlHandler(handle_break, TRUE)) { signal_notifications[signum] = -1; win32_maperr(GetLastError()); uerror("SetConsoleCtrlHandler", Nothing); } } else { if (signal(signum, handle_signal) == SIG_ERR) { signal_notifications[signum] = -1; uerror("signal", Nothing); } } #else sa.sa_handler = handle_signal; #if OCAML_VERSION >= 50000 sa.sa_flags = SA_ONSTACK; #else sa.sa_flags = 0; #endif sigemptyset(&sa.sa_mask); if (sigaction(signum, &sa, NULL) == -1) { signal_notifications[signum] = -1; uerror("sigaction", Nothing); } #endif return Val_unit; } /* Remove a signal handler. */ CAMLprim value lwt_unix_remove_signal(value val_signum, value val_forwarded) { #if !defined(LWT_ON_WINDOWS) struct sigaction sa; #endif /* The signal number is valid here since it was when we did the set_signal. */ int signum = caml_convert_signal_number(Int_val(val_signum)); signal_notifications[signum] = -1; if (Bool_val(val_forwarded)) return Val_unit; #if defined(LWT_ON_WINDOWS) if (signum == SIGINT) SetConsoleCtrlHandler(NULL, FALSE); else signal(signum, SIG_DFL); #else sa.sa_handler = SIG_DFL; sa.sa_flags = 0; sigemptyset(&sa.sa_mask); sigaction(signum, &sa, NULL); #endif return Val_unit; } /* Mark all signals as non-monitored. */ CAMLprim value lwt_unix_init_signals(value Unit) { int i; for (i = 0; i < NSIG; i++) signal_notifications[i] = -1; return Val_unit; } /* +-----------------------------------------------------------------+ | Job execution | +-----------------------------------------------------------------+ */ /* Execute the given job. */ static void execute_job(lwt_unix_job job) { DEBUG("executing the job"); lwt_unix_mutex_lock(&job->mutex); /* Mark the job as running. */ job->state = LWT_UNIX_JOB_STATE_RUNNING; lwt_unix_mutex_unlock(&job->mutex); /* Execute the job. */ job->worker(job); DEBUG("job done"); lwt_unix_mutex_lock(&job->mutex); DEBUG("marking the job has done"); /* Job is done. If the main thread stopped until now, asynchronous notification is not necessary. */ job->state = LWT_UNIX_JOB_STATE_DONE; /* Send a notification if the main thread continued its execution before the job terminated. */ if (job->fast == 0) { lwt_unix_mutex_unlock(&job->mutex); DEBUG("notifying the main thread"); lwt_unix_send_notification(job->notification_id); } else { lwt_unix_mutex_unlock(&job->mutex); DEBUG("not notifying the main thread"); } } /* +-----------------------------------------------------------------+ | Thread pool | +-----------------------------------------------------------------+ */ /* Number of thread waiting for a job in the pool. */ static int thread_waiting_count = 0; /* Number of started threads. */ static int thread_count = 0; /* Maximum number of system threads that can be started. */ static int pool_size = 1000; /* Condition on which pool threads are waiting. */ static lwt_unix_condition pool_condition; /* Queue of pending jobs. It points to the last enqueued job. */ static lwt_unix_job pool_queue = NULL; /* The mutex which protect access to [pool_queue], [pool_condition] and [thread_waiting_count]. */ static lwt_unix_mutex pool_mutex; /* +-----------------------------------------------------------------+ | Threading stuff initialization | +-----------------------------------------------------------------+ */ /* Whether threading has been initialized. */ static int threading_initialized = 0; /* Initialize the pool of thread. */ void initialize_threading() { if (threading_initialized == 0) { lwt_unix_mutex_init(&pool_mutex); lwt_unix_condition_init(&pool_condition); threading_initialized = 1; } } /* +-----------------------------------------------------------------+ | Worker loop | +-----------------------------------------------------------------+ */ /* Function executed by threads of the pool. * Note: all signals are masked for this thread. */ static void *worker_loop(void *data) { lwt_unix_job job = (lwt_unix_job)data; /* Execute the initial job if any. */ if (job != NULL) execute_job(job); while (1) { DEBUG("entering waiting section"); lwt_unix_mutex_lock(&pool_mutex); DEBUG("waiting for something to do"); /* Wait for something to do. */ while (pool_queue == NULL) { ++thread_waiting_count; lwt_unix_condition_wait(&pool_condition, &pool_mutex); } DEBUG("received something to do"); DEBUG("taking a job to execute"); /* Take the first queued job. */ job = pool_queue->next; /* Remove it from the queue. */ if (job->next == job) pool_queue = NULL; else pool_queue->next = job->next; lwt_unix_mutex_unlock(&pool_mutex); /* Execute the job. */ execute_job(job); } return NULL; } /* +-----------------------------------------------------------------+ | Jobs | +-----------------------------------------------------------------+ */ /* Description of jobs. */ struct custom_operations job_ops = { "lwt.unix.job", custom_finalize_default, custom_compare_default, custom_hash_default, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default, NULL }; /* Get the job structure contained in a custom value. */ #define Job_val(v) *(lwt_unix_job *)Data_custom_val(v) value lwt_unix_alloc_job(lwt_unix_job job) { value val_job = caml_alloc_custom(&job_ops, sizeof(lwt_unix_job), 0, 1); Job_val(val_job) = job; return val_job; } void lwt_unix_free_job(lwt_unix_job job) { if (job->async_method != LWT_UNIX_ASYNC_METHOD_NONE) lwt_unix_mutex_destroy(&job->mutex); free(job); } CAMLprim value lwt_unix_start_job(value val_job, value val_async_method) { lwt_unix_job job = Job_val(val_job); lwt_unix_async_method async_method = Int_val(val_async_method); int done = 0; /* Fallback to synchronous call if there is no worker available and we can not launch more threads. */ if (async_method != LWT_UNIX_ASYNC_METHOD_NONE && thread_waiting_count == 0 && thread_count >= pool_size) async_method = LWT_UNIX_ASYNC_METHOD_NONE; /* Initialises job parameters. */ job->state = LWT_UNIX_JOB_STATE_PENDING; job->fast = 1; job->async_method = async_method; switch (async_method) { case LWT_UNIX_ASYNC_METHOD_NONE: /* Execute the job synchronously. */ caml_enter_blocking_section(); job->worker(job); caml_leave_blocking_section(); return Val_true; case LWT_UNIX_ASYNC_METHOD_DETACH: case LWT_UNIX_ASYNC_METHOD_SWITCH: initialize_threading(); lwt_unix_mutex_init(&job->mutex); lwt_unix_mutex_lock(&pool_mutex); if (thread_waiting_count == 0) { /* Try to start a new worker. */ int zero_if_started_otherwise_errno = lwt_unix_launch_thread(worker_loop, (void *)job); /* Increment the worker thread count while still holding the mutex. */ if (zero_if_started_otherwise_errno == 0) ++thread_count; lwt_unix_mutex_unlock(&pool_mutex); /* If the worker thread was not started, raise an exception. This must be done with the mutex unlocked, as it can involve a surprising control transfer. */ if (zero_if_started_otherwise_errno != 0) { unix_error( zero_if_started_otherwise_errno, "launch_thread", Nothing); } } else { /* Add the job at the end of the queue. */ if (pool_queue == NULL) { pool_queue = job; job->next = job; } else { job->next = pool_queue->next; pool_queue->next = job; pool_queue = job; } /* Wakeup one worker. */ --thread_waiting_count; lwt_unix_condition_signal(&pool_condition); lwt_unix_mutex_unlock(&pool_mutex); } done = job->state == LWT_UNIX_JOB_STATE_DONE; if (done) { /* Wait for the mutex to be released because the job is going to be freed immediately. */ lwt_unix_mutex_lock(&job->mutex); lwt_unix_mutex_unlock(&job->mutex); } return Val_bool(done); } return Val_false; } CAMLprim value lwt_unix_check_job(value val_job, value val_notification_id) { lwt_unix_job job = Job_val(val_job); value result; DEBUG("checking job"); switch (job->async_method) { case LWT_UNIX_ASYNC_METHOD_NONE: return Val_int(1); case LWT_UNIX_ASYNC_METHOD_DETACH: case LWT_UNIX_ASYNC_METHOD_SWITCH: lwt_unix_mutex_lock(&job->mutex); /* We are not waiting anymore. */ job->fast = 0; /* Set the notification id for asynchronous wakeup. */ job->notification_id = Long_val(val_notification_id); result = Val_bool(job->state == LWT_UNIX_JOB_STATE_DONE); lwt_unix_mutex_unlock(&job->mutex); DEBUG("job done: %d", Int_val(result)); return result; } return Val_int(0); } CAMLprim value lwt_unix_self_result(value val_job) { lwt_unix_job job = Job_val(val_job); return job->result(job); } CAMLprim value lwt_unix_run_job_sync(value val_job) { lwt_unix_job job = Job_val(val_job); /* So lwt_unix_free_job won't try to destroy the mutex. */ job->async_method = LWT_UNIX_ASYNC_METHOD_NONE; caml_enter_blocking_section(); job->worker(job); caml_leave_blocking_section(); return job->result(job); } CAMLprim value lwt_unix_reset_after_fork(value Unit) { if (threading_initialized) { /* There is no more waiting threads. */ thread_waiting_count = 0; /* There is no more threads. */ thread_count = 0; /* Empty the queue. */ pool_queue = NULL; threading_initialized = 0; } return Val_unit; } /* +-----------------------------------------------------------------+ | Statistics and control | +-----------------------------------------------------------------+ */ CAMLprim value lwt_unix_pool_size(value Unit) { return Val_int(pool_size); } CAMLprim value lwt_unix_set_pool_size(value val_size) { pool_size = Int_val(val_size); return Val_unit; } CAMLprim value lwt_unix_thread_count(value Unit) { return Val_int(thread_count); } CAMLprim value lwt_unix_thread_waiting_count(value Unit) { return Val_int(thread_waiting_count); } lwt-5.9.1/src/unix/unix_c/000077500000000000000000000000001476253734400154125ustar00rootroot00000000000000lwt-5.9.1/src/unix/unix_c/unix_accept4.c000066400000000000000000000021331476253734400201430ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #ifdef HAVE_ACCEPT4 #define _GNU_SOURCE #include #include #include #include CAMLprim value lwt_unix_accept4(value vcloexec, value vnonblock, value vsock) { CAMLparam3(vcloexec, vnonblock, vsock); CAMLlocal2(vaddr, res); union sock_addr_union addr; socklen_param_type addr_len; int cloexec = Is_some(vcloexec) && Bool_val(Some_val(vcloexec)) ? SOCK_CLOEXEC : 0; int nonblock = Bool_val(vnonblock) ? SOCK_NONBLOCK : 0; addr_len = sizeof(addr); int fd = accept4(Int_val(vsock), &addr.s_gen, &addr_len, cloexec | nonblock); if (fd == -1) uerror("accept", Nothing); vaddr = alloc_sockaddr(&addr, addr_len, fd); res = caml_alloc_small(2, 0); Field(res, 0) = Val_int(fd); Field(res, 1) = vaddr; CAMLreturn(res); } #else #include "lwt_unix.h" LWT_NOT_AVAILABLE3(unix_accept4) #endif lwt-5.9.1/src/unix/unix_c/unix_access_job.c000066400000000000000000000101141476253734400207110ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [access]: int access(char* path, int mode) - these are the expected ocaml externals for this job: external access_job : string -> Unix.access_permission list -> unit Lwt_unix.job = "lwt_unix_access_job" external access_sync : string -> Unix.access_permission list -> unit = "lwt_unix_access_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Converters | +-----------------------------------------------------------------+ */ /* Table mapping constructors of ocaml type Unix.access_permission to C values. */ static const int access_permission_table[] = { /* Constructor R_OK. */ R_OK, /* Constructor W_OK. */ W_OK, /* Constructor X_OK. */ X_OK, /* Constructor F_OK. */ F_OK }; /* Convert ocaml values of type Unix.access_permission to a C int. */ static int int_of_access_permissions(value list) { int result = 0; while (list != Val_emptylist) { result |= access_permission_table[Int_val(Field(list, 0))]; list = Field(list, 1); }; return result; } /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [access]. */ struct job_access { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* in parameter. */ int mode; /* Buffer for string parameters. */ char data[]; }; /* The function calling [access]. */ static void worker_access(struct job_access* job) { /* Perform the blocking call. */ job->result = access(job->path, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_access(struct job_access* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "access", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_access_job(value path, value mode) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_access* job = lwt_unix_new_plus(struct job_access, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_access; job->job.result = (lwt_unix_job_result)result_access; /* Copy the mode parameter. */ job->mode = int_of_access_permissions(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_access_job(value Unit) { lwt_unix_not_available("access"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_bind_job.c000066400000000000000000000021101476253734400203610ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "lwt_unix.h" struct job_bind { struct lwt_unix_job job; int fd; union sock_addr_union addr; socklen_param_type addr_len; int result; int error_code; }; static void worker_bind(struct job_bind *job) { job->result = bind(job->fd, &job->addr.s_gen, job->addr_len); job->error_code = errno; } static value result_bind(struct job_bind *job) { LWT_UNIX_CHECK_JOB(job, job->result != 0, "bind"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_bind_job(value fd, value address) { LWT_UNIX_INIT_JOB(job, bind, 0); job->fd = Int_val(fd); get_sockaddr(address, &job->addr, &job->addr_len); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_read.c000066400000000000000000000012361476253734400207440ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_bytes_read(value val_fd, value val_buf, value val_ofs, value val_len) { long ret; ret = read(Int_val(val_fd), (char *)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len)); if (ret == -1) uerror("read", Nothing); return Val_long(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_read_job.c000066400000000000000000000032171476253734400215770ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" struct job_bytes_read { struct lwt_unix_job job; /* The file descriptor. */ int fd; /* The destination buffer. */ char *buffer; /* The offset in the string. */ long offset; /* The amount of data to read. */ long length; /* The result of the read syscall. */ long result; /* The value of errno. */ int error_code; /* OCaml buffer. */ value ocaml_buffer; }; static void worker_bytes_read(struct job_bytes_read *job) { job->result = read(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_bytes_read(struct job_bytes_read *job) { long result = job->result; caml_remove_generational_global_root(&job->ocaml_buffer); LWT_UNIX_CHECK_JOB(job, result < 0, "read"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buf, value val_ofs, value val_len) { LWT_UNIX_INIT_JOB(job, bytes_read, 0); job->fd = Int_val(val_fd); job->buffer = (char *)Caml_ba_data_val(val_buf) + Long_val(val_ofs); job->length = Long_val(val_len); job->ocaml_buffer = val_buf; caml_register_generational_global_root(&job->ocaml_buffer); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_recv.c000066400000000000000000000014341476253734400207700ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" value lwt_unix_bytes_recv(value fd, value buf, value ofs, value len, value flags) { int ret; ret = recv(Int_val(fd), (char *)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len), lwt_convert_flag_list(flags, msg_flag_table)); if (ret == -1) uerror("recv", Nothing); return Val_int(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_recvfrom.c000066400000000000000000000022751476253734400216600ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" value lwt_unix_bytes_recvfrom(value fd, value buf, value ofs, value len, value flags) { CAMLparam5(fd, buf, ofs, len, flags); CAMLlocal2(result, address); int ret; union sock_addr_union addr; socklen_t addr_len; addr_len = sizeof(addr); ret = recvfrom(Int_val(fd), (char *)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len), lwt_convert_flag_list(flags, msg_flag_table), &addr.s_gen, &addr_len); if (ret == -1) uerror("recvfrom", Nothing); address = alloc_sockaddr(&addr, addr_len, -1); result = caml_alloc_tuple(2); Field(result, 0) = Val_int(ret); Field(result, 1) = address; CAMLreturn(result); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_send.c000066400000000000000000000014341476253734400207620ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" value lwt_unix_bytes_send(value fd, value buf, value ofs, value len, value flags) { int ret; ret = send(Int_val(fd), (char *)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len), lwt_convert_flag_list(flags, msg_flag_table)); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_sendto.c000066400000000000000000000017121476253734400213240ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" value lwt_unix_bytes_sendto(value fd, value buf, value ofs, value len, value flags, value dest) { union sock_addr_union addr; socklen_t addr_len; int ret; get_sockaddr(dest, &addr, &addr_len); ret = sendto(Int_val(fd), (char *)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len), lwt_convert_flag_list(flags, msg_flag_table), &addr.s_gen, addr_len); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_sendto_byte.c000066400000000000000000000010771476253734400223530ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include extern value lwt_unix_bytes_sendto(value fd, value buf, value ofs, value len, value flags, value dest); CAMLprim value lwt_unix_bytes_sendto_byte(value *argv, int argc) { return lwt_unix_bytes_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_write.c000066400000000000000000000012701476253734400211610ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include CAMLprim value lwt_unix_bytes_write(value val_fd, value val_buf, value val_ofs, value val_len) { long ret; ret = write(Int_val(val_fd), (char *)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len)); if (ret == -1) uerror("write", Nothing); return Val_long(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_bytes_write_job.c000066400000000000000000000026621476253734400220210ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" struct job_bytes_write { struct lwt_unix_job job; int fd; char *buffer; long length; long result; int error_code; value ocaml_buffer; }; static void worker_bytes_write(struct job_bytes_write *job) { job->result = write(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_bytes_write(struct job_bytes_write *job) { long result = job->result; caml_remove_generational_global_root(&job->ocaml_buffer); LWT_UNIX_CHECK_JOB(job, result < 0, "write"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) { LWT_UNIX_INIT_JOB(job, bytes_write, 0); job->fd = Int_val(val_fd); job->buffer = (char *)Caml_ba_data_val(val_buffer) + Long_val(val_offset); job->length = Long_val(val_length); job->ocaml_buffer = val_buffer; caml_register_generational_global_root(&job->ocaml_buffer); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_chdir_job.c000066400000000000000000000061361476253734400205520ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [chdir]: int chdir(char* path) - these are the expected ocaml externals for this job: external chdir_job : string -> unit Lwt_unix.job = "lwt_unix_chdir_job" external chdir_sync : string -> unit = "lwt_unix_chdir_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [chdir]. */ struct job_chdir { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* Buffer for string parameters. */ char data[]; }; /* The function calling [chdir]. */ static void worker_chdir(struct job_chdir* job) { /* Perform the blocking call. */ job->result = chdir(job->path); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_chdir(struct job_chdir* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "chdir", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_chdir_job(value path) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_chdir* job = lwt_unix_new_plus(struct job_chdir, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_chdir; job->job.result = (lwt_unix_job_result)result_chdir; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_chdir_job(value Unit) { lwt_unix_not_available("chdir"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_chmod_job.c000066400000000000000000000063571476253734400205600ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [chmod]: int chmod(char* path, int mode) - these are the expected ocaml externals for this job: external chmod_job : string -> int -> unit Lwt_unix.job = "lwt_unix_chmod_job" external chmod_sync : string -> int -> unit = "lwt_unix_chmod_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [chmod]. */ struct job_chmod { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* in parameter. */ int mode; /* Buffer for string parameters. */ char data[]; }; /* The function calling [chmod]. */ static void worker_chmod(struct job_chmod* job) { /* Perform the blocking call. */ job->result = chmod(job->path, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_chmod(struct job_chmod* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "chmod", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_chmod_job(value path, value mode) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_chmod* job = lwt_unix_new_plus(struct job_chmod, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_chmod; job->job.result = (lwt_unix_job_result)result_chmod; /* Copy the mode parameter. */ job->mode = Int_val(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_chmod_job(value Unit) { lwt_unix_not_available("chmod"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_chown_job.c000066400000000000000000000066031476253734400205760ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [chown]: int chown(char* path, int ower, int group) - these are the expected ocaml externals for this job: external chown_job : string -> int -> int -> unit Lwt_unix.job = "lwt_unix_chown_job" external chown_sync : string -> int -> int -> unit = "lwt_unix_chown_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [chown]. */ struct job_chown { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* in parameter. */ int ower; /* in parameter. */ int group; /* Buffer for string parameters. */ char data[]; }; /* The function calling [chown]. */ static void worker_chown(struct job_chown* job) { /* Perform the blocking call. */ job->result = chown(job->path, job->ower, job->group); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_chown(struct job_chown* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "chown", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_chown_job(value path, value ower, value group) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_chown* job = lwt_unix_new_plus(struct job_chown, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_chown; job->job.result = (lwt_unix_job_result)result_chown; /* Copy the ower parameter. */ job->ower = Int_val(ower); /* Copy the group parameter. */ job->group = Int_val(group); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_chown_job(value Unit) { lwt_unix_not_available("chown"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_chroot_job.c000066400000000000000000000061641476253734400207600ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [chroot]: int chroot(char* path) - these are the expected ocaml externals for this job: external chroot_job : string -> unit Lwt_unix.job = "lwt_unix_chroot_job" external chroot_sync : string -> unit = "lwt_unix_chroot_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [chroot]. */ struct job_chroot { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* Buffer for string parameters. */ char data[]; }; /* The function calling [chroot]. */ static void worker_chroot(struct job_chroot* job) { /* Perform the blocking call. */ job->result = chroot(job->path); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_chroot(struct job_chroot* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "chroot", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_chroot_job(value path) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_chroot* job = lwt_unix_new_plus(struct job_chroot, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_chroot; job->job.result = (lwt_unix_job_result)result_chroot; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_chroot_job(value Unit) { lwt_unix_not_available("chroot"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_close_job.c000066400000000000000000000052551476253734400205670ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [close]: int close(int fd) - these are the expected ocaml externals for this job: external close_job : Unix.file_descr -> unit Lwt_unix.job = "lwt_unix_close_job" external close_sync : Unix.file_descr -> unit = "lwt_unix_close_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [close]. */ struct job_close { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; }; /* The function calling [close]. */ static void worker_close(struct job_close* job) { /* Perform the blocking call. */ job->result = close(job->fd); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_close(struct job_close* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "close", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_close_job(value fd) { /* Allocate a new job. */ struct job_close* job = lwt_unix_new(struct job_close); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_close; job->job.result = (lwt_unix_job_result)result_close; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_close_job(value Unit) { lwt_unix_not_available("close"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_closedir_job.c000066400000000000000000000016471476253734400212670ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" struct job_closedir { struct lwt_unix_job job; int result; int error_code; DIR *dir; }; static void worker_closedir(struct job_closedir *job) { job->result = closedir(job->dir); job->error_code = errno; } static value result_closedir(struct job_closedir *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "closedir"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_closedir_job(value dir) { LWT_UNIX_INIT_JOB(job, closedir, 0); job->dir = DIR_Val(dir); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_fchmod_job.c000066400000000000000000000055241476253734400207210ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [fchmod]: int fchmod(int fd, int mode) - these are the expected ocaml externals for this job: external fchmod_job : Unix.file_descr -> int -> unit Lwt_unix.job = "lwt_unix_fchmod_job" external fchmod_sync : Unix.file_descr -> int -> unit = "lwt_unix_fchmod_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [fchmod]. */ struct job_fchmod { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; /* in parameter. */ int mode; }; /* The function calling [fchmod]. */ static void worker_fchmod(struct job_fchmod* job) { /* Perform the blocking call. */ job->result = fchmod(job->fd, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_fchmod(struct job_fchmod* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "fchmod", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_fchmod_job(value fd, value mode) { /* Allocate a new job. */ struct job_fchmod* job = lwt_unix_new(struct job_fchmod); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_fchmod; job->job.result = (lwt_unix_job_result)result_fchmod; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the mode parameter. */ job->mode = Int_val(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_fchmod_job(value Unit) { lwt_unix_not_available("fchmod"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_fchown_job.c000066400000000000000000000057501476253734400207460ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [fchown]: int fchown(int fd, int ower, int group) - these are the expected ocaml externals for this job: external fchown_job : Unix.file_descr -> int -> int -> unit Lwt_unix.job = "lwt_unix_fchown_job" external fchown_sync : Unix.file_descr -> int -> int -> unit = "lwt_unix_fchown_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [fchown]. */ struct job_fchown { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; /* in parameter. */ int ower; /* in parameter. */ int group; }; /* The function calling [fchown]. */ static void worker_fchown(struct job_fchown* job) { /* Perform the blocking call. */ job->result = fchown(job->fd, job->ower, job->group); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_fchown(struct job_fchown* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "fchown", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_fchown_job(value fd, value ower, value group) { /* Allocate a new job. */ struct job_fchown* job = lwt_unix_new(struct job_fchown); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_fchown; job->job.result = (lwt_unix_job_result)result_fchown; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the ower parameter. */ job->ower = Int_val(ower); /* Copy the group parameter. */ job->group = Int_val(group); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_fchown_job(value Unit) { lwt_unix_not_available("fchown"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_fdatasync_job.c000066400000000000000000000055261476253734400214370ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [fdatasync]: int fdatasync(int fd) - these are the expected ocaml externals for this job: external fdatasync_job : Unix.file_descr -> unit Lwt_unix.job = "lwt_unix_fdatasync_job" external fdatasync_sync : Unix.file_descr -> unit = "lwt_unix_fdatasync_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) && defined(HAVE_FDATASYNC) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [fdatasync]. */ struct job_fdatasync { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; }; /* The function calling [fdatasync]. */ static void worker_fdatasync(struct job_fdatasync* job) { /* Perform the blocking call. */ job->result = fdatasync(job->fd); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_fdatasync(struct job_fdatasync* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "fdatasync", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_fdatasync_job(value fd) { /* Allocate a new job. */ struct job_fdatasync* job = lwt_unix_new(struct job_fdatasync); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_fdatasync; job->job.result = (lwt_unix_job_result)result_fdatasync; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) && defined(HAVE_FDATASYNC) */ CAMLprim value lwt_unix_fdatasync_job(value Unit) { lwt_unix_not_available("fdatasync"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) && defined(HAVE_FDATASYNC) */ lwt-5.9.1/src/unix/unix_c/unix_fstat_64_job.c000066400000000000000000000010661476253734400211100ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include "lwt_unix.h" #include "unix_stat_job_utils.h" CAMLprim value lwt_unix_fstat_64_job(value val_fd) { LWT_UNIX_INIT_JOB(job, fstat, 0); job->job.result = (lwt_unix_job_result)result_fstat_64; job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_fstat_job.c000066400000000000000000000007671476253734400206060ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include "lwt_unix.h" #include "unix_stat_job_utils.h" CAMLprim value lwt_unix_fstat_job(value val_fd) { LWT_UNIX_INIT_JOB(job, fstat, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_fsync_job.c000066400000000000000000000050361476253734400206010ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [fsync]: int fsync(int fd) - these are the expected ocaml externals for this job: external fsync_job : Unix.file_descr -> unit Lwt_unix.job = "lwt_unix_fsync_job" external fsync_sync : Unix.file_descr -> unit = "lwt_unix_fsync_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [fsync]. */ struct job_fsync { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; }; /* The function calling [fsync]. */ static void worker_fsync(struct job_fsync* job) { /* Perform the blocking call. */ job->result = fsync(job->fd); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_fsync(struct job_fsync* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "fsync", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_fsync_job(value fd) { /* Allocate a new job. */ struct job_fsync* job = lwt_unix_new(struct job_fsync); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_fsync; job->job.result = (lwt_unix_job_result)result_fsync; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_ftruncate_job.c000066400000000000000000000071601476253734400214520ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [ftruncate]: int ftruncate(int fd, off_t offset) - these are the expected ocaml externals for this job: external ftruncate_job : Unix.file_descr -> int -> unit Lwt_unix.job = "lwt_unix_ftruncate_job" external ftruncate_sync : Unix.file_descr -> int -> unit = "lwt_unix_ftruncate_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [ftruncate]. */ struct job_ftruncate { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; /* in parameter. */ off_t offset; }; /* The function calling [ftruncate]. */ static void worker_ftruncate(struct job_ftruncate* job) { /* Perform the blocking call. */ job->result = ftruncate(job->fd, job->offset); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_ftruncate(struct job_ftruncate* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "ftruncate", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_ftruncate_job(value fd, value offset) { /* Allocate a new job. */ struct job_ftruncate* job = lwt_unix_new(struct job_ftruncate); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_ftruncate; job->job.result = (lwt_unix_job_result)result_ftruncate; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the offset parameter. */ job->offset = Long_val(offset); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } /* The stub creating the job structure. */ CAMLprim value lwt_unix_ftruncate_64_job(value fd, value offset) { /* Allocate a new job. */ struct job_ftruncate* job = lwt_unix_new(struct job_ftruncate); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_ftruncate; job->job.result = (lwt_unix_job_result)result_ftruncate; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the offset parameter. */ job->offset = Int64_val(offset); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_ftruncate_job(value Unit) { lwt_unix_not_available("ftruncate"); return Val_unit; } CAMLprim value lwt_unix_ftruncate_64_job(value Unit) { lwt_unix_not_available("ftruncate"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_get_affinity.c000066400000000000000000000020051476253734400212660ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #define _GNU_SOURCE #include #include #include #include #include #include "lwt_unix.h" #if defined(HAVE_AFFINITY) CAMLprim value lwt_unix_get_affinity(value val_pid) { CAMLparam1(val_pid); CAMLlocal2(list, node); cpu_set_t cpus; if (sched_getaffinity(Int_val(val_pid), sizeof(cpu_set_t), &cpus) < 0) uerror("sched_getaffinity", Nothing); int i; list = Val_int(0); for (i = sizeof(cpu_set_t) * 8 - 1; i >= 0; i--) { if (CPU_ISSET(i, &cpus)) { node = caml_alloc_tuple(2); Field(node, 0) = Val_int(i); Field(node, 1) = list; list = node; } } CAMLreturn(list); } #else LWT_NOT_AVAILABLE1(unix_get_affinity) #endif #endif lwt-5.9.1/src/unix/unix_c/unix_get_cpu.c000066400000000000000000000010751476253734400202520ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #define _GNU_SOURCE #include #include #include #include "lwt_unix.h" #if defined(HAVE_GETCPU) CAMLprim value lwt_unix_get_cpu(value Unit) { int cpu = sched_getcpu(); if (cpu < 0) uerror("sched_getcpu", Nothing); return Val_int(cpu); } #else LWT_NOT_AVAILABLE1(unix_get_cpu) #endif #endif lwt-5.9.1/src/unix/unix_c/unix_get_credentials.c000066400000000000000000000036641476253734400217660ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #define _GNU_SOURCE #include #include #include #include #include #include #include "lwt_unix.h" #if defined(HAVE_GET_CREDENTIALS_LINUX) #define CREDENTIALS_TYPE struct ucred #define CREDENTIALS_FIELD(id) id #elif defined(HAVE_GET_CREDENTIALS_NETBSD) #define CREDENTIALS_TYPE struct sockcred #define CREDENTIALS_FIELD(id) sc_##id #elif defined(HAVE_GET_CREDENTIALS_OPENBSD) #define CREDENTIALS_TYPE struct sockpeercred #define CREDENTIALS_FIELD(id) id #elif defined(HAVE_GET_CREDENTIALS_FREEBSD) #define CREDENTIALS_TYPE struct cmsgcred #define CREDENTIALS_FIELD(id) cmsgcred_##id #endif #if defined(CREDENTIALS_TYPE) CAMLprim value lwt_unix_get_credentials(value fd) { CAMLparam1(fd); CAMLlocal1(res); CREDENTIALS_TYPE cred; socklen_t cred_len = sizeof(cred); if (getsockopt(Int_val(fd), SOL_SOCKET, SO_PEERCRED, &cred, &cred_len) == -1) uerror("get_credentials", Nothing); res = caml_alloc_tuple(3); Store_field(res, 0, Val_int(cred.CREDENTIALS_FIELD(pid))); Store_field(res, 1, Val_int(cred.CREDENTIALS_FIELD(uid))); Store_field(res, 2, Val_int(cred.CREDENTIALS_FIELD(gid))); CAMLreturn(res); } #elif defined(HAVE_GETPEEREID) CAMLprim value lwt_unix_get_credentials(value fd) { CAMLparam1(fd); CAMLlocal1(res); uid_t euid; gid_t egid; if (getpeereid(Int_val(fd), &euid, &egid) == -1) uerror("get_credentials", Nothing); res = caml_alloc_tuple(3); Store_field(res, 0, Val_int(-1)); Store_field(res, 1, Val_int(euid)); Store_field(res, 2, Val_int(egid)); CAMLreturn(res); } #else LWT_NOT_AVAILABLE1(unix_get_credentials) #endif #endif lwt-5.9.1/src/unix/unix_c/unix_get_network_information_utils.c000066400000000000000000000112771476253734400250060ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "unix_get_network_information_utils.h" #if defined(NON_R_GETHOSTBYADDR) || defined(NON_R_GETHOSTBYNAME) char **c_copy_addr_array(char **src, int addr_len) { if (src == NULL) { return NULL; } char **p = src; size_t i = 0; while (*p) { i++; p++; } const size_t ar_len = i; p = malloc((ar_len + 1) * sizeof(char *)); if (p == NULL) { return NULL; } for (i = 0; i < ar_len; ++i) { p[i] = malloc(addr_len); if (p[i] == NULL) { size_t j; for (j = 0; j < i; j++) { free(p[j]); } free(p); return NULL; } memcpy(p[i], src[i], addr_len); } p[ar_len] = NULL; return p; } #endif #if !defined(HAVE_NETDB_REENTRANT) || defined(NON_R_GETHOSTBYADDR) || \ defined(NON_R_GETHOSTBYNAME) char **c_copy_string_array(char **src) { char **p = src; size_t i = 0; size_t len; if (src == NULL) { return NULL; } while (*p) { i++; p++; } len = i; p = malloc((len + 1) * sizeof(char *)); if (p == NULL) { return NULL; } for (i = 0; i < len; ++i) { p[i] = strdup(src[i]); if (p[i] == NULL) { size_t j; for (j = 0; j < i; j++) { free(p[j]); } free(p); return NULL; } } p[len] = NULL; return p; } void c_free_string_array(char **src) { if (src) { char **p = src; while (*p) { free(*p); ++p; } free(src); } } char *s_strdup(const char *s) { return (strdup(s == NULL ? "" : s)); } #endif static value alloc_one_addr(char const *a) { struct in_addr addr; memmove(&addr, a, 4); return alloc_inet_addr(&addr); } static value alloc_one_addr6(char const *a) { struct in6_addr addr; memmove(&addr, a, 16); return alloc_inet6_addr(&addr); } value alloc_host_entry(struct hostent *entry) { value res; value name = Val_unit, aliases = Val_unit; value addr_list = Val_unit, adr = Val_unit; Begin_roots4(name, aliases, addr_list, adr); name = caml_copy_string((char *)(entry->h_name)); /* PR#4043: protect against buggy implementations of gethostbynamee() that return a NULL pointer in h_aliases */ if (entry->h_aliases) aliases = caml_copy_string_array((const char **)entry->h_aliases); else aliases = Atom(0); if (entry->h_length == 16) addr_list = caml_alloc_array(alloc_one_addr6, (const char **)entry->h_addr_list); else addr_list = caml_alloc_array(alloc_one_addr, (const char **)entry->h_addr_list); res = caml_alloc_small(4, 0); Field(res, 0) = name; Field(res, 1) = aliases; switch (entry->h_addrtype) { case PF_UNIX: Field(res, 2) = Val_int(0); break; case PF_INET: Field(res, 2) = Val_int(1); break; default: /*PF_INET6 */ Field(res, 2) = Val_int(2); break; } Field(res, 3) = addr_list; End_roots(); return res; } #if defined(NON_R_GETHOSTBYADDR) || defined(NON_R_GETHOSTBYNAME) struct hostent *hostent_dup(struct hostent *orig) { if (orig == NULL) { return NULL; } struct hostent *h = malloc(sizeof *h); if (h == NULL) { return NULL; } h->h_name = s_strdup(orig->h_name); if (!h->h_name) { goto nomem1; } if (!orig->h_aliases) { h->h_aliases = NULL; } else { h->h_aliases = c_copy_string_array(orig->h_aliases); if (!h->h_aliases) { goto nomem2; } } if (!orig->h_addr_list) { h->h_addr_list = NULL; } else { h->h_addr_list = c_copy_addr_array(orig->h_addr_list, orig->h_length); if (!h->h_addr_list) { goto nomem3; } } h->h_addrtype = orig->h_addrtype; h->h_length = orig->h_length; return h; nomem3: c_free_string_array(h->h_aliases); nomem2: free((char *)h->h_name); nomem1: free(h); return NULL; } void hostent_free(struct hostent *h) { if (h) { c_free_string_array(h->h_addr_list); c_free_string_array(h->h_aliases); free((char *)h->h_name); free(h); } } #endif #endif lwt-5.9.1/src/unix/unix_c/unix_get_network_information_utils.h000066400000000000000000000026251476253734400250100ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #pragma once #include "lwt_config.h" /* * Included in: * - unix_gethostname_job.c * - unix_gethostbyname_job.c * - unix_gethostbyaddr_job.c * - unix_getprotoby_getservby_job.c */ #if !defined(LWT_ON_WINDOWS) #include #include #include #include "lwt_unix.h" #define NETDB_BUFFER_SIZE 10000 /* keep test in sync with discover.ml */ #if !defined(HAS_GETHOSTBYADDR_R) || \ (HAS_GETHOSTBYADDR_R != 7 && HAS_GETHOSTBYADDR_R != 8) #define NON_R_GETHOSTBYADDR 1 #endif /* keep test in sync with discover.ml */ #if !defined(HAS_GETHOSTBYNAME_R) || \ (HAS_GETHOSTBYNAME_R != 5 && HAS_GETHOSTBYNAME_R != 6) #define NON_R_GETHOSTBYNAME 1 #endif #if defined(NON_R_GETHOSTBYADDR) || defined(NON_R_GETHOSTBYNAME) char **c_copy_addr_array(char **src, int addr_len); #endif #if !defined(HAVE_NETDB_REENTRANT) || defined(NON_R_GETHOSTBYADDR) || \ defined(NON_R_GETHOSTBYNAME) char **c_copy_string_array(char **src); void c_free_string_array(char **src); char *s_strdup(const char *s); #endif value alloc_host_entry(struct hostent *entry); #if defined(NON_R_GETHOSTBYADDR) || defined(NON_R_GETHOSTBYNAME) struct hostent *hostent_dup(struct hostent *orig); void hostent_free(struct hostent *h); #endif #endif lwt-5.9.1/src/unix/unix_c/unix_get_page_size.c000066400000000000000000000007311476253734400214270ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_get_page_size(value Unit) { long page_size = sysconf(_SC_PAGESIZE); if (page_size < 0) page_size = 4096; return Val_long(page_size); } #endif lwt-5.9.1/src/unix/unix_c/unix_get_pw_gr_nam_id_job.c000066400000000000000000000144751476253734400227520ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include #include #include "lwt_unix.h" #if !defined(__ANDROID__) static value alloc_passwd_entry(struct passwd *entry) { value res; value name = Val_unit, passwd = Val_unit, gecos = Val_unit; value dir = Val_unit, shell = Val_unit; Begin_roots5(name, passwd, gecos, dir, shell); name = caml_copy_string(entry->pw_name); passwd = caml_copy_string(entry->pw_passwd); #if !defined(__BEOS__) gecos = caml_copy_string(entry->pw_gecos); #else gecos = caml_copy_string(""); #endif dir = caml_copy_string(entry->pw_dir); shell = caml_copy_string(entry->pw_shell); res = caml_alloc_small(7, 0); Field(res, 0) = name; Field(res, 1) = passwd; Field(res, 2) = Val_int(entry->pw_uid); Field(res, 3) = Val_int(entry->pw_gid); Field(res, 4) = gecos; Field(res, 5) = dir; Field(res, 6) = shell; End_roots(); return res; } static value alloc_group_entry(struct group *entry) { value res; value name = Val_unit, pass = Val_unit, mem = Val_unit; Begin_roots3(name, pass, mem); name = caml_copy_string(entry->gr_name); pass = caml_copy_string(entry->gr_passwd); mem = caml_copy_string_array((const char **)entry->gr_mem); res = caml_alloc_small(4, 0); Field(res, 0) = name; Field(res, 1) = pass; Field(res, 2) = Val_int(entry->gr_gid); Field(res, 3) = mem; End_roots(); return res; } #define JOB_GET_ENTRY(INIT, FUNC, CONF, TYPE, ARG, ARG_DECL, FAIL_ARG) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE entry; \ struct TYPE *ptr; \ char *buffer; \ int result; \ ARG_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ size_t buffer_size = sysconf(_SC_##CONF##_R_SIZE_MAX); \ if (buffer_size == (size_t)-1) buffer_size = 16384; \ while (1) \ { \ job->buffer = (char *)lwt_unix_malloc(buffer_size); \ job->result = FUNC##_r(job->ARG, &job->entry, job->buffer, \ buffer_size, &job->ptr); \ if (job->result != ERANGE) break; \ buffer_size = buffer_size * 2; \ if (buffer_size > 1 << 20) break; \ free(job->buffer); \ } \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ int result = job->result; \ if (result) { \ value arg = FAIL_ARG; \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ unix_error(result, #FUNC, arg); \ } else if (job->ptr == NULL) { \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value entry = alloc_##TYPE##_entry(&job->entry); \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ return entry; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(value ARG) \ { \ INIT; \ return lwt_unix_alloc_job(&job->job); \ } JOB_GET_ENTRY(LWT_UNIX_INIT_JOB_STRING(job, getpwnam, 0, name), getpwnam, GETPW, passwd, name, char *name; char data[], caml_copy_string(job->name)) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB_STRING(job, getgrnam, 0, name), getgrnam, GETGR, group, name, char *name; char data[], caml_copy_string(job->name)) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB(job, getpwuid, 0); job->uid = Int_val(uid), getpwuid, GETPW, passwd, uid, int uid, Nothing) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB(job, getgrgid, 0); job->gid = Int_val(gid), getgrgid, GETGR, group, gid, int gid, Nothing) #else LWT_NOT_AVAILABLE1(unix_getpwnam_job) LWT_NOT_AVAILABLE1(unix_getgrnam_job) LWT_NOT_AVAILABLE1(unix_getpwuid_job) LWT_NOT_AVAILABLE1(unix_getgrgid_job) #endif #endif lwt-5.9.1/src/unix/unix_c/unix_getaddrinfo_job.c000066400000000000000000000074201476253734400217440ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" struct job_getaddrinfo { struct lwt_unix_job job; char *node; char *service; struct addrinfo hints; struct addrinfo *info; int result; char data[]; }; static value cst_to_constr(int n, const int *tbl, int size, int deflt) { int i; for (i = 0; i < size; i++) if (n == tbl[i]) return Val_int(i); return Val_int(deflt); } static value convert_addrinfo(const struct addrinfo *a) { CAMLparam0(); CAMLlocal3(vres, vaddr, vcanonname); union sock_addr_union sa; socklen_t len; len = a->ai_addrlen; if (len > sizeof(sa)) len = sizeof(sa); memcpy(&sa.s_gen, a->ai_addr, len); vaddr = alloc_sockaddr(&sa, len, -1); vcanonname = caml_copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname); vres = caml_alloc_small(5, 0); Field(vres, 0) = cst_to_constr(a->ai_family, caml_unix_socket_domain_table, 3, 0); Field(vres, 1) = cst_to_constr(a->ai_socktype, caml_unix_socket_type_table, 4, 0); Field(vres, 2) = Val_int(a->ai_protocol); Field(vres, 3) = vaddr; Field(vres, 4) = vcanonname; CAMLreturn(vres); } static void worker_getaddrinfo(struct job_getaddrinfo *job) { job->result = getaddrinfo(job->node[0] ? job->node : NULL, job->service[0] ? job->service : NULL, &job->hints, &job->info); } static value result_getaddrinfo(struct job_getaddrinfo *job) { CAMLparam0(); CAMLlocal3(vres, e, v); vres = Val_int(0); if (job->result == 0) { struct addrinfo *r; for (r = job->info; r; r = r->ai_next) { e = convert_addrinfo(r); v = caml_alloc_small(2, 0); Field(v, 0) = e; Field(v, 1) = vres; vres = v; } } if (job->info != NULL) freeaddrinfo(job->info); lwt_unix_free_job(&job->job); CAMLreturn(vres); } CAMLprim value lwt_unix_getaddrinfo_job(value node, value service, value hints) { LWT_UNIX_INIT_JOB_STRING2(job, getaddrinfo, 0, node, service); job->info = NULL; memset(&job->hints, 0, sizeof(struct addrinfo)); job->hints.ai_family = PF_UNSPEC; for (/*nothing*/; hints != Val_emptylist; hints = Field(hints, 1)) { value v = Field(hints, 0); if (Is_block(v)) switch (Tag_val(v)) { case 0: /* AI_FAMILY of socket_domain */ job->hints.ai_family = caml_unix_socket_domain_table[Int_val(Field(v, 0))]; break; case 1: /* AI_SOCKTYPE of socket_type */ job->hints.ai_socktype = caml_unix_socket_type_table[Int_val(Field(v, 0))]; break; case 2: /* AI_PROTOCOL of int */ job->hints.ai_protocol = Int_val(Field(v, 0)); break; } else switch (Int_val(v)) { case 0: /* AI_NUMERICHOST */ job->hints.ai_flags |= AI_NUMERICHOST; break; case 1: /* AI_CANONNAME */ job->hints.ai_flags |= AI_CANONNAME; break; case 2: /* AI_PASSIVE */ job->hints.ai_flags |= AI_PASSIVE; break; } } return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_getcwd_job.c000066400000000000000000000245661476253734400207450ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" /** Lwt C stubs come in two varieties, depending on whether the underlying C call is blocking or non-blocking. In all cases, the Lwt wrapper around the C call must be made to appear *non*-blocking. 1. The simple case is when the underlying C call is already non-blocking. An example of this is `lwt_unix_read`, which is used by Lwt to perform reads from file descriptors that are in non-blocking mode. This stub is a simple wrapper around `read(2)`. It converts its arguments from OCaml runtime representation to normal C, machine representation, passes them to `read(2)`, converts the result back to OCaml, and returns. 2. In case the underlying C call is blocking, as `getcwd(3)` is, Lwt "converts" it to a non-blocking call by running it inside a worker thread. The rest of this comment is concerned with such blocking calls. For background on writing C stubs in OCaml, see https://ocaml.org/manual/intfc.html Each Lwt stub for a blocking C call defines a *job* for the Lwt worker thread pool. The actual thread pool is implemented in `lwt_unix_stubs.c` and is beyond the scope of this comment. It is not necessary to understand it to implement Lwt jobs (indeed, the author currently doesn't remember exactly how it works!). The thread pool expects jobs in a fixed format (the `struct` below) and accompanying functions with fixed names. You *MUST* follow this naming conventions. Specifically, for a job "`FOO`", you must define - the struct `struct job_FOO` - the function `lwt_unix_FOO_job` - the function `worker_FOO` - the function `result_FOO` The struct `struct job_FOO`: This is the representation of the job that will be manipulated by the thread pool. It has several purposes: - Store the pointers to `worker_FOO` and `result_FOO`, so the thread pool is able to run them. - Store the C call arguments, or references to them, so they can be accessed by `worker_FOO` when it runs in the worker thread. - Store the C call results, so they can be accessed by `result_FOO` in the main thread. - Be something that can be placed in queues, or manipulated otherwise. The function `lwt_unix_FOO_job` allocates the job's struct. The function `worker_FOO` is later called in a worker thread to actually run the job. The function `result_FOO` is, even later, called in the main thread to return the result of the job to OCaml, and deallocate the job. It is also possible to define additional helper functions and/or types, as needed. Many stubs are defined on Unix-like systems, but not Windows, and vice versa. However, Lwt's OCaml code lacks conditional compilation for this, and expects all the C symbols to be available on all platforms during linking. It just doesn't call the ones that don't have a real implementation. The unimplemented symbols are defined using the `LWT_NOT_AVAILABLEx` macros. The `getcwd` job currently takes one argument, and is not implemented on Windows. For this reason, `lwt_unix_windows.h` has `LWT_NOT_AVAILABLE1(unix_getcwd_job)`. The `lwt_` prefix is left off. In case this macro is forgotten, Lwt's CI builds should detect that when you open a PR against the Lwt repo. Don't worry if this happens – it's a typical oversight for all contributors and maintainers. See inline comments in the implementation of the `getcwd` job below for other details. */ /** The first field of a job `struct` must always be `struct lwt_unix_job job`: - The `struct lwt_unix_job` contains the data the thread pool needs to manage the job: function pointers, the total size of the job `struct`, etc. Placing it at the start of each job `struct` type ensures that the offsets to these fields are the same between all kinds of jobs. - The `struct lwt_unix_job` must be called `job`, because that is what the job helper macros expect. The job `struct` should also contain a field `error_code`. This is a snapshot of `errno` from the worker thread, right after the C call ran. `errno` is a notorious source of pitfalls; see comments in `worker_getcwd` and `result_getcwd`. The rest of the `struct` is free-form, but typically it contains - One field per argument to the C call. - One field for the return value of the C call. */ struct job_getcwd { struct lwt_unix_job job; char buf[4096]; char *result; int error_code; }; /* In the OCaml sources, getcwd's buffer size is set as either - 4096 (in asmrun/spacetime.c, byterun/sys.c) - PATH_MAX, MAXPATHLEN, or 512 (in otherlibs/unix/getcwd.c) */ /* Runs in the worker thread. This function is `static` (not visible outside this C file) because it is called only through the function pointer that is stored inside `job_getcwd::job` when the job is allocated. `static` is why the name is not prefixed with `lwt_unix_`. */ static void worker_getcwd(struct job_getcwd *job) { /* Run the C call. We don't perform any checking in the worker thread, because we typically don't want to take any other action here – we want to take action in the main thread. In more complex calls, pre-checks on the arguments are done in the `lwt_unix_FOO_job` job-allocating function, and post-checks on the results are done in the `result_FOO` function. */ job->result = getcwd(job->buf, sizeof(job->buf)); /* Store the current value of `errno`. Note that if the C call succeeded, it did not reset `errno` to zero. In that case, `errno` still contains the error code from the last C call to fail in this worker thread. This means that `errno`/`job->error_code` *cannot* be used to determine whether the C call succeeded or not. */ job->error_code = errno; } /* Runs in the main thread. This function is `static` for the same reason as `worker_getcwd`. */ static value result_getcwd(struct job_getcwd *job) { /* This macro is defined in `lwt_unix.h`. The arguments are used as follows: - The first argument is the name of the job variable. - If the check in the second argument *succeeds*, the C call, and job, failed (confusing!). Note that this check must *not* be based solely on `job->error_code`; see comment in `worker_getcwd` above. - The last argument is the name of the C call, used in a `Unix.Unix_error` exception raised if the job failed. If the check succeeds/job failed, this macro deallocates the job, raises the exception, and does *not* "return" to the rest of `result_getcwd`. Otherwise, if the job succeeded, the job is *not* deallocated, and execution continues in the rest of `result_getcwd`. `job->error_code` is used internally by the macro in creating the `Unix.Unix_error`. If this is incorrect (i.e., some job does not set `errno` on failure), it is necessary to replace the macro by its expansion, and modify the behavior. */ LWT_UNIX_CHECK_JOB(job, job->result == NULL, "getcwd"); /* Convert the job result to an OCaml value. In this case, create an OCaml string from the temporary buffer into which `getcwd(3)` wrote the current directory. This copies the string. Throughout Lwt, blocking C calls that run in worker threads can't write directly into OCaml strings, because the OCaml garbage collector might move the strings after the pointer has already been passed to the call, but while the call is still blocked. Bigarrays don't have this problem, so pointers into them are passed to blocking C calls, avoiding a copy. In addition to worker threads not being able to write into OCaml strings, they typically cannot *allocate* any OCaml strings (or other values) either, because the worker threads do not try to take OCaml's global runtime lock. This sometimes results in extra data copies. For an example, see the implementation of `readdir_n`. At the time of this writing, that implementation copied each string returned by `readdir` twice. For jobs that return integers or other kinds of values, it is necessary to use the various `Int_val`, `Long_val` macros, etc. See https://ocaml.org/manual/intfc.html#s:c-ops-on-values */ value result = caml_copy_string(job->result); /* Have to free the job manually! */ lwt_unix_free_job(&job->job); return result; } /* In the case of `Lwt_unix.getcwd`, the argument is `()`, which is represented in C by one argument, which we conventually call `unit`. OCaml always passes the same value for this argument, and we don't use it. */ CAMLprim value lwt_unix_getcwd_job(value unit) { /* Allocate the `job_getcwd` on the OCaml heap. Inside it, store its size, and pointers to `worker_getcwd` and `result_getcwd`. Arguments must be stored manually after the macro is called, but in the case of `getcwd`, there are no arguments to initialize. For an example of a job that has arguments, see `lwt_unix_read_job`. The first argument is the name of the variable to be created to store the pointer to the job `struct`, i.e. struct job_getcwd *job = ... The last argument is the number of bytes of storage to reserve in memory immediately following the `struct`. This is for fields such as `char data[]` at the end of the struct. It is typically zero. For an example where it is not zero, see `lwt_unix_read_job` again. If the additional data is stored inline in the job struct, it is deallocated with `lwt_unix_free_job`. If the additional data is for pointers to additional structure, you must remember to deallocate it yourself. For an example of this, see `readdir_n`.*/ LWT_UNIX_INIT_JOB(job, getcwd, 0); /* Allocate a corresponding object in the OCaml heap. `&job->job` is the same numeric address as `job`, but has type `struct lwt_unix_job`. */ return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_gethostbyaddr_job.c000066400000000000000000000035641476253734400223260ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #define _GNU_SOURCE #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_get_network_information_utils.h" struct job_gethostbyaddr { struct lwt_unix_job job; struct in_addr addr; struct hostent entry; struct hostent *ptr; #ifndef NON_R_GETHOSTBYADDR char buffer[NETDB_BUFFER_SIZE]; #endif }; static void worker_gethostbyaddr(struct job_gethostbyaddr *job) { #if HAS_GETHOSTBYADDR_R == 7 int h_errno; job->ptr = gethostbyaddr_r(&job->addr, 4, AF_INET, &job->entry, job->buffer, NETDB_BUFFER_SIZE, &h_errno); #elif HAS_GETHOSTBYADDR_R == 8 int h_errno; if (gethostbyaddr_r(&job->addr, 4, AF_INET, &job->entry, job->buffer, NETDB_BUFFER_SIZE, &job->ptr, &h_errno) != 0) job->ptr = NULL; #else job->ptr = gethostbyaddr(&job->addr, 4, AF_INET); if (job->ptr) { job->ptr = hostent_dup(job->ptr); if (job->ptr) { job->entry = *job->ptr; } } #endif } static value result_gethostbyaddr(struct job_gethostbyaddr *job) { if (job->ptr == NULL) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { value entry = alloc_host_entry(&job->entry); #ifdef NON_R_GETHOSTBYADDR hostent_free(job->ptr); #endif lwt_unix_free_job(&job->job); return entry; } } CAMLprim value lwt_unix_gethostbyaddr_job(value val_addr) { LWT_UNIX_INIT_JOB(job, gethostbyaddr, 0); job->addr = GET_INET_ADDR(val_addr); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_gethostbyname_job.c000066400000000000000000000035221476253734400223260ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_get_network_information_utils.h" struct job_gethostbyname { struct lwt_unix_job job; struct hostent entry; struct hostent *ptr; #ifndef NON_R_GETHOSTBYNAME char buffer[NETDB_BUFFER_SIZE]; #endif char *name; char data[]; }; static void worker_gethostbyname(struct job_gethostbyname *job) { #if HAS_GETHOSTBYNAME_R == 5 int h_errno; job->ptr = gethostbyname_r(job->name, &job->entry, job->buffer, NETDB_BUFFER_SIZE, &h_errno); #elif HAS_GETHOSTBYNAME_R == 6 int h_errno; if (gethostbyname_r(job->name, &job->entry, job->buffer, NETDB_BUFFER_SIZE, &(job->ptr), &h_errno) != 0) job->ptr = NULL; #else job->ptr = gethostbyname(job->name); if (job->ptr) { job->ptr = hostent_dup(job->ptr); if (job->ptr) { job->entry = *job->ptr; } } #endif } static value result_gethostbyname(struct job_gethostbyname *job) { if (job->ptr == NULL) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { value entry = alloc_host_entry(&job->entry); #ifdef NON_R_GETHOSTBYNAME hostent_free(job->ptr); #endif lwt_unix_free_job(&job->job); return entry; } } CAMLprim value lwt_unix_gethostbyname_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, gethostbyname, 0, name); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_gethostname_job.c000066400000000000000000000030331476253734400217700ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_get_network_information_utils.h" struct job_gethostname { struct lwt_unix_job job; char *buffer; int result; int error_code; }; static void worker_gethostname(struct job_gethostname *job) { int buffer_size = 64; int err; for (;;) { job->buffer = lwt_unix_malloc(buffer_size + 1); err = gethostname(job->buffer, buffer_size); if (err == -1 && errno == ENAMETOOLONG) { free(job->buffer); buffer_size *= 2; } else if (err == -1) { free(job->buffer); job->result = -1; job->error_code = errno; return; } else { job->buffer[buffer_size] = 0; job->result = 0; return; } } } static value result_gethostname(struct job_gethostname *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "gethostname"); value result = caml_copy_string(job->buffer); free(job->buffer); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_gethostname_job(value Unit) { LWT_UNIX_INIT_JOB(job, gethostname, 0); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_getlogin_job.c000066400000000000000000000020771476253734400212710ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" #if !defined(__ANDROID__) struct job_getlogin { struct lwt_unix_job job; char buffer[1024]; int result; }; static void worker_getlogin(struct job_getlogin *job) { job->result = getlogin_r(job->buffer, 1024); } static value result_getlogin(struct job_getlogin *job) { int result = job->result; if (result) { lwt_unix_free_job(&job->job); unix_error(result, "getlogin", Nothing); } else { value v = caml_copy_string(job->buffer); lwt_unix_free_job(&job->job); return v; } } CAMLprim value lwt_unix_getlogin_job(value Unit) { LWT_UNIX_INIT_JOB(job, getlogin, 0); return lwt_unix_alloc_job(&job->job); } #else LWT_NOT_AVAILABLE1(unix_getlogin_job) #endif #endif lwt-5.9.1/src/unix/unix_c/unix_getnameinfo_job.c000066400000000000000000000034171476253734400217540ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include "lwt_unix.h" struct job_getnameinfo { struct lwt_unix_job job; union sock_addr_union addr; socklen_t addr_len; int opts; char host[4096]; char serv[1024]; int result; }; static const int getnameinfo_flag_table[] = {NI_NOFQDN, NI_NUMERICHOST, NI_NAMEREQD, NI_NUMERICSERV, NI_DGRAM}; static void worker_getnameinfo(struct job_getnameinfo *job) { job->result = getnameinfo((const struct sockaddr *)&job->addr.s_gen, job->addr_len, job->host, sizeof(job->host), job->serv, sizeof(job->serv), job->opts); } static value result_getnameinfo(struct job_getnameinfo *job) { CAMLparam0(); CAMLlocal3(vres, vhost, vserv); if (job->result) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { vhost = caml_copy_string(job->host); vserv = caml_copy_string(job->serv); vres = caml_alloc_small(2, 0); Field(vres, 0) = vhost; Field(vres, 1) = vserv; lwt_unix_free_job(&job->job); CAMLreturn(vres); } } CAMLprim value lwt_unix_getnameinfo_job(value sockaddr, value opts) { LWT_UNIX_INIT_JOB(job, getnameinfo, 0); get_sockaddr(sockaddr, &job->addr, &job->addr_len); job->opts = lwt_convert_flag_list(opts, getnameinfo_flag_table); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_getprotoby_getservby_job.c000066400000000000000000000245751476253734400237600ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #define ARGS(args...) args #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_get_network_information_utils.h" static value alloc_protoent(struct protoent *entry) { value res; value name = Val_unit, aliases = Val_unit; Begin_roots2(name, aliases); name = caml_copy_string(entry->p_name); aliases = caml_copy_string_array((const char **)entry->p_aliases); res = caml_alloc_small(3, 0); Field(res, 0) = name; Field(res, 1) = aliases; Field(res, 2) = Val_int(entry->p_proto); End_roots(); return res; } static value alloc_servent(struct servent *entry) { value res; value name = Val_unit, aliases = Val_unit, proto = Val_unit; Begin_roots3(name, aliases, proto); name = caml_copy_string(entry->s_name); aliases = caml_copy_string_array((const char **)entry->s_aliases); proto = caml_copy_string(entry->s_proto); res = caml_alloc_small(4, 0); Field(res, 0) = name; Field(res, 1) = aliases; Field(res, 2) = Val_int(ntohs(entry->s_port)); Field(res, 3) = proto; End_roots(); return res; } #if defined(HAVE_NETDB_REENTRANT) #define JOB_GET_ENTRY2(INIT, FUNC, TYPE, ARGS_VAL, ARGS_DECL, ARGS_CALL) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE entry; \ struct TYPE *ptr; \ char *buffer; \ ARGS_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ size_t size = 1024; \ for (;;) { \ job->buffer = (char *)lwt_unix_malloc(size); \ \ int result = FUNC##_r(ARGS_CALL, &job->entry, job->buffer, size, \ &job->ptr); \ \ switch (result) { \ case 0: \ return; \ case ERANGE: \ free(job->buffer); \ size += 1024; \ break; \ case ENOENT: \ default: \ job->ptr = NULL; \ return; \ } \ } \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ if (job->ptr == NULL) { \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value res = alloc_##TYPE(&job->entry); \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ return res; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(ARGS_VAL) \ { \ INIT; \ return lwt_unix_alloc_job(&(job->job)); \ } #else /* defined(HAVE_NETDB_REENTRANT) */ static struct servent *servent_dup(const struct servent *serv) { struct servent *s; if (!serv) { return NULL; } s = malloc(sizeof *s); if (s == NULL) { goto nomem1; } s->s_name = s_strdup(serv->s_name); if (s->s_name == NULL) { goto nomem2; } s->s_proto = s_strdup(serv->s_proto); if (s->s_proto == NULL) { goto nomem3; } s->s_aliases = c_copy_string_array(serv->s_aliases); if (s->s_aliases == NULL && serv->s_aliases != NULL) { goto nomem4; } s->s_port = serv->s_port; return s; nomem4: free(s->s_proto); nomem3: free(s->s_name); nomem2: free(s); nomem1: return NULL; } static void servent_free(struct servent *s) { if (!s) { return; } free(s->s_proto); free(s->s_name); c_free_string_array(s->s_aliases); free(s); } static struct protoent *protoent_dup(const struct protoent *proto) { if (!proto) { return NULL; } struct protoent *p = malloc(sizeof *p); if (p == NULL) { return NULL; } p->p_name = s_strdup(proto->p_name); if (p->p_name == NULL) { goto nomem1; } p->p_aliases = c_copy_string_array(proto->p_aliases); if (p->p_aliases == NULL && proto->p_aliases != NULL) { goto nomem2; } p->p_proto = proto->p_proto; return p; nomem2: free(p->p_name); nomem1: free(p); return NULL; } static void protoent_free(struct protoent *p) { if (p) { free(p->p_name); c_free_string_array(p->p_aliases); free(p); } } #define JOB_GET_ENTRY2(INIT, FUNC, TYPE, ARGS_VAL, ARGS_DECL, ARGS_CALL) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE *entry; \ ARGS_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ job->entry = FUNC(ARGS_CALL); \ if (job->entry) { \ job->entry = TYPE##_dup(job->entry); \ if (!job->entry) { \ } \ } \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ if (job->entry == NULL) { \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value res = alloc_##TYPE(job->entry); \ TYPE##_free(job->entry); \ lwt_unix_free_job(&job->job); \ return res; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(ARGS_VAL) \ { \ INIT; \ return lwt_unix_alloc_job(&(job->job)); \ } #endif /* defined(HAVE_NETDB_REENTRANT) */ JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING(job, getprotobyname, 0, name), getprotobyname, protoent, value name, char *name; char data[], job->name) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB(job, getprotobynumber, 0); job->num = Int_val(num), getprotobynumber, protoent, value num, int num, job->num) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING2(job, getservbyname, 0, name, proto), getservbyname, servent, ARGS(value name, value proto), char *name; char *proto; char data[], ARGS(job->name, job->proto)) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING(job, getservbyport, 0, proto); job->port = htons(Int_val(port)), getservbyport, servent, ARGS(value port, value proto), int port; char *proto; char data[], ARGS(job->port, job->proto)) #endif lwt-5.9.1/src/unix/unix_c/unix_guess_blocking_job.c000066400000000000000000000020271476253734400224520ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" struct job_guess_blocking { struct lwt_unix_job job; int fd; int result; }; static void worker_guess_blocking(struct job_guess_blocking *job) { struct stat stat; if (fstat(job->fd, &stat) == 0) job->result = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode)); else job->result = 1; } static value result_guess_blocking(struct job_guess_blocking *job) { value result = Val_bool(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_guess_blocking_job(value val_fd) { LWT_UNIX_INIT_JOB(job, guess_blocking, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_invalidate_dir.c000066400000000000000000000007631476253734400216050ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" CAMLprim value lwt_unix_invalidate_dir(value dir) { CAMLparam1(dir); DIR_Val(dir) = NULL; CAMLreturn(Val_unit); } #endif lwt-5.9.1/src/unix/unix_c/unix_iov_max.c000066400000000000000000000011021476253734400202550ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #define _GNU_SOURCE #include #include #include #include CAMLprim value lwt_unix_iov_max(value unit) { CAMLparam1(unit); CAMLlocal1(res); #ifdef IOV_MAX res = caml_alloc(1, 0); Store_field(res, 0, Val_int(IOV_MAX)); #else res = Val_int(0); #endif CAMLreturn(res); } #endif lwt-5.9.1/src/unix/unix_c/unix_isatty_job.c000066400000000000000000000014561476253734400207760ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include "lwt_unix.h" struct job_isatty { struct lwt_unix_job job; int fd; int result; }; static void worker_isatty(struct job_isatty *job) { job->result = isatty(job->fd); } static value result_isatty(struct job_isatty *job) { value result = Val_bool(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_isatty_job(value val_fd) { LWT_UNIX_INIT_JOB(job, isatty, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_link_job.c000066400000000000000000000071031476253734400204110ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [link]: int link(char* oldpath, char* newpath) - these are the expected ocaml externals for this job: external link_job : string -> string -> unit Lwt_unix.job = "lwt_unix_link_job" external link_sync : string -> string -> unit = "lwt_unix_link_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [link]. */ struct job_link { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* oldpath; /* in parameter. */ char* newpath; /* Buffer for string parameters. */ char data[]; }; /* The function calling [link]. */ static void worker_link(struct job_link* job) { /* Perform the blocking call. */ job->result = link(job->oldpath, job->newpath); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_link(struct job_link* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->oldpath into a caml string. */ value string_argument = caml_copy_string(job->oldpath); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "link", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_link_job(value oldpath, value newpath) { /* Get the length of the oldpath parameter. */ mlsize_t len_oldpath = caml_string_length(oldpath) + 1; /* Get the length of the newpath parameter. */ mlsize_t len_newpath = caml_string_length(newpath) + 1; /* Allocate a new job. */ struct job_link* job = lwt_unix_new_plus(struct job_link, len_oldpath + len_newpath); /* Set the offset of the oldpath parameter inside the job structure. */ job->oldpath = job->data; /* Set the offset of the newpath parameter inside the job structure. */ job->newpath = job->data + len_oldpath; /* Copy the oldpath parameter inside the job structure. */ memcpy(job->oldpath, String_val(oldpath), len_oldpath); /* Copy the newpath parameter inside the job structure. */ memcpy(job->newpath, String_val(newpath), len_newpath); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_link; job->job.result = (lwt_unix_job_result)result_link; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_link_job(value Unit) { lwt_unix_not_available("link"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_lockf_job.c000066400000000000000000000056111476253734400205540ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" struct job_lockf { struct lwt_unix_job job; int fd; int command; long length; int result; int error_code; }; #if defined(F_GETLK) && defined(F_SETLK) && defined(F_SETLKW) static void worker_lockf(struct job_lockf *job) { struct flock l; l.l_whence = 1; if (job->length < 0) { l.l_start = job->length; l.l_len = -job->length; } else { l.l_start = 0L; l.l_len = job->length; } switch (job->command) { case 0: /* F_ULOCK */ l.l_type = F_UNLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; case 1: /* F_LOCK */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_SETLKW, &l); job->error_code = errno; break; case 2: /* F_TLOCK */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; case 3: /* F_TEST */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_GETLK, &l); if (job->result != -1) { if (l.l_type == F_UNLCK) { job->result = 0; } else { job->result = -1; job->error_code = EACCES; } } break; case 4: /* F_RLOCK */ l.l_type = F_RDLCK; job->result = fcntl(job->fd, F_SETLKW, &l); job->error_code = errno; break; case 5: /* F_TRLOCK */ l.l_type = F_RDLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; default: job->result = -1; job->error_code = EINVAL; } } #else static const int lock_command_table[] = {F_ULOCK, F_LOCK, F_TLOCK, F_TEST, F_LOCK, F_TLOCK}; static void worker_lockf(struct job_lockf *job) { job->result = lockf(job->fd, lock_command_table[job->command], job->length); job->error_code = errno; } #endif static value result_lockf(struct job_lockf *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "lockf"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_lockf_job(value val_fd, value val_command, value val_length) { LWT_UNIX_INIT_JOB(job, lockf, 0); job->fd = Int_val(val_fd); job->command = Int_val(val_command); job->length = Long_val(val_length); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_lseek_job.c000066400000000000000000000117011476253734400205560ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [lseek]: off_t lseek(int fd, off_t offset, int whence) - these are the expected ocaml externals for this job: external lseek_job : Unix.file_descr -> int -> Unix.seek_command -> int Lwt_unix.job = "lwt_unix_lseek_job" external lseek_sync : Unix.file_descr -> int -> Unix.seek_command -> int = "lwt_unix_lseek_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Converters | +-----------------------------------------------------------------+ */ /* Table mapping constructors of ocaml type Unix.seek_command to C values. */ static const int seek_command_table[] = { /* Constructor SEEK_SET. */ SEEK_SET, /* Constructor SEEK_CUR. */ SEEK_CUR, /* Constructor SEEK_END. */ SEEK_END }; /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [lseek]. */ struct job_lseek { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ off_t result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; /* in parameter. */ off_t offset; /* in parameter. */ int whence; }; /* The function calling [lseek]. */ static void worker_lseek(struct job_lseek* job) { /* Perform the blocking call. */ job->result = lseek(job->fd, job->offset, job->whence); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_lseek(struct job_lseek* job) { value result; /* Check for errors. */ if (job->result == (off_t)-1) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "lseek", Nothing); } /* Build the caml result. */ result = Val_long(job->result); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return result; } /* The function building the caml result. */ static value result_lseek_64(struct job_lseek* job) { value result; /* Check for errors. */ if (job->result == (off_t)-1) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "lseek", Nothing); } /* Build the caml result. */ result = caml_copy_int64(job->result); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return result; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_lseek_job(value fd, value offset, value whence) { /* Allocate a new job. */ struct job_lseek* job = lwt_unix_new(struct job_lseek); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_lseek; job->job.result = (lwt_unix_job_result)result_lseek; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the offset parameter. */ job->offset = Long_val(offset); /* Copy the whence parameter. */ job->whence = seek_command_table[Int_val(whence)]; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } /* The stub creating the job structure. */ CAMLprim value lwt_unix_lseek_64_job(value fd, value offset, value whence) { /* Allocate a new job. */ struct job_lseek* job = lwt_unix_new(struct job_lseek); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_lseek; job->job.result = (lwt_unix_job_result)result_lseek_64; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the offset parameter. */ job->offset = Int64_val(offset); /* Copy the whence parameter. */ job->whence = seek_command_table[Int_val(whence)]; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_lseek_job(value Unit) { lwt_unix_not_available("lseek"); return Val_unit; } CAMLprim value lwt_unix_lseek_64_job(value Unit) { lwt_unix_not_available("lseek"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_lstat_64_job.c000066400000000000000000000010421476253734400211100ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include "lwt_unix.h" #include "unix_stat_job_utils.h" CAMLprim value lwt_unix_lstat_64_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, lstat, 0, name); job->job.result = (lwt_unix_job_result)result_lstat_64; return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_lstat_job.c000066400000000000000000000007431476253734400206060ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include "lwt_unix.h" #include "unix_stat_job_utils.h" CAMLprim value lwt_unix_lstat_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, lstat, 0, name); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_madvise.c000066400000000000000000000020611476253734400202500ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include static const int advise_table[] = { MADV_NORMAL, MADV_RANDOM, MADV_SEQUENTIAL, MADV_WILLNEED, MADV_DONTNEED, #if defined(MADV_MERGEABLE) MADV_MERGEABLE, #else 0, #endif #if defined(MADV_UNMERGEABLE) MADV_UNMERGEABLE, #else 0, #endif #if defined(MADV_HUGEPAGE) MADV_HUGEPAGE, #else 0, #endif #if defined(MADV_NOHUGEPAGE) MADV_NOHUGEPAGE, #else 0, #endif }; CAMLprim value lwt_unix_madvise(value val_buffer, value val_offset, value val_length, value val_advice) { int ret = madvise((char *)Caml_ba_data_val(val_buffer) + Long_val(val_offset), Long_val(val_length), advise_table[Int_val(val_advice)]); if (ret == -1) uerror("madvise", Nothing); return Val_unit; } #endif lwt-5.9.1/src/unix/unix_c/unix_mcast_modify_membership.c000066400000000000000000000034511476253734400235150ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "unix_mcast_utils.h" /* Keep this in sync with the type Lwt_unix.mcast_action */ #define VAL_MCAST_ACTION_ADD (Val_int(0)) #define VAL_MCAST_ACTION_DROP (Val_int(1)) CAMLprim value lwt_unix_mcast_modify_membership(value fd, value v_action, value if_addr, value group_addr) { int t, r; int fd_sock; int optname; fd_sock = Int_val(fd); t = socket_domain(fd_sock); r = 0; switch (t) { case PF_INET: { struct ip_mreq mreq; if (caml_string_length(group_addr) != 4 || caml_string_length(if_addr) != 4) { caml_invalid_argument( "lwt_unix_mcast_modify: Not an IPV4 address"); } memcpy(&mreq.imr_multiaddr, &GET_INET_ADDR(group_addr), 4); memcpy(&mreq.imr_interface, &GET_INET_ADDR(if_addr), 4); switch (v_action) { case VAL_MCAST_ACTION_ADD: optname = IP_ADD_MEMBERSHIP; break; default: optname = IP_DROP_MEMBERSHIP; break; } r = setsockopt(fd_sock, IPPROTO_IP, optname, (void *)&mreq, sizeof(mreq)); break; } default: caml_invalid_argument("lwt_unix_mcast_modify_membership"); }; if (r == -1) uerror("setsockopt", Nothing); return Val_unit; } #endif lwt-5.9.1/src/unix/unix_c/unix_mcast_set_loop.c000066400000000000000000000015311476253734400216340ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "unix_mcast_utils.h" CAMLprim value lwt_unix_mcast_set_loop(value fd, value flag) { int t, r, f; t = socket_domain(Int_val(fd)); f = Bool_val(flag); r = 0; switch (t) { case PF_INET: r = setsockopt(Int_val(fd), IPPROTO_IP, IP_MULTICAST_LOOP, (void *)&f, sizeof(f)); break; default: caml_invalid_argument("lwt_unix_mcast_set_loop"); }; if (r == -1) uerror("setsockopt", Nothing); return Val_unit; } #endif lwt-5.9.1/src/unix/unix_c/unix_mcast_set_ttl.c000066400000000000000000000015671476253734400214770ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "unix_mcast_utils.h" CAMLprim value lwt_unix_mcast_set_ttl(value fd, value ttl) { int t, r, v; int fd_sock; fd_sock = Int_val(fd); t = socket_domain(fd_sock); v = Int_val(ttl); r = 0; switch (t) { case PF_INET: r = setsockopt(fd_sock, IPPROTO_IP, IP_MULTICAST_TTL, (void *)&v, sizeof(v)); break; default: caml_invalid_argument("lwt_unix_mcast_set_ttl"); }; if (r == -1) uerror("setsockopt", Nothing); return Val_unit; } #endif lwt-5.9.1/src/unix/unix_c/unix_mcast_utils.c000066400000000000000000000016121476253734400211500ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "unix_mcast_utils.h" int socket_domain(int fd) { /* Return the socket domain, PF_INET or PF_INET6. Fails for non-IP protos. fd must be a socket! */ union sock_addr_union addr; socklen_t l; l = sizeof(addr); if (getsockname(fd, &addr.s_gen, &l) == -1) uerror("getsockname", Nothing); switch (addr.s_gen.sa_family) { case AF_INET: return PF_INET; case AF_INET6: return PF_INET6; default: caml_invalid_argument("Not an Internet socket"); } return 0; } #endif lwt-5.9.1/src/unix/unix_c/unix_mcast_utils.h000066400000000000000000000007131476253734400211560ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #pragma once #include "lwt_config.h" /* * Included in: * - unix_mcast_modify_membership.c * - unix_mcast_set_loop.c * - unix_mcast_set_ttl.c * - unix_mcast_utils.c */ #if !defined(LWT_ON_WINDOWS) #include #include int socket_domain(int fd); #endif lwt-5.9.1/src/unix/unix_c/unix_mincore.c000066400000000000000000000021541476253734400202570ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" #ifdef __CYGWIN__ LWT_NOT_AVAILABLE4(unix_mincore) #elif defined __OpenBSD__ #include #if !defined SYS_mincore LWT_NOT_AVAILABLE4(unix_mincore) #endif #else #ifdef HAVE_BSD_MINCORE #define MINCORE_VECTOR_TYPE char #else #define MINCORE_VECTOR_TYPE unsigned char #endif CAMLprim value lwt_unix_mincore(value val_buffer, value val_offset, value val_length, value val_states) { long len = Wosize_val(val_states); MINCORE_VECTOR_TYPE vec[len]; mincore((char *)Caml_ba_data_val(val_buffer) + Long_val(val_offset), Long_val(val_length), vec); long i; for (i = 0; i < len; i++) Field(val_states, i) = Val_bool(vec[i] & 1); return Val_unit; } #undef MINCORE_VECTOR_TYPE #endif #endif lwt-5.9.1/src/unix/unix_c/unix_mkdir_job.c000066400000000000000000000064061476253734400205670ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [mkdir]: int mkdir(char* path, int mode) - these are the expected ocaml externals for this job: external mkdir_job : string -> int -> unit Lwt_unix.job = "lwt_unix_mkdir_job" external mkdir_sync : string -> int -> unit = "lwt_unix_mkdir_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [mkdir]. */ struct job_mkdir { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* in parameter. */ int mode; /* Buffer for string parameters. */ char data[]; }; /* The function calling [mkdir]. */ static void worker_mkdir(struct job_mkdir* job) { /* Perform the blocking call. */ job->result = mkdir(job->path, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_mkdir(struct job_mkdir* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "mkdir", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_mkdir_job(value path, value mode) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_mkdir* job = lwt_unix_new_plus(struct job_mkdir, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_mkdir; job->job.result = (lwt_unix_job_result)result_mkdir; /* Copy the mode parameter. */ job->mode = Int_val(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_mkdir_job(value Unit) { lwt_unix_not_available("mkdir"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_mkfifo_job.c000066400000000000000000000064341476253734400207350ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [mkfifo]: int mkfifo(char* path, int mode) - these are the expected ocaml externals for this job: external mkfifo_job : string -> int -> unit Lwt_unix.job = "lwt_unix_mkfifo_job" external mkfifo_sync : string -> int -> unit = "lwt_unix_mkfifo_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [mkfifo]. */ struct job_mkfifo { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* in parameter. */ int mode; /* Buffer for string parameters. */ char data[]; }; /* The function calling [mkfifo]. */ static void worker_mkfifo(struct job_mkfifo* job) { /* Perform the blocking call. */ job->result = mkfifo(job->path, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_mkfifo(struct job_mkfifo* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "mkfifo", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_mkfifo_job(value path, value mode) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_mkfifo* job = lwt_unix_new_plus(struct job_mkfifo, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_mkfifo; job->job.result = (lwt_unix_job_result)result_mkfifo; /* Copy the mode parameter. */ job->mode = Int_val(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_mkfifo_job(value Unit) { lwt_unix_not_available("mkfifo"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_not_available.c000066400000000000000000000007451476253734400214270ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include "lwt_unix.h" LWT_NOT_AVAILABLE1(unix_is_socket) LWT_NOT_AVAILABLE1(unix_system_job) LWT_NOT_AVAILABLE1(unix_socketpair_stub) LWT_NOT_AVAILABLE4(process_create_process) LWT_NOT_AVAILABLE1(process_wait_job) LWT_NOT_AVAILABLE2(process_terminate_process) #endif lwt-5.9.1/src/unix/unix_c/unix_open_job.c000066400000000000000000000057571476253734400204320ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include "lwt_unix.h" #ifndef O_NONBLOCK #define O_NONBLOCK O_NDELAY #endif #ifndef O_DSYNC #define O_DSYNC 0 #endif #ifndef O_SYNC #define O_SYNC 0 #endif #ifndef O_RSYNC #define O_RSYNC 0 #endif #if OCAML_VERSION_MAJOR < 5 #define caml_unix_cloexec_default unix_cloexec_default #endif static const int open_flag_table[] = { O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0, /* O_SHARE_DELETE, Windows-only */ 0, /* O_CLOEXEC, treated specially */ 0 /* O_KEEPEXEC, treated specially */ }; enum { CLOEXEC = 1, KEEPEXEC = 2 }; static int open_cloexec_table[15] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, CLOEXEC, KEEPEXEC}; struct job_open { struct lwt_unix_job job; int flags; int perms; int fd; /* will have value CLOEXEC or KEEPEXEC on entry to worker_open */ int blocking; int error_code; char *name; char data[]; }; static void worker_open(struct job_open *job) { int fd; int cloexec; if (job->fd & CLOEXEC) cloexec = 1; else if (job->fd & KEEPEXEC) cloexec = 0; else cloexec = caml_unix_cloexec_default; #if defined(O_CLOEXEC) if (cloexec) job->flags |= O_CLOEXEC; #endif fd = open(job->name, job->flags, job->perms); #if !defined(O_CLOEXEC) && defined(FD_CLOEXEC) if (fd >= 0 && cloexec) { int flags = fcntl(fd, F_GETFD, 0); if (flags == -1 || fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1) { int serrno = errno; close(fd); errno = serrno; fd = -1; } } #endif job->fd = fd; job->error_code = errno; if (fd >= 0) { struct stat stat; if (fstat(fd, &stat) < 0) job->blocking = 1; else job->blocking = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode)); } } static value result_open(struct job_open *job) { int fd = job->fd; LWT_UNIX_CHECK_JOB_ARG(job, fd < 0, "open", job->name); value result = caml_alloc_tuple(2); Field(result, 0) = Val_int(fd); Field(result, 1) = Val_bool(job->blocking); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_open_job(value name, value flags, value perms) { LWT_UNIX_INIT_JOB_STRING(job, open, 0, name); job->fd = lwt_convert_flag_list(flags, open_cloexec_table); job->flags = lwt_convert_flag_list(flags, open_flag_table); job->perms = Int_val(perms); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_opendir_job.c000066400000000000000000000020461476253734400211150ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "lwt_unix.h" struct job_opendir { struct lwt_unix_job job; DIR *result; int error_code; char *path; char data[]; }; static void worker_opendir(struct job_opendir *job) { job->result = opendir(job->path); job->error_code = errno; } static value result_opendir(struct job_opendir *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result == NULL, "opendir", job->path); value result = caml_alloc_small(1, Abstract_tag); DIR_Val(result) = job->result; lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_opendir_job(value path) { LWT_UNIX_INIT_JOB_STRING(job, opendir, 0, path); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_pread.c000066400000000000000000000012121476253734400177100ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include CAMLprim value lwt_unix_pread(value val_fd, value val_buf, value val_file_ofs, value val_ofs, value val_len) { long ret; ret = pread(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len), Long_val(val_file_ofs)); if (ret == -1) uerror("pread", Nothing); return Val_long(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_pread_job.c000066400000000000000000000040721476253734400205510ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "lwt_unix.h" struct job_pread { struct lwt_unix_job job; /* The file descriptor. */ int fd; /* The amount of data to read. */ long length; /* The offset in the file */ off_t file_offset; /* The OCaml string. */ value string; /* The offset in the string. */ long offset; /* The result of the pread syscall. */ long result; /* The value of errno. */ int error_code; /* The temporary buffer. */ char buffer[]; }; static void worker_pread(struct job_pread *job) { job->result = pread(job->fd, job->buffer, job->length, job->file_offset); job->error_code = errno; } static value result_pread(struct job_pread *job) { long result = job->result; if (result < 0) { int error_code = job->error_code; caml_remove_generational_global_root(&(job->string)); lwt_unix_free_job(&job->job); unix_error(error_code, "pread", Nothing); } else { memcpy(Bytes_val(job->string) + job->offset, job->buffer, result); caml_remove_generational_global_root(&(job->string)); lwt_unix_free_job(&job->job); return Val_long(result); } } CAMLprim value lwt_unix_pread_job(value val_fd, value val_buffer, value val_file_offset, value val_offset, value val_length) { long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, pread, length); job->fd = Int_val(val_fd); job->length = length; job->file_offset = Long_val(val_file_offset); job->string = val_buffer; job->offset = Long_val(val_offset); caml_register_generational_global_root(&(job->string)); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_pwrite.c000066400000000000000000000012431476253734400201330ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_pwrite(value val_fd, value val_buf, value val_file_ofs, value val_ofs, value val_len) { long ret; ret = pwrite(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len), Long_val(val_file_ofs)); if (ret == -1) uerror("pwrite", Nothing); return Val_long(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_pwrite_job.c000066400000000000000000000025501476253734400207670ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" struct job_pwrite { struct lwt_unix_job job; int fd; long length; off_t file_offset; long result; int error_code; char buffer[]; }; static void worker_pwrite(struct job_pwrite *job) { job->result = pwrite(job->fd, job->buffer, job->length, job->file_offset); job->error_code = errno; } static value result_pwrite(struct job_pwrite *job) { long result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "pwrite"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_pwrite_job(value val_fd, value val_string, value val_file_offset, value val_offset, value val_length) { long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, pwrite, length); job->fd = Int_val(val_fd); job->length = length; job->file_offset = Long_val(val_file_offset); memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_read.c000066400000000000000000000011311476253734400175300ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include CAMLprim value lwt_unix_read(value val_fd, value val_buf, value val_ofs, value val_len) { long ret; ret = read(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len)); if (ret == -1) uerror("read", Nothing); return Val_long(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_read_job.c000066400000000000000000000035721476253734400203750ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "lwt_unix.h" struct job_read { struct lwt_unix_job job; /* The file descriptor. */ int fd; /* The amount of data to read. */ long length; /* The OCaml string. */ value string; /* The offset in the string. */ long offset; /* The result of the read syscall. */ long result; /* The value of errno. */ int error_code; /* The temporary buffer. */ char buffer[]; }; static void worker_read(struct job_read *job) { job->result = read(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_read(struct job_read *job) { long result = job->result; if (result < 0) { int error_code = job->error_code; caml_remove_generational_global_root(&(job->string)); lwt_unix_free_job(&job->job); unix_error(error_code, "read", Nothing); } else { memcpy(Bytes_val(job->string) + job->offset, job->buffer, result); caml_remove_generational_global_root(&(job->string)); lwt_unix_free_job(&job->job); return Val_long(result); } } CAMLprim value lwt_unix_read_job(value val_fd, value val_buffer, value val_offset, value val_length) { long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, read, length); job->fd = Int_val(val_fd); job->length = length; job->string = val_buffer; job->offset = Long_val(val_offset); caml_register_generational_global_root(&(job->string)); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_readable.c000066400000000000000000000010641476253734400203610ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_readable(value fd) { struct pollfd pollfd; pollfd.fd = Int_val(fd); pollfd.events = POLLIN; pollfd.revents = 0; if (poll(&pollfd, 1, 0) < 0) uerror("readable", Nothing); return (Val_bool(pollfd.revents & POLLIN)); } #endif lwt-5.9.1/src/unix/unix_c/unix_readdir_job.c000066400000000000000000000035061476253734400210710ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include "lwt_unix.h" struct job_readdir { struct lwt_unix_job job; DIR *dir; struct dirent *entry; int error_code; }; static void worker_readdir(struct job_readdir *job) { // From the man page of readdir // If the end of the directory stream is reached, NULL is returned and // errno is not changed. If an error occurs, NULL is returned and errno // is set appropriately. To distinguish end of stream and from an error, // set errno to zero before calling readdir() and then check the value of // errno if NULL is returned. errno = 0; job->entry = readdir(job->dir); job->error_code = errno; } static value result_readdir(struct job_readdir *job) { LWT_UNIX_CHECK_JOB(job, job->entry == NULL && job->error_code != 0, "readdir"); if (job->entry == NULL) { // From the man page // On success, readdir() returns a pointer to a dirent structure. // (This structure may be statically allocated; do not attempt to // free(3) it.) lwt_unix_free_job(&job->job); caml_raise_end_of_file(); } else { value name = caml_copy_string(job->entry->d_name); // see above about not freeing dirent lwt_unix_free_job(&job->job); return name; } } CAMLprim value lwt_unix_readdir_job(value val_dir) { LWT_UNIX_INIT_JOB(job, readdir, 0); job->dir = DIR_Val(val_dir); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_readdir_n_job.c000066400000000000000000000050661476253734400214110ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include "lwt_unix.h" struct job_readdir_n { struct lwt_unix_job job; DIR *dir; /* count serves two purpose: 1. Transmit the maximum number of entries requested by the programmer. See `readdir_n`'s OCaml side documentation. 2. Transmit the number of actually read entries from the `worker` to the result parser. See below `worker_readdir_n` and `result_readdir_n` */ long count; int error_code; char *entries[]; }; static void worker_readdir_n(struct job_readdir_n *job) { long i; for (i = 0; i < job->count; i++) { errno = 0; struct dirent *entry = readdir(job->dir); /* An error happened. */ if (entry == NULL && errno != 0) { job->count = i; job->error_code = errno; return; } /* End of directory reached */ if (entry == NULL && errno == 0) break; /* readdir is good */ char *name = strdup(entry->d_name); if (name == NULL) { job->count = i; job->error_code = errno; return; } /* All is good */ job->entries[i] = name; } job->count = i; job->error_code = 0; } static value result_readdir_n(struct job_readdir_n *job) { CAMLparam0(); CAMLlocal1(result); int error_code = job->error_code; if (error_code) { long i; for (i = 0; i < job->count; i++) free(job->entries[i]); lwt_unix_free_job(&job->job); unix_error(error_code, "readdir", Nothing); } else { result = caml_alloc(job->count, 0); long i; for (i = 0; i < job->count; i++) { Store_field(result, i, caml_copy_string(job->entries[i])); } for (i = 0; i < job->count; i++) free(job->entries[i]); lwt_unix_free_job(&job->job); CAMLreturn(result); } } CAMLprim value lwt_unix_readdir_n_job(value val_dir, value val_count) { long count = Long_val(val_count); DIR *dir = DIR_Val(val_dir); LWT_UNIX_INIT_JOB(job, readdir_n, sizeof(char *) * count); job->dir = dir; job->count = count; return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_readlink_job.c000066400000000000000000000030251476253734400212440ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" struct job_readlink { struct lwt_unix_job job; char *buffer; ssize_t result; int error_code; char *name; char data[]; }; static void worker_readlink(struct job_readlink *job) { ssize_t buffer_size = 1024; ssize_t link_length; for (;;) { job->buffer = lwt_unix_malloc(buffer_size + 1); link_length = readlink(job->name, job->buffer, buffer_size); if (link_length < 0) { free(job->buffer); job->result = -1; job->error_code = errno; return; } if (link_length < buffer_size) { job->buffer[link_length] = 0; job->result = link_length; return; } else { free(job->buffer); buffer_size *= 2; } } } static value result_readlink(struct job_readlink *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "readlink", job->name); value result = caml_copy_string(job->buffer); free(job->buffer); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_readlink_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, readlink, 0, name); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_readv.c000066400000000000000000000017101476253734400177210ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include "lwt_unix.h" #include "unix_readv_writev_utils.h" /* readv primitive for non-blocking file descriptors. */ CAMLprim value lwt_unix_readv(value fd, value io_vectors, value val_count) { CAMLparam3(fd, io_vectors, val_count); size_t count = Long_val(val_count); /* Assemble iovec structures on the stack. */ struct iovec iovecs[count]; flatten_io_vectors(iovecs, io_vectors, count, NULL, NULL); /* Data is read directly into the buffers. There is no need to copy afterwards. */ ssize_t result = readv(Int_val(fd), iovecs, count); if (result == -1) uerror("readv", Nothing); CAMLreturn(Val_long(result)); } #endif lwt-5.9.1/src/unix/unix_c/unix_readv_job.c000066400000000000000000000062051476253734400205570ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" #include "unix_readv_writev_utils.h" /* Job and readv primitives for blocking file descriptors. */ struct job_readv { struct lwt_unix_job job; int fd; int error_code; ssize_t result; size_t count; /* Heap-allocated iovec structures. */ struct iovec *iovecs; /* Reference to OCaml I/O vectors, to be retained for the duration of the readv operation. */ value ocaml_io_vectors; /* Data to be read into bytes buffers is first read into temporary buffers on the C heap. This is an array of descriptors for copying that data into the actual bytes buffers. The array is terminated by a descriptor whose temporary_buffer member is NULL. */ struct readv_copy_to buffers[]; }; static void worker_readv(struct job_readv *job) { job->result = readv(job->fd, job->iovecs, job->count); job->error_code = errno; } static value result_readv(struct job_readv *job) { struct readv_copy_to *read_buffer; /* If the read is successful, copy data to the OCaml buffers. */ if (job->result != -1) { for (read_buffer = job->buffers; read_buffer->temporary_buffer != NULL; ++read_buffer) { memcpy(&Byte(String_val(read_buffer->caml_buffer), read_buffer->offset), read_buffer->temporary_buffer, read_buffer->length); } } /* Free heap-allocated structures and buffers. */ for (read_buffer = job->buffers; read_buffer->temporary_buffer != NULL; ++read_buffer) { free(read_buffer->temporary_buffer); caml_remove_generational_global_root(&read_buffer->caml_buffer); } free(job->iovecs); caml_remove_generational_global_root(&job->ocaml_io_vectors); /* Decide on the actual result. */ ssize_t result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "readv"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_readv_job(value fd, value io_vectors, value val_count) { CAMLparam3(fd, io_vectors, val_count); size_t count = Long_val(val_count); /* The extra struct readv_copy_to (+ 1) is for the final terminator, in case all buffer slices are in bytes buffers. */ LWT_UNIX_INIT_JOB(job, readv, sizeof(struct readv_copy_to) * (count + 1)); job->fd = Int_val(fd); job->count = count; /* Assemble iovec structures on the heap. */ job->iovecs = lwt_unix_malloc(sizeof(struct iovec) * count); flatten_io_vectors( job->iovecs, Field(io_vectors, 0), count, NULL, job->buffers); /* Retain the OCaml I/O vectors, so that the buffers don't get deallocated by the GC. */ job->ocaml_io_vectors = io_vectors; caml_register_generational_global_root(&job->ocaml_io_vectors); CAMLreturn(lwt_unix_alloc_job(&job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_readv_writev_utils.c000066400000000000000000000045611476253734400225500ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" #include "unix_readv_writev_utils.h" void flatten_io_vectors(struct iovec *iovecs, value io_vectors, size_t count, char **buffer_copies, struct readv_copy_to *read_buffers) { CAMLparam1(io_vectors); CAMLlocal3(node, io_vector, buffer); size_t index; size_t copy_index = 0; for (node = io_vectors, index = 0; index < count; node = Field(node, 1), ++index) { io_vector = Field(node, 0); intnat offset = Long_val(Field(io_vector, 1)); intnat length = Long_val(Field(io_vector, 2)); iovecs[index].iov_len = length; buffer = Field(Field(io_vector, 0), 0); if (Tag_val(Field(io_vector, 0)) == IO_vectors_bytes) { if (buffer_copies != NULL) { buffer_copies[copy_index] = lwt_unix_malloc(length); memcpy(buffer_copies[copy_index], &Byte(String_val(buffer), offset), length); iovecs[index].iov_base = buffer_copies[copy_index]; ++copy_index; } else if (read_buffers != NULL) { read_buffers[copy_index].temporary_buffer = lwt_unix_malloc(length); read_buffers[copy_index].length = length; read_buffers[copy_index].offset = offset; read_buffers[copy_index].caml_buffer = buffer; caml_register_generational_global_root( &read_buffers[copy_index].caml_buffer); iovecs[index].iov_base = read_buffers[copy_index].temporary_buffer; ++copy_index; } else iovecs[index].iov_base = &Byte(String_val(buffer), offset); } else iovecs[index].iov_base = &((char *)Caml_ba_data_val(buffer))[offset]; } if (buffer_copies != NULL) buffer_copies[copy_index] = NULL; if (read_buffers != NULL) read_buffers[copy_index].temporary_buffer = NULL; CAMLreturn0; } #endif lwt-5.9.1/src/unix/unix_c/unix_readv_writev_utils.h000066400000000000000000000045221476253734400225520ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #pragma once #include "lwt_config.h" /* * header included in: * unix_writev * unix_writec_job * unix_readv * unix_readv_job */ #if !defined(LWT_ON_WINDOWS) #include #include #include /* For blocking readv calls, arrays of this struct associate temporary buffers which are passed to the readv system call with the OCaml bytes buffers into which the data must ultimately be copied. */ struct readv_copy_to { /* Length of the temporary buffer. */ size_t length; /* Offset into the OCaml buffer to which the temporary buffer must be copied. */ size_t offset; value caml_buffer; char *temporary_buffer; }; /* Tags for each of the constructors of type Lwt_unix.IO_vectors._buffer. The order must correspond to that in lwt_unix.ml. */ enum { IO_vectors_bytes, IO_vectors_bigarray }; /* Given an uninitialized array of iovec structures `iovecs`, and an OCaml value `io_vectors` of type Lwt_unix.IO_vectors._io_vector list, writes pointers to the first `count` buffer slices in `io_vectors` to `iovecs`. Each buffer slice may be a bytes buffer or a Bigarray buffer. In case `buffer_copies` is not NULL, a fresh buffer is allocated on the heap for each bytes buffer, and the contents of the bytes buffer are copied there. Pointers to these copies are written to `iovecs`, instead of pointers to the original buffers. The pointers are also stored as an array at `buffer_copies`, so that they can be freed later. This mechanism is used when `iovecs` will be passed to a blocking writev call, which is run by Lwt in a worker thread. In that case, the original, uncopied bytes buffers may be moved by the garbage collector before the I/O call runs, or while it is running. Similarly, in case `read_buffers` is not NULL, `flatten_io_vectors` allocates a temporary buffer for each OCaml bytes buffer. Pointers to the buffers are stored in `read_buffers`, together with GC roots for the corresponding OCaml buffers. */ void flatten_io_vectors(struct iovec *iovecs, value io_vectors, size_t count, char **buffer_copies, struct readv_copy_to *read_buffers); #endif lwt-5.9.1/src/unix/unix_c/unix_recv.c000066400000000000000000000013141476253734400175570ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" value lwt_unix_recv(value fd, value buf, value ofs, value len, value flags) { int ret; ret = recv(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), lwt_convert_flag_list(flags, msg_flag_table)); if (ret == -1) uerror("recv", Nothing); return Val_int(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_recv_msg.c000066400000000000000000000011531476253734400204260ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include "unix_recv_send_utils.h" #include "unix_readv_writev_utils.h" CAMLprim value lwt_unix_recv_msg(value val_fd, value val_n_iovs, value val_iovs) { int n_iovs = Int_val(val_n_iovs); struct iovec iovs[n_iovs]; flatten_io_vectors(iovs, val_iovs, n_iovs, NULL, NULL); return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs); } #endif lwt-5.9.1/src/unix/unix_c/unix_recv_send_utils.c000066400000000000000000000060701476253734400220140ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include #include #include "unix_recv_send_utils.h" const int msg_flag_table[3] = {MSG_OOB, MSG_DONTROUTE, MSG_PEEK}; value wrapper_recv_msg(int fd, int n_iovs, struct iovec *iovs) { CAMLparam0(); CAMLlocal3(list, result, x); struct msghdr msg; memset(&msg, 0, sizeof(msg)); msg.msg_iov = iovs; msg.msg_iovlen = n_iovs; #if defined(HAVE_FD_PASSING) msg.msg_controllen = CMSG_SPACE(256 * sizeof(int)); msg.msg_control = alloca(msg.msg_controllen); memset(msg.msg_control, 0, msg.msg_controllen); #endif int ret = recvmsg(fd, &msg, 0); if (ret == -1) uerror("recv_msg", Nothing); list = Val_int(0); #if defined(HAVE_FD_PASSING) struct cmsghdr *cm; for (cm = CMSG_FIRSTHDR(&msg); cm; cm = CMSG_NXTHDR(&msg, cm)) if (cm->cmsg_level == SOL_SOCKET && cm->cmsg_type == SCM_RIGHTS) { int *fds = (int *)CMSG_DATA(cm); int nfds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int); int i; for (i = nfds - 1; i >= 0; i--) { x = caml_alloc_tuple(2); Store_field(x, 0, Val_int(fds[i])); Store_field(x, 1, list); list = x; }; break; }; #endif result = caml_alloc_tuple(2); Store_field(result, 0, Val_int(ret)); Store_field(result, 1, list); CAMLreturn(result); } value wrapper_send_msg(int fd, int n_iovs, struct iovec *iovs, value val_n_fds, value val_fds, value dest) { CAMLparam3(val_n_fds, val_fds, dest); struct msghdr msg; memset(&msg, 0, sizeof(msg)); msg.msg_iov = iovs; msg.msg_iovlen = n_iovs; if (Is_some(dest)) { union sock_addr_union addr; socklen_t addr_len; get_sockaddr(Some_val(dest), &addr, &addr_len); msg.msg_name = &addr.s_gen; msg.msg_namelen = addr_len; } int n_fds = Int_val(val_n_fds); #if defined(HAVE_FD_PASSING) if (n_fds > 0) { msg.msg_controllen = CMSG_SPACE(n_fds * sizeof(int)); msg.msg_control = alloca(msg.msg_controllen); memset(msg.msg_control, 0, msg.msg_controllen); struct cmsghdr *cm; cm = CMSG_FIRSTHDR(&msg); cm->cmsg_level = SOL_SOCKET; cm->cmsg_type = SCM_RIGHTS; cm->cmsg_len = CMSG_LEN(n_fds * sizeof(int)); int *fds = (int *)CMSG_DATA(cm); for (/*nothing*/; val_fds != Val_emptylist; val_fds = Field(val_fds, 1), fds++) *fds = Int_val(Field(val_fds, 0)); }; #else if (n_fds > 0) lwt_unix_not_available("fd_passing"); #endif int ret = sendmsg(fd, &msg, 0); if (ret == -1) uerror("send_msg", Nothing); CAMLreturn(Val_int(ret)); } #endif lwt-5.9.1/src/unix/unix_c/unix_recv_send_utils.h000066400000000000000000000025071476253734400220220ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #pragma once #include "lwt_config.h" /* * header included in: * unix_send * unix_bytes_send * unix_recv * unix_bytes_recv * unix_recvfrom * unix_bytes_recvfrom * unix_sendto * unix_bytes_sendto * unix_recv_msg * unix_bytes_recv_msg * unix_send_msg * unix_getaddrinfo_job */ #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #if OCAML_VERSION_MAJOR < 5 #define caml_unix_socket_domain_table socket_domain_table #define caml_unix_socket_type_table socket_type_table #endif #if OCAML_VERSION < 50300 extern int caml_unix_socket_domain_table[]; extern int caml_unix_socket_type_table[]; #else extern const int caml_unix_socket_domain_table[]; extern const int caml_unix_socket_type_table[]; #endif extern const int msg_flag_table[]; extern void get_sockaddr(value mladdr, union sock_addr_union *addr /*out*/, socklen_t *addr_len /*out*/); value wrapper_recv_msg(int fd, int n_iovs, struct iovec *iovs); value wrapper_send_msg(int fd, int n_iovs, struct iovec *iovs, value val_n_fds, value val_fds, value dest); #endif lwt-5.9.1/src/unix/unix_c/unix_recvfrom.c000066400000000000000000000021661476253734400204510ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" value lwt_unix_recvfrom(value fd, value buf, value ofs, value len, value flags) { CAMLparam5(fd, buf, ofs, len, flags); CAMLlocal2(result, address); int ret; union sock_addr_union addr; socklen_t addr_len; addr_len = sizeof(addr); ret = recvfrom(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), lwt_convert_flag_list(flags, msg_flag_table), &addr.s_gen, &addr_len); if (ret == -1) uerror("recvfrom", Nothing); address = alloc_sockaddr(&addr, addr_len, -1); result = caml_alloc_tuple(2); Field(result, 0) = Val_int(ret); Field(result, 1) = address; CAMLreturn(result); } #endif lwt-5.9.1/src/unix/unix_c/unix_rename_job.c000066400000000000000000000071561476253734400207330ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [rename]: int rename(char* oldpath, char* newpath) - these are the expected ocaml externals for this job: external rename_job : string -> string -> unit Lwt_unix.job = "lwt_unix_rename_job" external rename_sync : string -> string -> unit = "lwt_unix_rename_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [rename]. */ struct job_rename { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* oldpath; /* in parameter. */ char* newpath; /* Buffer for string parameters. */ char data[]; }; /* The function calling [rename]. */ static void worker_rename(struct job_rename* job) { /* Perform the blocking call. */ job->result = rename(job->oldpath, job->newpath); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_rename(struct job_rename* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->oldpath into a caml string. */ value string_argument = caml_copy_string(job->oldpath); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "rename", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_rename_job(value oldpath, value newpath) { /* Get the length of the oldpath parameter. */ mlsize_t len_oldpath = caml_string_length(oldpath) + 1; /* Get the length of the newpath parameter. */ mlsize_t len_newpath = caml_string_length(newpath) + 1; /* Allocate a new job. */ struct job_rename* job = lwt_unix_new_plus(struct job_rename, len_oldpath + len_newpath); /* Set the offset of the oldpath parameter inside the job structure. */ job->oldpath = job->data; /* Set the offset of the newpath parameter inside the job structure. */ job->newpath = job->data + len_oldpath; /* Copy the oldpath parameter inside the job structure. */ memcpy(job->oldpath, String_val(oldpath), len_oldpath); /* Copy the newpath parameter inside the job structure. */ memcpy(job->newpath, String_val(newpath), len_newpath); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_rename; job->job.result = (lwt_unix_job_result)result_rename; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_rename_job(value Unit) { lwt_unix_not_available("rename"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_rewinddir_job.c000066400000000000000000000014521476253734400214440ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" struct job_rewinddir { struct lwt_unix_job job; DIR *dir; }; static void worker_rewinddir(struct job_rewinddir *job) { rewinddir(job->dir); } static value result_rewinddir(struct job_rewinddir *job) { lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_rewinddir_job(value dir) { LWT_UNIX_INIT_JOB(job, rewinddir, 0); job->dir = DIR_Val(dir); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_rmdir_job.c000066400000000000000000000061361476253734400205760ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [rmdir]: int rmdir(char* path) - these are the expected ocaml externals for this job: external rmdir_job : string -> unit Lwt_unix.job = "lwt_unix_rmdir_job" external rmdir_sync : string -> unit = "lwt_unix_rmdir_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [rmdir]. */ struct job_rmdir { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* Buffer for string parameters. */ char data[]; }; /* The function calling [rmdir]. */ static void worker_rmdir(struct job_rmdir* job) { /* Perform the blocking call. */ job->result = rmdir(job->path); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_rmdir(struct job_rmdir* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "rmdir", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_rmdir_job(value path) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_rmdir* job = lwt_unix_new_plus(struct job_rmdir, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_rmdir; job->job.result = (lwt_unix_job_result)result_rmdir; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_rmdir_job(value Unit) { lwt_unix_not_available("rmdir"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_send.c000066400000000000000000000013141476253734400175510ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" value lwt_unix_send(value fd, value buf, value ofs, value len, value flags) { int ret; ret = send(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), lwt_convert_flag_list(flags, msg_flag_table)); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_send_msg.c000066400000000000000000000013321476253734400204170ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include "unix_recv_send_utils.h" #include "unix_readv_writev_utils.h" CAMLprim value lwt_unix_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds, value val_dest) { int n_iovs = Int_val(val_n_iovs); struct iovec iovs[n_iovs]; flatten_io_vectors(iovs, val_iovs, n_iovs, NULL, NULL); return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds, val_dest); } #endif lwt-5.9.1/src/unix/unix_c/unix_send_msg_byte.c000066400000000000000000000013401476253734400214410ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include extern value lwt_unix_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds, value val_dest); CAMLprim value lwt_unix_send_msg_byte(value * argv, int argc) { value val_fd = argv[0]; value val_n_iovs = argv[1]; value val_iovs = argv[2]; value val_n_fds = argv[3]; value val_fds = argv[4]; value val_dest = argv[5]; return lwt_unix_send_msg(val_fd, val_n_iovs, val_iovs, val_n_fds, val_fds, val_dest); } #endif lwt-5.9.1/src/unix/unix_c/unix_sendto.c000066400000000000000000000016331476253734400201200ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include #include "lwt_unix.h" #include "unix_recv_send_utils.h" value lwt_unix_sendto(value fd, value buf, value ofs, value len, value flags, value dest) { union sock_addr_union addr; socklen_t addr_len; int ret; get_sockaddr(dest, &addr, &addr_len); ret = sendto(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), lwt_convert_flag_list(flags, msg_flag_table), &addr.s_gen, addr_len); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_sendto_byte.c000066400000000000000000000010501476253734400211340ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include extern value lwt_unix_sendto(value fd, value buf, value ofs, value len, value flags, value dest); CAMLprim value lwt_unix_sendto_byte(value *argv, int argc) { return lwt_unix_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } #endif lwt-5.9.1/src/unix/unix_c/unix_set_affinity.c000066400000000000000000000015401476253734400213050ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #define _GNU_SOURCE #include #include #include #include #include #include "lwt_unix.h" #if defined(HAVE_AFFINITY) CAMLprim value lwt_unix_set_affinity(value val_pid, value val_cpus) { cpu_set_t cpus; CPU_ZERO(&cpus); for (/*nothing*/; val_cpus != Val_emptylist; val_cpus = Field(val_cpus, 1)) CPU_SET(Int_val(Field(val_cpus, 0)), &cpus); if (sched_setaffinity(Int_val(val_pid), sizeof(cpu_set_t), &cpus) < 0) uerror("sched_setaffinity", Nothing); return Val_unit; } #else LWT_NOT_AVAILABLE2(unix_set_affinity) #endif #endif lwt-5.9.1/src/unix/unix_c/unix_somaxconn.c000066400000000000000000000005461476253734400206330ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include CAMLprim value lwt_unix_somaxconn(value unit) { return Val_int(SOMAXCONN); } #endif lwt-5.9.1/src/unix/unix_c/unix_stat_64_job.c000066400000000000000000000010371476253734400207400ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include "lwt_unix.h" #include "unix_stat_job_utils.h" CAMLprim value lwt_unix_stat_64_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, stat, 0, name); job->job.result = (lwt_unix_job_result)result_stat_64; return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_stat_job.c000066400000000000000000000007411476253734400204300ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include "lwt_unix.h" #include "unix_stat_job_utils.h" CAMLprim value lwt_unix_stat_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, stat, 0, name); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_stat_job_utils.c000066400000000000000000000070611476253734400216520ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include "unix_stat_job_utils.h" value copy_stat(int use_64, struct stat *buf) { CAMLparam0(); CAMLlocal5(atime, mtime, ctime, offset, v); atime = caml_copy_double((double)buf->st_atime + (NANOSEC(buf, a) / 1000000000.0)); mtime = caml_copy_double((double)buf->st_mtime + (NANOSEC(buf, m) / 1000000000.0)); ctime = caml_copy_double((double)buf->st_ctime + (NANOSEC(buf, c) / 1000000000.0)); offset = use_64 ? caml_copy_int64(buf->st_size) : Val_int(buf->st_size); v = caml_alloc_small(12, 0); Field(v, 0) = Val_int(buf->st_dev); Field(v, 1) = Val_int(buf->st_ino); switch (buf->st_mode & S_IFMT) { case S_IFREG: Field(v, 2) = Val_int(0); break; case S_IFDIR: Field(v, 2) = Val_int(1); break; case S_IFCHR: Field(v, 2) = Val_int(2); break; case S_IFBLK: Field(v, 2) = Val_int(3); break; case S_IFLNK: Field(v, 2) = Val_int(4); break; case S_IFIFO: Field(v, 2) = Val_int(5); break; case S_IFSOCK: Field(v, 2) = Val_int(6); break; default: Field(v, 2) = Val_int(0); break; } Field(v, 3) = Val_int(buf->st_mode & 07777); Field(v, 4) = Val_int(buf->st_nlink); Field(v, 5) = Val_int(buf->st_uid); Field(v, 6) = Val_int(buf->st_gid); Field(v, 7) = Val_int(buf->st_rdev); Field(v, 8) = offset; Field(v, 9) = atime; Field(v, 10) = mtime; Field(v, 11) = ctime; CAMLreturn(v); } void worker_stat(struct job_stat *job) { job->result = stat(job->name, &job->stat); job->error_code = errno; } value result_stat(struct job_stat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "stat", job->name); value result = copy_stat(0, &job->stat); lwt_unix_free_job(&job->job); return result; } value result_stat_64(struct job_stat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "stat", job->name); value result = copy_stat(1, &job->stat); lwt_unix_free_job(&job->job); return result; } void worker_lstat(struct job_lstat *job) { job->result = lstat(job->name, &job->lstat); job->error_code = errno; } value result_lstat(struct job_lstat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "lstat", job->name); value result = copy_stat(0, &(job->lstat)); lwt_unix_free_job(&job->job); return result; } value result_lstat_64(struct job_lstat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "lstat", job->name); value result = copy_stat(1, &(job->lstat)); lwt_unix_free_job(&job->job); return result; } void worker_fstat(struct job_fstat *job) { job->result = fstat(job->fd, &(job->fstat)); job->error_code = errno; } value result_fstat(struct job_fstat *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "fstat"); value result = copy_stat(0, &(job->fstat)); lwt_unix_free_job(&job->job); return result; } value result_fstat_64(struct job_fstat *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "fstat"); value result = copy_stat(1, &(job->fstat)); lwt_unix_free_job(&job->job); return result; } #endif lwt-5.9.1/src/unix/unix_c/unix_stat_job_utils.h000066400000000000000000000025541476253734400216610ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #pragma once /* Included in: * - unix_stat_job.c * - unix_stat64_job.c * - unix_lstat_job.c * - unix_lstat_64_job.c * - unix_fstat_job.c * - unix_fstat_64_job.c */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" struct job_stat { struct lwt_unix_job job; struct stat stat; int result; int error_code; char *name; char data[]; }; struct job_lstat { struct lwt_unix_job job; struct stat lstat; int result; int error_code; char *name; char data[]; }; struct job_fstat { struct lwt_unix_job job; int fd; struct stat fstat; int result; int error_code; }; value copy_stat(int use_64, struct stat *buf); void worker_stat(struct job_stat *job); value result_stat(struct job_stat *job); value result_stat_64(struct job_stat *job); void worker_lstat(struct job_lstat *job); value result_lstat(struct job_lstat *job); value result_lstat_64(struct job_lstat *job); void worker_fstat(struct job_fstat *job); value result_fstat(struct job_fstat *job); value result_fstat_64(struct job_fstat *job); #endif lwt-5.9.1/src/unix/unix_c/unix_symlink_job.c000066400000000000000000000072051476253734400211450ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [symlink]: int symlink(char* oldpath, char* newpath) - these are the expected ocaml externals for this job: external symlink_job : string -> string -> unit Lwt_unix.job = "lwt_unix_symlink_job" external symlink_sync : string -> string -> unit = "lwt_unix_symlink_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [symlink]. */ struct job_symlink { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* oldpath; /* in parameter. */ char* newpath; /* Buffer for string parameters. */ char data[]; }; /* The function calling [symlink]. */ static void worker_symlink(struct job_symlink* job) { /* Perform the blocking call. */ job->result = symlink(job->oldpath, job->newpath); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_symlink(struct job_symlink* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->oldpath into a caml string. */ value string_argument = caml_copy_string(job->oldpath); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "symlink", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_symlink_job(value oldpath, value newpath) { /* Get the length of the oldpath parameter. */ mlsize_t len_oldpath = caml_string_length(oldpath) + 1; /* Get the length of the newpath parameter. */ mlsize_t len_newpath = caml_string_length(newpath) + 1; /* Allocate a new job. */ struct job_symlink* job = lwt_unix_new_plus(struct job_symlink, len_oldpath + len_newpath); /* Set the offset of the oldpath parameter inside the job structure. */ job->oldpath = job->data; /* Set the offset of the newpath parameter inside the job structure. */ job->newpath = job->data + len_oldpath; /* Copy the oldpath parameter inside the job structure. */ memcpy(job->oldpath, String_val(oldpath), len_oldpath); /* Copy the newpath parameter inside the job structure. */ memcpy(job->newpath, String_val(newpath), len_newpath); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_symlink; job->job.result = (lwt_unix_job_result)result_symlink; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_symlink_job(value Unit) { lwt_unix_not_available("symlink"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_tcdrain_job.c000066400000000000000000000054711476253734400211060ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [tcdrain]: int tcdrain(int fd) - these are the expected ocaml externals for this job: external tcdrain_job : Unix.file_descr -> unit Lwt_unix.job = "lwt_unix_tcdrain_job" external tcdrain_sync : Unix.file_descr -> unit = "lwt_unix_tcdrain_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) && !defined(__ANDROID__) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [tcdrain]. */ struct job_tcdrain { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; }; /* The function calling [tcdrain]. */ static void worker_tcdrain(struct job_tcdrain* job) { /* Perform the blocking call. */ job->result = tcdrain(job->fd); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_tcdrain(struct job_tcdrain* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "tcdrain", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_tcdrain_job(value fd) { /* Allocate a new job. */ struct job_tcdrain* job = lwt_unix_new(struct job_tcdrain); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_tcdrain; job->job.result = (lwt_unix_job_result)result_tcdrain; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) && !defined(__ANDROID__) */ CAMLprim value lwt_unix_tcdrain_job(value Unit) { lwt_unix_not_available("tcdrain"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) && !defined(__ANDROID__) */ lwt-5.9.1/src/unix/unix_c/unix_tcflow_job.c000066400000000000000000000066101476253734400207540ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [tcflow]: int tcflow(int fd, int action) - these are the expected ocaml externals for this job: external tcflow_job : Unix.file_descr -> Unix.flow_action -> unit Lwt_unix.job = "lwt_unix_tcflow_job" external tcflow_sync : Unix.file_descr -> Unix.flow_action -> unit = "lwt_unix_tcflow_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Converters | +-----------------------------------------------------------------+ */ /* Table mapping constructors of ocaml type Unix.flow_action to C values. */ static const int flow_action_table[] = { /* Constructor TCOOFF. */ TCOOFF, /* Constructor TCOON. */ TCOON, /* Constructor TCIOFF. */ TCIOFF, /* Constructor TCION. */ TCION }; /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [tcflow]. */ struct job_tcflow { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; /* in parameter. */ int action; }; /* The function calling [tcflow]. */ static void worker_tcflow(struct job_tcflow* job) { /* Perform the blocking call. */ job->result = tcflow(job->fd, job->action); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_tcflow(struct job_tcflow* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "tcflow", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_tcflow_job(value fd, value action) { /* Allocate a new job. */ struct job_tcflow* job = lwt_unix_new(struct job_tcflow); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_tcflow; job->job.result = (lwt_unix_job_result)result_tcflow; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the action parameter. */ job->action = flow_action_table[Int_val(action)]; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_tcflow_job(value Unit) { lwt_unix_not_available("tcflow"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_tcflush_job.c000066400000000000000000000066031476253734400211300ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [tcflush]: int tcflush(int fd, int queue) - these are the expected ocaml externals for this job: external tcflush_job : Unix.file_descr -> Unix.flush_queue -> unit Lwt_unix.job = "lwt_unix_tcflush_job" external tcflush_sync : Unix.file_descr -> Unix.flush_queue -> unit = "lwt_unix_tcflush_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Converters | +-----------------------------------------------------------------+ */ /* Table mapping constructors of ocaml type Unix.flush_queue to C values. */ static const int flush_queue_table[] = { /* Constructor TCIFLUSH. */ TCIFLUSH, /* Constructor TCOFLUSH. */ TCOFLUSH, /* Constructor TCIOFLUSH. */ TCIOFLUSH }; /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [tcflush]. */ struct job_tcflush { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; /* in parameter. */ int queue; }; /* The function calling [tcflush]. */ static void worker_tcflush(struct job_tcflush* job) { /* Perform the blocking call. */ job->result = tcflush(job->fd, job->queue); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_tcflush(struct job_tcflush* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "tcflush", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_tcflush_job(value fd, value queue) { /* Allocate a new job. */ struct job_tcflush* job = lwt_unix_new(struct job_tcflush); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_tcflush; job->job.result = (lwt_unix_job_result)result_tcflush; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the queue parameter. */ job->queue = flush_queue_table[Int_val(queue)]; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_tcflush_job(value Unit) { lwt_unix_not_available("tcflush"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_tcgetattr_job.c000066400000000000000000000021341476253734400214540ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" #include "unix_termios_conversion.h" struct job_tcgetattr { struct lwt_unix_job job; int fd; struct termios termios; int result; int error_code; }; static void worker_tcgetattr(struct job_tcgetattr *job) { job->result = tcgetattr(job->fd, &job->termios); job->error_code = errno; } static value result_tcgetattr(struct job_tcgetattr *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "tcgetattr"); value res = caml_alloc_tuple(NFIELDS); encode_terminal_status(&job->termios, &Field(res, 0)); lwt_unix_free_job(&job->job); return res; } CAMLprim value lwt_unix_tcgetattr_job(value fd) { LWT_UNIX_INIT_JOB(job, tcgetattr, 0); job->fd = Int_val(fd); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_tcsendbreak_job.c000066400000000000000000000057611476253734400217510ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [tcsendbreak]: int tcsendbreak(int fd, int duration) - these are the expected ocaml externals for this job: external tcsendbreak_job : Unix.file_descr -> int -> unit Lwt_unix.job = "lwt_unix_tcsendbreak_job" external tcsendbreak_sync : Unix.file_descr -> int -> unit = "lwt_unix_tcsendbreak_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [tcsendbreak]. */ struct job_tcsendbreak { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ int fd; /* in parameter. */ int duration; }; /* The function calling [tcsendbreak]. */ static void worker_tcsendbreak(struct job_tcsendbreak* job) { /* Perform the blocking call. */ job->result = tcsendbreak(job->fd, job->duration); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_tcsendbreak(struct job_tcsendbreak* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "tcsendbreak", Nothing); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_tcsendbreak_job(value fd, value duration) { /* Allocate a new job. */ struct job_tcsendbreak* job = lwt_unix_new(struct job_tcsendbreak); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_tcsendbreak; job->job.result = (lwt_unix_job_result)result_tcsendbreak; /* Copy the fd parameter. */ job->fd = Int_val(fd); /* Copy the duration parameter. */ job->duration = Int_val(duration); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_tcsendbreak_job(value Unit) { lwt_unix_not_available("tcsendbreak"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_tcsetattr_job.c000066400000000000000000000031531476253734400214720ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include "lwt_unix.h" #include "unix_termios_conversion.h" struct job_tcsetattr { struct lwt_unix_job job; int fd; int when; /* This array contains only non-allocated values. */ value termios[NFIELDS]; int result; int error_code; }; static const int when_flag_table[] = {TCSANOW, TCSADRAIN, TCSAFLUSH}; static void worker_tcsetattr(struct job_tcsetattr *job) { struct termios termios; int result = tcgetattr(job->fd, &termios); if (result < 0) { job->result = result; job->error_code = errno; } else { int result_decode = decode_terminal_status(&termios, &(job->termios[0])); if (result_decode != 0) { job->result = -1; } else { job->result = tcsetattr(job->fd, job->when, &termios); } job->error_code = errno; } } static value result_tcsetattr(struct job_tcsetattr *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "tcsetattr"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_tcsetattr_job(value fd, value when, value termios) { LWT_UNIX_INIT_JOB(job, tcsetattr, 0); job->fd = Int_val(fd); job->when = when_flag_table[Int_val(when)]; memcpy(&job->termios, (value *)&Field(termios, 0), NFIELDS * sizeof(value)); return lwt_unix_alloc_job(&job->job); } #endif lwt-5.9.1/src/unix/unix_c/unix_termios_conversion.c000066400000000000000000000173161476253734400225600ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include "unix_termios_conversion.h" /* TODO: make it reentrant. */ enum { Bool, Enum, Speed, Char, End }; enum { Input, Output }; enum { Iflags, Oflags, Cflags, Lflags }; /* Structure of the terminal_io record. Cf. unix.mli */ static const long terminal_io_descr[] = { /* Input modes */ Bool, Iflags, IGNBRK, Bool, Iflags, BRKINT, Bool, Iflags, IGNPAR, Bool, Iflags, PARMRK, Bool, Iflags, INPCK, Bool, Iflags, ISTRIP, Bool, Iflags, INLCR, Bool, Iflags, IGNCR, Bool, Iflags, ICRNL, Bool, Iflags, IXON, Bool, Iflags, IXOFF, /* Output modes */ Bool, Oflags, OPOST, /* Control modes */ Speed, Output, Speed, Input, Enum, Cflags, 5, 4, CSIZE, CS5, CS6, CS7, CS8, Enum, Cflags, 1, 2, CSTOPB, 0, CSTOPB, Bool, Cflags, CREAD, Bool, Cflags, PARENB, Bool, Cflags, PARODD, Bool, Cflags, HUPCL, Bool, Cflags, CLOCAL, /* Local modes */ Bool, Lflags, ISIG, Bool, Lflags, ICANON, Bool, Lflags, NOFLSH, Bool, Lflags, ECHO, Bool, Lflags, ECHOE, Bool, Lflags, ECHOK, Bool, Lflags, ECHONL, /* Control characters */ Char, VINTR, Char, VQUIT, Char, VERASE, Char, VKILL, Char, VEOF, Char, VEOL, Char, VMIN, Char, VTIME, Char, VSTART, Char, VSTOP, End}; static const struct { speed_t speed; int baud; } speedtable[] = {{B50, 50}, {B75, 75}, {B110, 110}, {B134, 134}, {B150, 150}, #ifdef B200 {B200, 200}, #endif {B300, 300}, {B600, 600}, {B1200, 1200}, {B1800, 1800}, {B2400, 2400}, {B4800, 4800}, {B9600, 9600}, {B19200, 19200}, {B38400, 38400}, #ifdef B57600 {B57600, 57600}, #endif #ifdef B115200 {B115200, 115200}, #endif #ifdef B230400 {B230400, 230400}, #endif {B0, 0}, /* Linux extensions */ #ifdef B460800 {B460800, 460800}, #endif #ifdef B500000 {B500000, 500000}, #endif #ifdef B576000 {B576000, 576000}, #endif #ifdef B921600 {B921600, 921600}, #endif #ifdef B1000000 {B1000000, 1000000}, #endif #ifdef B1152000 {B1152000, 1152000}, #endif #ifdef B1500000 {B1500000, 1500000}, #endif #ifdef B2000000 {B2000000, 2000000}, #endif #ifdef B2500000 {B2500000, 2500000}, #endif #ifdef B3000000 {B3000000, 3000000}, #endif #ifdef B3500000 {B3500000, 3500000}, #endif #ifdef B4000000 {B4000000, 4000000}, #endif /* MacOS extensions */ #ifdef B7200 {B7200, 7200}, #endif #ifdef B14400 {B14400, 14400}, #endif #ifdef B28800 {B28800, 28800}, #endif #ifdef B76800 {B76800, 76800}, #endif /* Cygwin extensions (in addition to the Linux ones) */ #ifdef B128000 {B128000, 128000}, #endif #ifdef B256000 {B256000, 256000}, #endif }; #define NSPEEDS (int)(sizeof(speedtable) / sizeof(speedtable[0])) static tcflag_t *choose_field(struct termios *terminal_status, long field) { switch (field) { case Iflags: return &terminal_status->c_iflag; case Oflags: return &terminal_status->c_oflag; case Cflags: return &terminal_status->c_cflag; case Lflags: return &terminal_status->c_lflag; default: return 0; } } void encode_terminal_status(struct termios *terminal_status, volatile value *dst) { for (const long *pc = terminal_io_descr; *pc != End; dst++) { switch (*pc++) { case Bool: { tcflag_t *src = choose_field(terminal_status, *pc++); tcflag_t msk = *pc++; *dst = Val_bool(*src & msk); break; } case Enum: { tcflag_t *src = choose_field(terminal_status, *pc++); int ofs = *pc++; int num = *pc++; tcflag_t msk = *pc++; for (int i = 0; i < num; i++) { if ((*src & msk) == pc[i]) { *dst = Val_int(i + ofs); break; } } pc += num; break; } case Speed: { int which = *pc++; speed_t speed = 0; *dst = Val_int(9600); /* in case no speed in speedtable matches */ switch (which) { case Output: speed = cfgetospeed(terminal_status); break; case Input: speed = cfgetispeed(terminal_status); break; } for (int i = 0; i < NSPEEDS; i++) { if (speed == speedtable[i].speed) { *dst = Val_int(speedtable[i].baud); break; } } break; } case Char: { int which = *pc++; *dst = Val_int(terminal_status->c_cc[which]); break; } } } } int decode_terminal_status(struct termios *terminal_status, volatile value *src) { for (const long *pc = terminal_io_descr; *pc != End; src++) { switch (*pc++) { case Bool: { tcflag_t *dst = choose_field(terminal_status, *pc++); tcflag_t msk = *pc++; if (Bool_val(*src)) *dst |= msk; else *dst &= ~msk; break; } case Enum: { tcflag_t *dst = choose_field(terminal_status, *pc++); int ofs = *pc++; int num = *pc++; tcflag_t msk = *pc++; int i = Int_val(*src) - ofs; if (i >= 0 && i < num) { *dst = (*dst & ~msk) | pc[i]; } else { errno = EINVAL; return EINVAL; } pc += num; break; } case Speed: { int which = *pc++; int baud = Int_val(*src); int res = 0; for (int i = 0; i < NSPEEDS; i++) { if (baud == speedtable[i].baud) { switch (which) { case Output: res = cfsetospeed(terminal_status, speedtable[i].speed); break; case Input: res = cfsetispeed(terminal_status, speedtable[i].speed); break; } if (res == -1) return res; goto ok; } } errno = EINVAL; return EINVAL; ok: break; } case Char: { int which = *pc++; terminal_status->c_cc[which] = Int_val(*src); break; } } } return 0; } #endif lwt-5.9.1/src/unix/unix_c/unix_termios_conversion.h000066400000000000000000000012351476253734400225560ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #pragma once #include "lwt_config.h" /* Header included in: * - unix_tcsetattr_job.c */ #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" /* Number of fields in the terminal_io record field. Cf. unix.mli */ #define NFIELDS 38 void encode_terminal_status(struct termios *terminal_status, volatile value *dst); int decode_terminal_status(struct termios *terminal_status, volatile value *src); #endif lwt-5.9.1/src/unix/unix_c/unix_truncate_job.c000066400000000000000000000104121476253734400212760ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [truncate]: int truncate(char* path, off_t offset) - these are the expected ocaml externals for this job: external truncate_job : string -> int -> unit Lwt_unix.job = "lwt_unix_truncate_job" external truncate_sync : string -> int -> unit = "lwt_unix_truncate_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [truncate]. */ struct job_truncate { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* in parameter. */ off_t offset; /* Buffer for string parameters. */ char data[]; }; /* The function calling [truncate]. */ static void worker_truncate(struct job_truncate* job) { /* Perform the blocking call. */ job->result = truncate(job->path, job->offset); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_truncate(struct job_truncate* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "truncate", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_truncate_job(value path, value offset) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_truncate* job = lwt_unix_new_plus(struct job_truncate, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_truncate; job->job.result = (lwt_unix_job_result)result_truncate; /* Copy the offset parameter. */ job->offset = Long_val(offset); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } /* The stub creating the job structure. */ CAMLprim value lwt_unix_truncate_64_job(value path, value offset) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_truncate* job = lwt_unix_new_plus(struct job_truncate, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_truncate; job->job.result = (lwt_unix_job_result)result_truncate; /* Copy the offset parameter. */ job->offset = Int64_val(offset); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_truncate_job(value Unit) { lwt_unix_not_available("truncate"); return Val_unit; } CAMLprim value lwt_unix_truncate_64_job(value Unit) { lwt_unix_not_available("truncate"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_unlink_job.c000066400000000000000000000061641476253734400207620ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ /* Informations: - this is the expected prototype of the C function [unlink]: int unlink(char* path) - these are the expected ocaml externals for this job: external unlink_job : string -> unit Lwt_unix.job = "lwt_unix_unlink_job" external unlink_sync : string -> unit = "lwt_unix_unlink_sync" */ /* Caml headers. */ #include "lwt_config.h" #include #include #include #include #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) /* Specific headers. */ #include #include #include /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ /* Structure holding informations for calling [unlink]. */ struct job_unlink { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* in parameter. */ char* path; /* Buffer for string parameters. */ char data[]; }; /* The function calling [unlink]. */ static void worker_unlink(struct job_unlink* job) { /* Perform the blocking call. */ job->result = unlink(job->path); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_unlink(struct job_unlink* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "unlink", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_unlink_job(value path) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_unlink* job = lwt_unix_new_plus(struct job_unlink, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initializes function fields. */ job->job.worker = (lwt_unix_job_worker)worker_unlink; job->job.result = (lwt_unix_job_result)result_unlink; /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } #else /* !defined(LWT_ON_WINDOWS) */ CAMLprim value lwt_unix_unlink_job(value Unit) { lwt_unix_not_available("unlink"); return Val_unit; } #endif /* !defined(LWT_ON_WINDOWS) */ lwt-5.9.1/src/unix/unix_c/unix_utimes_job.c000066400000000000000000000027471476253734400207730ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" struct job_utimes { struct lwt_unix_job job; char *path; const struct timeval *times_pointer; struct timeval times[2]; int result; int error_code; char data[]; }; static void worker_utimes(struct job_utimes *job) { job->result = utimes(job->path, job->times_pointer); job->error_code = errno; } static value result_utimes(struct job_utimes *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result != 0, "utimes", job->path); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_utimes_job(value path, value val_atime, value val_mtime) { LWT_UNIX_INIT_JOB_STRING(job, utimes, 0, path); double atime = Double_val(val_atime); double mtime = Double_val(val_mtime); if (atime == 0.0 && mtime == 0.0) job->times_pointer = NULL; else { job->times[0].tv_sec = atime; job->times[0].tv_usec = (atime - job->times[0].tv_sec) * 1000000; job->times[1].tv_sec = mtime; job->times[1].tv_usec = (mtime - job->times[1].tv_sec) * 1000000; job->times_pointer = job->times; } return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_valid_dir.c000066400000000000000000000010131476253734400205510ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" CAMLprim value lwt_unix_valid_dir(value dir) { CAMLparam1(dir); int result = DIR_Val(dir) == NULL ? 0 : 1; CAMLreturn(Val_int(result)); } #endif lwt-5.9.1/src/unix/unix_c/unix_wait4.c000066400000000000000000000051731476253734400176570ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" #include #include #include #include /* Some code duplicated from OCaml's otherlibs/unix/wait.c */ CAMLextern int caml_convert_signal_number(int); CAMLextern int caml_rev_convert_signal_number(int); #if !defined(__ANDROID__) #if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \ defined(WSTOPSIG) && defined(WTERMSIG)) /* Assume old-style V7 status word */ #define WIFEXITED(status) (((status)&0xFF) == 0) #define WEXITSTATUS(status) (((status) >> 8) & 0xFF) #define WIFSTOPPED(status) (((status)&0xFF) == 0xFF) #define WSTOPSIG(status) (((status) >> 8) & 0xFF) #define WTERMSIG(status) ((status)&0x3F) #endif #define TAG_WEXITED 0 #define TAG_WSIGNALED 1 #define TAG_WSTOPPED 2 static value alloc_process_status(int status) { value st; if (WIFEXITED(status)) { st = caml_alloc_small(1, TAG_WEXITED); Field(st, 0) = Val_int(WEXITSTATUS(status)); } else if (WIFSTOPPED(status)) { st = caml_alloc_small(1, TAG_WSTOPPED); Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status))); } else { st = caml_alloc_small(1, TAG_WSIGNALED); Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status))); } return st; } static const int wait_flag_table[] = {WNOHANG, WUNTRACED}; value lwt_unix_wait4(value flags, value pid_req) { CAMLparam1(flags); CAMLlocal2(times, res); int pid, status, cv_flags; cv_flags = lwt_convert_flag_list(flags, wait_flag_table); struct rusage ru; caml_enter_blocking_section(); pid = wait4(Int_val(pid_req), &status, cv_flags, &ru); caml_leave_blocking_section(); if (pid == -1) uerror("wait4", Nothing); times = caml_alloc_small(2 * Double_wosize, Double_array_tag); Store_double_field(times, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6); Store_double_field(times, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); res = caml_alloc_tuple(3); Store_field(res, 0, Val_int(pid)); Store_field(res, 1, alloc_process_status(status)); Store_field(res, 2, times); CAMLreturn(res); } #else #include "lwt_unix.h" LWT_NOT_AVAILABLE2(unix_wait4) #endif #endif lwt-5.9.1/src/unix/unix_c/unix_wait_mincore_job.c000066400000000000000000000023521476253734400221350ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include #include "lwt_unix.h" #ifdef __CYGWIN__ LWT_NOT_AVAILABLE2(unix_wait_mincore_job) #else struct job_wait_mincore { struct lwt_unix_job job; value ocaml_buffer; char *ptr; }; static void worker_wait_mincore(struct job_wait_mincore *job) { /* Read the byte to force the kernel to fetch the page: */ char dummy; memcpy(&dummy, job->ptr, 1); } static value result_wait_mincore(struct job_wait_mincore *job) { caml_remove_generational_global_root(&job->ocaml_buffer); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_wait_mincore_job(value val_buffer, value val_offset) { LWT_UNIX_INIT_JOB(job, wait_mincore, 0); job->ptr = (char *)Caml_ba_data_val(val_buffer) + Long_val(val_offset); job->ocaml_buffer = val_buffer; caml_register_generational_global_root(&job->ocaml_buffer); return lwt_unix_alloc_job(&(job->job)); } #endif #endif lwt-5.9.1/src/unix/unix_c/unix_writable.c000066400000000000000000000010661476253734400204350ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_writable(value fd) { struct pollfd pollfd; pollfd.fd = Int_val(fd); pollfd.events = POLLOUT; pollfd.revents = 0; if (poll(&pollfd, 1, 0) < 0) uerror("writable", Nothing); return (Val_bool(pollfd.revents & POLLOUT)); } #endif lwt-5.9.1/src/unix/unix_c/unix_write.c000066400000000000000000000011621476253734400177530ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_write(value val_fd, value val_buf, value val_ofs, value val_len) { long ret; ret = write(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len)); if (ret == -1) uerror("write", Nothing); return Val_long(ret); } #endif lwt-5.9.1/src/unix/unix_c/unix_write_job.c000066400000000000000000000023111476253734400206020ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" struct job_write { struct lwt_unix_job job; int fd; long length; long result; int error_code; char buffer[]; }; static void worker_write(struct job_write *job) { job->result = write(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_write(struct job_write *job) { long result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "write"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) { long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, write, length); job->fd = Int_val(val_fd); job->length = length; memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/unix_c/unix_writev.c000066400000000000000000000016241476253734400201440ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" #include "unix_readv_writev_utils.h" /* writev primitive for non-blocking file descriptors. */ CAMLprim value lwt_unix_writev(value fd, value io_vectors, value val_count) { CAMLparam3(fd, io_vectors, val_count); size_t count = Long_val(val_count); /* Assemble iovec structures on the stack. No data is copied. */ struct iovec iovecs[count]; flatten_io_vectors(iovecs, io_vectors, count, NULL, NULL); ssize_t result = writev(Int_val(fd), iovecs, count); if (result == -1) uerror("writev", Nothing); CAMLreturn(Val_long(result)); } #endif lwt-5.9.1/src/unix/unix_c/unix_writev_job.c000066400000000000000000000046761476253734400210100ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if !defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" #include "unix_readv_writev_utils.h" /* Job and writev primitives for blocking file descriptors. */ struct job_writev { struct lwt_unix_job job; int fd; int error_code; ssize_t result; size_t count; /* Heap-allocated iovec structures. */ struct iovec *iovecs; /* Heap-allocated array of pointers to heap-allocated copies of bytes buffer slices. This array is NULL-terminated. */ char **buffer_copies; /* Reference to OCaml I/O vectors, to be retained for the duration of the writev operation. */ value ocaml_io_vectors; }; static void worker_writev(struct job_writev *job) { job->result = writev(job->fd, job->iovecs, job->count); job->error_code = errno; } static value result_writev(struct job_writev *job) { char **buffer_copy; for (buffer_copy = job->buffer_copies; *buffer_copy != NULL; ++buffer_copy) { free(*buffer_copy); } free(job->buffer_copies); free(job->iovecs); caml_remove_generational_global_root(&job->ocaml_io_vectors); ssize_t result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "writev"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_writev_job(value fd, value io_vectors, value val_count) { CAMLparam3(fd, io_vectors, val_count); LWT_UNIX_INIT_JOB(job, writev, 0); job->fd = Int_val(fd); job->count = Long_val(val_count); /* Assemble iovec structures on the heap and copy bytes buffer slices. */ job->iovecs = lwt_unix_malloc(job->count * sizeof(struct iovec)); /* The extra (+ 1) pointer is for the NULL terminator, in case all buffer slices are in bytes buffers. */ job->buffer_copies = lwt_unix_malloc((job->count + 1) * sizeof(char *)); flatten_io_vectors( job->iovecs, Field(io_vectors, 0), job->count, job->buffer_copies, NULL); /* Retain the OCaml I/O vectors, so that the buffers don't get deallocated by the GC. */ job->ocaml_io_vectors = io_vectors; caml_register_generational_global_root(&job->ocaml_io_vectors); CAMLreturn(lwt_unix_alloc_job(&job->job)); } #endif lwt-5.9.1/src/unix/windows_c/000077500000000000000000000000001476253734400161215ustar00rootroot00000000000000lwt-5.9.1/src/unix/windows_c/windows_bytes_read.c000066400000000000000000000031441476253734400221620ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include CAMLprim value lwt_unix_bytes_read(value fd, value buf, value vofs, value vlen) { intnat ofs, len, written; DWORD numbytes, numwritten; DWORD err = 0; Begin_root(buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; if (len > 0) { numbytes = len; if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); ret = recv(s, (char *)Caml_ba_array_val(buf)->data + ofs, numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); numwritten = ret; } else { HANDLE h = Handle_val(fd); if (!ReadFile(h, (char *)Caml_ba_array_val(buf)->data + ofs, numbytes, &numwritten, NULL)) err = GetLastError(); } if (err == ERROR_BROKEN_PIPE) { /* The write handle for an anonymous pipe has been closed. We match the Unix behavior, and treat this as a zero-read instead of a Unix_error. See OCaml PR #4790. */ numwritten = 0; } else if (err) { win32_maperr(err); uerror("write", Nothing); } written = numwritten; } End_roots(); return Val_long(written); } #endif lwt-5.9.1/src/unix/windows_c/windows_bytes_read_job.c000066400000000000000000000045521476253734400230200ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" struct job_bytes_read { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; char *buffer; DWORD length; DWORD result; DWORD error_code; value ocaml_buffer; }; static void worker_bytes_read(struct job_bytes_read *job) { if (job->kind == KIND_SOCKET) { int ret; ret = recv(job->fd.socket, job->buffer, job->length, 0); if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); job->result = ret; } else { if (!ReadFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) job->error_code = GetLastError(); } } static value result_bytes_read(struct job_bytes_read *job) { value result; DWORD error = job->error_code; caml_remove_generational_global_root(&job->ocaml_buffer); if (error == ERROR_BROKEN_PIPE) { /* The write handle for an anonymous pipe has been closed. We match the Unix behavior, and treat this as a zero-read instead of a Unix_error. See OCaml PR #4790. */ job->result = 0; } else if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("bytes_read", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buffer, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); LWT_UNIX_INIT_JOB(job, bytes_read, 0); job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; job->buffer = (char *)Caml_ba_data_val(val_buffer) + Long_val(val_offset); job->length = Long_val(val_length); job->error_code = 0; job->ocaml_buffer = val_buffer; caml_register_generational_global_root(&job->ocaml_buffer); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/windows_c/windows_bytes_write.c000066400000000000000000000025151476253734400224020ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include CAMLprim value lwt_unix_bytes_write(value fd, value buf, value vofs, value vlen) { intnat ofs, len, written; DWORD numbytes, numwritten; DWORD err = 0; Begin_root(buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; if (len > 0) { numbytes = len; if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); ret = send(s, (char *)Caml_ba_array_val(buf)->data + ofs, numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); numwritten = ret; } else { HANDLE h = Handle_val(fd); if (!WriteFile(h, (char *)Caml_ba_array_val(buf)->data + ofs, numbytes, &numwritten, NULL)) err = GetLastError(); } if (err) { win32_maperr(err); uerror("write", Nothing); } written = numwritten; } End_roots(); return Val_long(written); } #endif lwt-5.9.1/src/unix/windows_c/windows_bytes_write_job.c000066400000000000000000000042551476253734400232370ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" struct job_bytes_write { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; char *buffer; DWORD length; DWORD result; DWORD error_code; value ocaml_buffer; }; static void worker_bytes_write(struct job_bytes_write *job) { if (job->kind == KIND_SOCKET) { int ret; ret = send(job->fd.socket, job->buffer, job->length, 0); if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); job->result = ret; } else { if (!WriteFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) job->error_code = GetLastError(); } } CAMLprim value result_bytes_write(struct job_bytes_write *job) { value result; DWORD error = job->error_code; caml_remove_generational_global_root(&job->ocaml_buffer); if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("bytes_write", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); LWT_UNIX_INIT_JOB(job, bytes_write, 0); job->job.worker = (lwt_unix_job_worker)worker_bytes_write; job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; job->buffer = (char *)Caml_ba_data_val(val_buffer) + Long_val(val_offset); job->length = Long_val(val_length); job->error_code = 0; job->ocaml_buffer = val_buffer; caml_register_generational_global_root(&job->ocaml_buffer); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/windows_c/windows_fsync_job.c000066400000000000000000000022561476253734400220200ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include "lwt_unix.h" struct job_fsync { struct lwt_unix_job job; HANDLE handle; DWORD error_code; }; static void worker_fsync(struct job_fsync *job) { if (!FlushFileBuffers(job->handle)) job->error_code = GetLastError(); } static value result_fsync(struct job_fsync *job) { DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("fsync", Nothing); } lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_fsync_job(value val_fd) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); if (fd->kind != KIND_HANDLE) { caml_invalid_argument("Lwt_unix.fsync"); } else { LWT_UNIX_INIT_JOB(job, fsync, 0); job->handle = fd->fd.handle; job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } } #endif lwt-5.9.1/src/unix/windows_c/windows_get_page_size.c000066400000000000000000000006371476253734400226520ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include CAMLprim value lwt_unix_get_page_size(value Unit) { SYSTEM_INFO si; GetSystemInfo(&si); return Val_long(si.dwPageSize); } #endif lwt-5.9.1/src/unix/windows_c/windows_is_socket.c000066400000000000000000000006341476253734400220250ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_is_socket(value fd) { return (Val_bool(Descr_kind_val(fd) == KIND_SOCKET)); } #endif lwt-5.9.1/src/unix/windows_c/windows_not_available.c000066400000000000000000000053611476253734400226440ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include "lwt_unix.h" LWT_NOT_AVAILABLE1(unix_readable) LWT_NOT_AVAILABLE1(unix_writable) LWT_NOT_AVAILABLE6(unix_madvise) LWT_NOT_AVAILABLE4(unix_mincore) LWT_NOT_AVAILABLE1(unix_iov_max) LWT_NOT_AVAILABLE3(unix_writev) LWT_NOT_AVAILABLE3(unix_writev_job) LWT_NOT_AVAILABLE3(unix_readv) LWT_NOT_AVAILABLE3(unix_readv_job) LWT_NOT_AVAILABLE5(unix_recv) LWT_NOT_AVAILABLE5(unix_send) LWT_NOT_AVAILABLE5(unix_bytes_recv) LWT_NOT_AVAILABLE5(unix_bytes_send) LWT_NOT_AVAILABLE5(unix_recvfrom) LWT_NOT_AVAILABLE5(unix_bytes_recvfrom) LWT_NOT_AVAILABLE6(unix_sendto) LWT_NOT_AVAILABLE_BYTE(unix_sendto_byte) LWT_NOT_AVAILABLE6(unix_bytes_sendto) LWT_NOT_AVAILABLE_BYTE(unix_bytes_sendto_byte) LWT_NOT_AVAILABLE3(unix_recv_msg) LWT_NOT_AVAILABLE6(unix_send_msg) LWT_NOT_AVAILABLE1(unix_get_credentials) LWT_NOT_AVAILABLE2(unix_mcast_set_loop) LWT_NOT_AVAILABLE2(unix_mcast_set_ttl) LWT_NOT_AVAILABLE4(unix_mcast_modify_membership) LWT_NOT_AVAILABLE4(unix_wait4) LWT_NOT_AVAILABLE1(unix_get_cpu) LWT_NOT_AVAILABLE1(unix_get_affinity) LWT_NOT_AVAILABLE2(unix_set_affinity) LWT_NOT_AVAILABLE1(unix_guess_blocking_job) LWT_NOT_AVAILABLE2(unix_wait_mincore_job) LWT_NOT_AVAILABLE1(unix_open_job) LWT_NOT_AVAILABLE1(unix_stat_job) LWT_NOT_AVAILABLE1(unix_stat_64_job) LWT_NOT_AVAILABLE1(unix_lstat_job) LWT_NOT_AVAILABLE1(unix_lstat_64_job) LWT_NOT_AVAILABLE1(unix_fstat_job) LWT_NOT_AVAILABLE1(unix_fstat_64_job) LWT_NOT_AVAILABLE3(unix_utimes_job) LWT_NOT_AVAILABLE1(unix_isatty_job) LWT_NOT_AVAILABLE1(unix_opendir_job) LWT_NOT_AVAILABLE1(unix_closedir_job) LWT_NOT_AVAILABLE1(unix_valid_dir) LWT_NOT_AVAILABLE1(unix_invalidate_dir) LWT_NOT_AVAILABLE1(unix_rewinddir_job) LWT_NOT_AVAILABLE1(unix_readdir_job) LWT_NOT_AVAILABLE2(unix_readdir_n_job) LWT_NOT_AVAILABLE1(unix_readlink_job) LWT_NOT_AVAILABLE3(unix_lockf_job) LWT_NOT_AVAILABLE1(unix_getlogin_job) LWT_NOT_AVAILABLE1(unix_getpwnam_job) LWT_NOT_AVAILABLE1(unix_getgrnam_job) LWT_NOT_AVAILABLE1(unix_getpwuid_job) LWT_NOT_AVAILABLE1(unix_getgrgid_job) LWT_NOT_AVAILABLE1(unix_gethostname_job) LWT_NOT_AVAILABLE1(unix_gethostbyname_job) LWT_NOT_AVAILABLE1(unix_gethostbyaddr_job) LWT_NOT_AVAILABLE1(unix_getprotobyname_job) LWT_NOT_AVAILABLE1(unix_getprotobynumber_job) LWT_NOT_AVAILABLE2(unix_getservbyname_job) LWT_NOT_AVAILABLE2(unix_getservbyport_job) LWT_NOT_AVAILABLE3(unix_getaddrinfo_job) LWT_NOT_AVAILABLE2(unix_getnameinfo_job) LWT_NOT_AVAILABLE2(unix_bind_job) LWT_NOT_AVAILABLE1(unix_getcwd_job) LWT_NOT_AVAILABLE1(unix_tcgetattr_job) LWT_NOT_AVAILABLE3(unix_tcsetattr_job) LWT_NOT_AVAILABLE_BYTE(unix_send_msg_byte) #endif lwt-5.9.1/src/unix/windows_c/windows_pread.c000066400000000000000000000033031476253734400211310ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include CAMLprim value lwt_unix_pread(value fd, value buf, value vfile_offset, value vofs, value vlen) { intnat ofs, len, file_offset, written; DWORD numbytes, numwritten; DWORD err = 0; Begin_root(buf); ofs = Long_val(vofs); len = Long_val(vlen); file_offset = Long_val(vfile_offset); written = 0; if (len > 0) { numbytes = len; if (Descr_kind_val(fd) == KIND_SOCKET) { caml_invalid_argument("Lwt_unix.pread"); } else { HANDLE h = Handle_val(fd); OVERLAPPED overlapped; memset( &overlapped, 0, sizeof(overlapped)); overlapped.OffsetHigh = (DWORD)(file_offset >> 32); overlapped.Offset = (DWORD)(file_offset & 0xFFFFFFFFLL); if (!ReadFile(h, &Byte(buf, ofs), numbytes, &numwritten, &overlapped)) err = GetLastError(); } if (err == ERROR_BROKEN_PIPE) { /* The write handle for an anonymous pipe has been closed. We match the Unix behavior, and treat this as a zero-read instead of a Unix_error. See OCaml PR #4790. */ numwritten = 0; } else if (err) { win32_maperr(err); uerror("pread", Nothing); } written = numwritten; } End_roots(); return Val_long(written); } #endif lwt-5.9.1/src/unix/windows_c/windows_pread_job.c000066400000000000000000000050741476253734400217720ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" struct job_pread { struct lwt_unix_job job; HANDLE handle; DWORD length; DWORD Offset; DWORD OffsetHigh; DWORD result; DWORD error_code; value string; DWORD offset; char buffer[]; }; static void worker_pread(struct job_pread *job) { OVERLAPPED overlapped; memset( &overlapped, 0, sizeof(overlapped)); overlapped.OffsetHigh = job->OffsetHigh; overlapped.Offset = job->Offset; if (!ReadFile(job->handle, job->buffer, job->length, &(job->result), &overlapped)) job->error_code = GetLastError(); } static value result_pread(struct job_pread *job) { value result; DWORD error = job->error_code; if (error == ERROR_BROKEN_PIPE) { /* The write handle for an anonymous pipe has been closed. We match the Unix behavior, and treat this as a zero-read instead of a Unix_error. See OCaml PR #4790. */ job->result = 0; } else if (error) { caml_remove_generational_global_root(&job->string); lwt_unix_free_job(&job->job); win32_maperr(error); uerror("pread", Nothing); } memcpy(Bytes_val(job->string) + job->offset, job->buffer, job->result); result = Val_long(job->result); caml_remove_generational_global_root(&job->string); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_pread_job(value val_fd, value val_string, value val_file_offset, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); long length = Long_val(val_length); DWORDLONG file_offset = Long_val(val_file_offset); if (fd->kind != KIND_HANDLE) { caml_invalid_argument("Lwt_unix.pread"); } else { LWT_UNIX_INIT_JOB(job, pread, length); job->handle = fd->fd.handle; job->length = length; job->OffsetHigh = (DWORD)(file_offset >> 32); job->Offset = (DWORD)(file_offset & 0xFFFFFFFFLL); job->error_code = 0; job->string = val_string; job->offset = Long_val(val_offset); caml_register_generational_global_root(&(job->string)); return lwt_unix_alloc_job(&(job->job)); } } #endif lwt-5.9.1/src/unix/windows_c/windows_pwrite.c000066400000000000000000000026571476253734400213630ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include CAMLprim value lwt_unix_pwrite(value fd, value buf, value vfile_offset, value vofs, value vlen) { intnat ofs, len, file_offset, written; DWORD numbytes, numwritten; DWORD err = 0; Begin_root(buf); ofs = Long_val(vofs); len = Long_val(vlen); file_offset = Long_val(vfile_offset); written = 0; if (len > 0) { numbytes = len; if (Descr_kind_val(fd) == KIND_SOCKET) { caml_invalid_argument("Lwt_unix.pwrite"); } else { HANDLE h = Handle_val(fd); OVERLAPPED overlapped; memset( &overlapped, 0, sizeof(overlapped)); overlapped.OffsetHigh = (DWORD)(file_offset >> 32); overlapped.Offset = (DWORD)(file_offset & 0xFFFFFFFFLL); if (!WriteFile(h, &Byte(buf, ofs), numbytes, &numwritten, &overlapped)) err = GetLastError(); } if (err) { win32_maperr(err); uerror("pwrite", Nothing); } written = numwritten; } End_roots(); return Val_long(written); } #endif lwt-5.9.1/src/unix/windows_c/windows_pwrite_job.c000066400000000000000000000040571476253734400222110ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include #include "lwt_unix.h" struct job_pwrite { struct lwt_unix_job job; HANDLE handle; DWORD length; DWORD Offset; DWORD OffsetHigh; DWORD result; DWORD error_code; char buffer[]; }; static void worker_pwrite(struct job_pwrite *job) { OVERLAPPED overlapped; memset( &overlapped, 0, sizeof(overlapped)); overlapped.OffsetHigh = job->OffsetHigh; overlapped.Offset = job->Offset; if (!WriteFile(job->handle, job->buffer, job->length, &(job->result), &overlapped)) job->error_code = GetLastError(); } static value result_pwrite(struct job_pwrite *job) { value result; DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("pwrite", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_pwrite_job(value val_fd, value val_string, value val_file_offset, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); long length = Long_val(val_length); DWORDLONG file_offset = Long_val(val_file_offset); if (fd->kind != KIND_HANDLE) { caml_invalid_argument("Lwt_unix.pwrite"); } else { LWT_UNIX_INIT_JOB(job, pwrite, length); job->handle = fd->fd.handle; memcpy( job->buffer, String_val(val_string) + Long_val(val_offset), length); job->length = length; job->OffsetHigh = (DWORD)(file_offset >> 32); job->Offset = (DWORD)(file_offset & 0xFFFFFFFFLL); job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } } #endif lwt-5.9.1/src/unix/windows_c/windows_read.c000066400000000000000000000027331476253734400207570ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_read(value fd, value buf, value vofs, value vlen) { intnat ofs, len, written; DWORD numbytes, numwritten; DWORD err = 0; Begin_root(buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; if (len > 0) { numbytes = len; if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); ret = recv(s, &Byte(buf, ofs), numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); numwritten = ret; } else { HANDLE h = Handle_val(fd); if (!ReadFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL)) err = GetLastError(); } if (err == ERROR_BROKEN_PIPE) { /* The write handle for an anonymous pipe has been closed. We match the Unix behavior, and treat this as a zero-read instead of a Unix_error. See OCaml PR #4790. */ numwritten = 0; } else if (err) { win32_maperr(err); uerror("read", Nothing); } written = numwritten; } End_roots(); return Val_long(written); } #endif lwt-5.9.1/src/unix/windows_c/windows_read_job.c000066400000000000000000000046261476253734400216140ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include "lwt_unix.h" struct job_read { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; DWORD length; DWORD result; DWORD error_code; value string; DWORD offset; char buffer[]; }; static void worker_read(struct job_read *job) { if (job->kind == KIND_SOCKET) { int ret; ret = recv(job->fd.socket, job->buffer, job->length, 0); if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); job->result = ret; } else { if (!ReadFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) job->error_code = GetLastError(); } } static value result_read(struct job_read *job) { value result; DWORD error = job->error_code; if (error == ERROR_BROKEN_PIPE) { /* The write handle for an anonymous pipe has been closed. We match the Unix behavior, and treat this as a zero-read instead of a Unix_error. See OCaml PR #4790. */ job->result = 0; } else if (error) { caml_remove_generational_global_root(&job->string); lwt_unix_free_job(&job->job); win32_maperr(error); uerror("read", Nothing); } memcpy(Bytes_val(job->string) + job->offset, job->buffer, job->result); result = Val_long(job->result); caml_remove_generational_global_root(&job->string); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_read_job(value val_fd, value val_string, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, read, length); job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; job->length = length; job->error_code = 0; job->string = val_string; job->offset = Long_val(val_offset); caml_register_generational_global_root(&(job->string)); return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/unix/windows_c/windows_somaxconn.c000066400000000000000000000005431476253734400220460ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include CAMLprim value lwt_unix_somaxconn(value Unit) { return Val_int(SOMAXCONN); } #endif lwt-5.9.1/src/unix/windows_c/windows_system_job.c000066400000000000000000000033501476253734400222160ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #if OCAML_VERSION < 41300 #define CAML_INTERNALS #endif #include #include #include #include #include #include "lwt_unix.h" struct job_system { struct lwt_unix_job job; HANDLE handle; }; static void worker_system(struct job_system *job) { WaitForSingleObject(job->handle, INFINITE); } static value result_system(struct job_system *job) { HANDLE handle = job->handle; DWORD code; DWORD err; lwt_unix_free_job(&job->job); if (!GetExitCodeProcess(handle, &code)) { err = GetLastError(); CloseHandle(handle); win32_maperr(err); uerror("GetExitCodeProcess", Nothing); } CloseHandle(handle); return Val_int(code); } CAMLprim value lwt_unix_system_job(value cmdline) { CAMLparam1(cmdline); STARTUPINFO si; PROCESS_INFORMATION pi; DWORD flags = CREATE_UNICODE_ENVIRONMENT; BOOL ret; char_os *cmdlines = caml_stat_strdup_to_os(String_val(cmdline)); ZeroMemory(&si, sizeof(si)); ZeroMemory(&pi, sizeof(pi)); si.cb = sizeof(si); ret = CreateProcess(NULL, cmdlines, NULL, NULL, TRUE, flags, NULL, NULL, &si, &pi); caml_stat_free(cmdlines); if (!ret) { win32_maperr(GetLastError()); uerror("CreateProcess", Nothing); } else { LWT_UNIX_INIT_JOB(job, system, 0); CloseHandle(pi.hThread); job->handle = pi.hProcess; CAMLreturn(lwt_unix_alloc_job(&(job->job))); } } #endif lwt-5.9.1/src/unix/windows_c/windows_write.c000066400000000000000000000023041476253734400211700ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include CAMLprim value lwt_unix_write(value fd, value buf, value vofs, value vlen) { intnat ofs, len, written; DWORD numbytes, numwritten; DWORD err = 0; Begin_root(buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; if (len > 0) { numbytes = len; if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); ret = send(s, &Byte(buf, ofs), numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); numwritten = ret; } else { HANDLE h = Handle_val(fd); if (!WriteFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL)) err = GetLastError(); } if (err) { win32_maperr(err); uerror("write", Nothing); } written = numwritten; } End_roots(); return Val_long(written); } #endif lwt-5.9.1/src/unix/windows_c/windows_write_job.c000066400000000000000000000036021476253734400220240ustar00rootroot00000000000000/* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) #include #include #include #include "lwt_unix.h" struct job_write { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; DWORD length; DWORD result; DWORD error_code; char buffer[]; }; static void worker_write(struct job_write *job) { if (job->kind == KIND_SOCKET) { int ret; ret = send(job->fd.socket, job->buffer, job->length, 0); if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); job->result = ret; } else { if (!WriteFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) job->error_code = GetLastError(); } } static value result_write(struct job_write *job) { value result; DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("write", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, write, length); job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); job->length = length; job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } #endif lwt-5.9.1/src/util/000077500000000000000000000000001476253734400141175ustar00rootroot00000000000000lwt-5.9.1/src/util/fetch-dependees.py000077500000000000000000000050721476253734400175230ustar00rootroot00000000000000#! /usr/bin/env python # Retrieves source code of OPAM packages recursively depending on Lwt into a # subdirectory ./dependees/, so you can grep through the code. import os.path import subprocess import time DEPENDEES = "dependees" def main(): now = time.time() subprocess.check_call(["opam", "update"]) packages = subprocess.check_output([ "opam", "list", "--all", "--depends-on=lwt", "--dev", "--recursive", "--short"]) depopt_packages = subprocess.check_output([ "opam", "list", "--all", "--depends-on=lwt", "--depopts", "--dev", "--short", "--with-test", "--with-doc"]) packages = packages.strip().split("\n") depopt_packages = depopt_packages.strip().split("\n") packages = set(packages).union(set(depopt_packages)) packages = list(packages) packages.sort() print "Downloading %i packages..." % len(packages) for package in packages: directory = os.path.join(DEPENDEES, package) try: timestamp = os.path.getmtime(directory) if now - timestamp < 24 * 60 * 60: continue except: pass remove_command = ["rm", "-rf", directory] subprocess.check_call(remove_command) use_opam_source = False info_command = ["opam", "info", "--field=dev-repo:", package] try: field = subprocess.check_output(info_command) no_quotes = field[1:-2] if no_quotes[0:9] == "git+https": repo = no_quotes[4:] elif no_quotes[0:16] == "git://github.com": if no_quotes[-1:] == "/": no_quotes = no_quotes[:-1] repo = "https" + no_quotes[3:] else: use_opam_source = True if use_opam_source == False: clone_command = \ ["git", "clone", "-q", "--depth", "1", repo, directory] print "[%s]" % package, " ".join(clone_command) subprocess.check_call(clone_command) except: use_opam_source = True if not use_opam_source: continue source_command = ["opam", "source", "--dir=" + directory] try: subprocess.check_call(source_command + ["--dev-repo", package]) except subprocess.CalledProcessError as e: subprocess.check_call(remove_command) try: subprocess.check_call(source_command + [package]) except subprocess.CalledProcessError as e: pass if __name__ == "__main__": main() lwt-5.9.1/test/000077500000000000000000000000001476253734400133325ustar00rootroot00000000000000lwt-5.9.1/test/core/000077500000000000000000000000001476253734400142625ustar00rootroot00000000000000lwt-5.9.1/test/core/dune000066400000000000000000000001731476253734400151410ustar00rootroot00000000000000(test (name main) (package lwt) (libraries lwttester) (preprocess (future_syntax)) (flags (:standard -w +A-40-42))) lwt-5.9.1/test/core/main.ml000066400000000000000000000010471476253734400155420ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) Test.run "core" (Test_lwt.suites @ [ Test_lwt_stream.suite; Test_lwt_list.suite_primary; Test_lwt_list.suite_intensive; Test_lwt_switch.suite; Test_lwt_mutex.suite; Test_lwt_result.suite; Test_lwt_mvar.suite; Test_lwt_condition.suite; Test_lwt_pool.suite; Test_lwt_sequence.suite; Test_lwt_seq.suite_base; Test_lwt_seq.suite_fuzzing; ]) lwt-5.9.1/test/core/test_lwt.ml000066400000000000000000003721231476253734400164710ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] open Test let state_is = Lwt.debug_state_is (* When using JavaScript promises, this runs [f] on the next "tick." *) let later f = Lwt.map f Lwt.return_unit (* An exception type fresh to this testing module. *) exception Exception let set_async_exception_hook hook = let saved = !Lwt.async_exception_hook in let restore () = Lwt.async_exception_hook := saved in Lwt.async_exception_hook := hook; restore (* An add_loc function for [Lwt.backtrace_bind], etc. This should be defined literally at each place it is used, and it should be tested that the location of the re-raise is added to the backtrace. However, I believe that backtraces are broken right now, so neither of these is done. *) let add_loc exn = try raise exn with exn -> exn (* The list of all the test suites in this file. This name is repeatedly shadowed as more and more test suites are defined. The purpose is to keep the aggregation of test suites local to their definition, instead of having to maintain a list in a separate location in the code. *) let suites : Test.suite list = [] (* Tests for promises created with [Lwt.return], [Lwt.fail], and related functions, as well as state query (hard to test one without the other). These tests use assertions instead of relying on the correctness of a final [Lwt.return], not that it's particularly likely to be broken. *) let trivial_promise_tests = suite "trivial promises" [ test "return" begin fun () -> state_is (Lwt.Return "foo") (Lwt.return "foo") end; test "reject" begin fun () -> state_is (Lwt.Fail Exception) (Lwt.fail Exception) end; test "of_result: fulfilled" begin fun () -> state_is (Lwt.Return "foo") (Lwt.of_result (Result.Ok "foo")) end; test "of_result: rejected" begin fun () -> state_is (Lwt.Fail Exception) (Lwt.of_result (Result.Error Exception)) end; test "return_unit" begin fun () -> state_is (Lwt.Return ()) Lwt.return_unit end; test "return_true" begin fun () -> state_is (Lwt.Return true) Lwt.return_true end; test "return_false" begin fun () -> state_is (Lwt.Return false) Lwt.return_false end; test "return_none" begin fun () -> state_is (Lwt.Return None) Lwt.return_none end; test "return_some" begin fun () -> state_is (Lwt.Return (Some "foo")) (Lwt.return_some "foo") end; test "return_ok" begin fun () -> state_is (Lwt.Return (Result.Ok "foo")) (Lwt.return_ok "foo") end; test "return_error" begin fun () -> state_is (Lwt.Return (Result.Error "foo")) (Lwt.return_error "foo") end; test "fail_with" begin fun () -> state_is (Lwt.Fail (Failure "foo")) (Lwt.fail_with "foo") end; test "fail_invalid_arg" begin fun () -> state_is (Lwt.Fail (Invalid_argument "foo")) (Lwt.fail_invalid_arg "foo") end; ] let suites = suites @ [trivial_promise_tests] (* Tests for promises created with [Lwt.wait] and [Lwt.task], not including tests for cancellation of the latter. Tests for double use of [Lwt.wakeup] and related functions are in a separated suite. So are tests for [Lwt.wakeup_later] and related functions. *) let initial_promise_tests = suite "initial promises" [ test "wait: pending" begin fun () -> let p, _ = Lwt.wait () in state_is Lwt.Sleep p end; test "task: pending" begin fun () -> let p, _ = Lwt.task () in state_is Lwt.Sleep p end; test "wait: fulfill" begin fun () -> let p, r = Lwt.wait () in Lwt.wakeup r "foo"; state_is (Lwt.Return "foo") p end; test "task: fulfill" begin fun () -> let p, r = Lwt.task () in Lwt.wakeup r "foo"; state_is (Lwt.Return "foo") p end; test "wait: reject" begin fun () -> let p, r = Lwt.wait () in Lwt.wakeup_exn r Exception; state_is (Lwt.Fail Exception) p end; test "task: reject" begin fun () -> let p, r = Lwt.task () in Lwt.wakeup_exn r Exception; state_is (Lwt.Fail Exception) p end; test "wait: resolve" begin fun () -> let p, r = Lwt.wait () in Lwt.wakeup_result r (Result.Ok "foo"); state_is (Lwt.Return "foo") p end; test "task: resolve" begin fun () -> let p, r = Lwt.task () in Lwt.wakeup_result r (Result.Ok "foo"); state_is (Lwt.Return "foo") p end; ] let suites = suites @ [initial_promise_tests] let double_resolve_tests = suite "double resolve" [ test "wakeup: double use on wait" begin fun () -> let _, r = Lwt.wait () in Lwt.wakeup r "foo"; try Lwt.wakeup r "foo"; Lwt.return_false with Invalid_argument "Lwt.wakeup" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup: double use on task" begin fun () -> let _, r = Lwt.task () in Lwt.wakeup r "foo"; try Lwt.wakeup r "foo"; Lwt.return_false with Invalid_argument "Lwt.wakeup" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_exn: double use on wait" begin fun () -> let _, r = Lwt.wait () in Lwt.wakeup_exn r Exception; try Lwt.wakeup_exn r Exception; Lwt.return_false with Invalid_argument "Lwt.wakeup_exn" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_exn: double use on task" begin fun () -> let _, r = Lwt.task () in Lwt.wakeup_exn r Exception; try Lwt.wakeup_exn r Exception; Lwt.return_false with Invalid_argument "Lwt.wakeup_exn" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_result: double use on wait" begin fun () -> let _, r = Lwt.wait () in Lwt.wakeup_exn r Exception; try Lwt.wakeup_result r (Result.Ok ()); Lwt.return_false with Invalid_argument "Lwt.wakeup_result" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_result: double use on task" begin fun () -> let _, r = Lwt.task () in Lwt.wakeup_exn r Exception; try Lwt.wakeup_result r (Result.Ok ()); Lwt.return_false with Invalid_argument "Lwt.wakeup_result" -> Lwt.return_true end [@ocaml.warning "-52"]; ] let suites = suites @ [double_resolve_tests] (* Tests for sequential composition functions, such as [Lwt.bind], but not including testing for interaction with cancellation and sequence-associated storage. Those tests come later. *) let bind_tests = suite "bind" [ test "already fulfilled" begin fun () -> let p = Lwt.return "foo" in let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in state_is (Lwt.Return "foobar") p end; (* A somewhat surprising behavior of native [bind] is that if [p] is fulfilled and [f] raises before evaluating to a promise, [bind p f] raises, instead of evaluating to a promise. On the other hand, if [p] is pending, and [f] raises, the exception is folded into the promise resulting from [bind]. See https://github.com/ocsigen/lwt/issues/329 *) test "already fulfilled, f raises" begin fun () -> let p = Lwt.return "foo" in try Lwt.bind p (fun _ -> raise Exception) |> ignore; Lwt.return_false with Exception -> Lwt.return_true end; test "already rejected" begin fun () -> let p = Lwt.fail Exception in let p = Lwt.bind p (fun _ -> Lwt.return "foo") in state_is (Lwt.Fail Exception) p end; test "pending" begin fun () -> let f_ran = ref false in let p, _ = Lwt.wait () in let p = Lwt.bind p (fun _ -> f_ran := true; Lwt.return_unit) in Lwt.bind (state_is Lwt.Sleep p) (fun correct -> Lwt.return (correct && !f_ran = false)) end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p end; test "pending, fulfilled, f raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.bind p (fun _ -> raise Exception) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.bind p (fun _ -> Lwt.return "foo") in Lwt.wakeup_exn r Exception; state_is (Lwt.Fail Exception) p end; test "chain" begin fun () -> let p1, r1 = Lwt.wait () in let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in let p3 = Lwt.bind p2 (fun s -> Lwt.return (s ^ "!!1")) in Lwt.wakeup r1 "foo"; state_is (Lwt.Return "foobar!!1") p3 end; test "suspended chain" begin fun () -> let p1, r = Lwt.wait () in let p2 = Lwt.return "foo" in let p3 = Lwt.bind p1 (fun () -> p2) in let p4 = Lwt.bind p1 (fun () -> p3) in Lwt.wakeup r (); state_is (Lwt.Return "foo") p4 end; test "fanout" begin fun () -> let p1, r = Lwt.wait () in let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in let p3 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "!!1")) in let p4 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "omg")) in Lwt.wakeup r "foo"; Lwt.bind (state_is (Lwt.Return "foobar") p2) (fun p2_correct -> Lwt.bind (state_is (Lwt.Return "foo!!1") p3) (fun p3_correct -> Lwt.bind (state_is (Lwt.Return "fooomg") p4) (fun p4_correct -> Lwt.return (p2_correct && p3_correct && p4_correct)))) end; test "double pending" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.bind p1 (fun _ -> p2) in Lwt.wakeup r1 "foo"; assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r2 "bar"; state_is (Lwt.Return "bar") p end; test "same pending" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.bind p (fun _ -> p) in Lwt.wakeup r "foo"; state_is (Lwt.Return "foo") p end; test "nested" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.bind p1 (fun s -> Lwt.bind p2 (fun s' -> Lwt.return (s ^ s'))) in Lwt.wakeup r1 "foo"; Lwt.wakeup r2 "bar"; state_is (Lwt.Return "foobar") p end; (* This tests an implementation detail, namely the construction and flattening of a chain of proxy promises. *) test "proxy chain" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3, r3 = Lwt.wait () in let p4 = Lwt.bind p1 (fun _ -> p3) in let p5 = Lwt.bind p2 (fun _ -> p4) in Lwt.wakeup r1 (); Lwt.wakeup r2 (); Lwt.wakeup r3 "bar"; Lwt.bind (state_is (Lwt.Return "bar") p3) (fun p3_correct -> Lwt.bind (state_is (Lwt.Return "bar") p4) (fun p4_correct -> Lwt.bind (state_is (Lwt.Return "bar") p5) (fun p5_correct -> Lwt.return (p3_correct && p4_correct && p5_correct)))) end; (* This tests an implementation detail, namely that proxy promise chaining does not form cycles. It's only relevant for the native implementation. *) test "cycle" begin fun () -> let p, r = Lwt.wait () in let p' = ref (Lwt.return_unit) in p' := Lwt.bind p (fun _ -> !p'); Lwt.wakeup r (); Lwt.return (Lwt.state !p' = Lwt.Sleep) end; (* This tests the effect of an implementation detail: if a promise is going to be resolved by a callback, but that promise becomes a proxy synchronously during that callback, everything still works. *) test "proxy during callback" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.bind p1 (fun () -> (* Synchronously resolve [p2]. Because of the [bind] below, [p3] will become a proxy for [p4] while this callback is still running. We then finish the callback by returning [true]. If [bind] is implemented correctly, it will follow the [p3] proxy link to [p4] only after the callback returns. In an earlier incorrect implementation, this code could cause Lwt to hang forever, or crash the process. *) Lwt.wakeup r2 (); Lwt.return_true) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup r1 (); p4 end; ] let suites = suites @ [bind_tests] let backtrace_bind_tests = suite "backtrace_bind" [ test "fulfilled" begin fun () -> let p = Lwt.return "foo" in let p = Lwt.backtrace_bind add_loc p (fun s -> Lwt.return @@ s ^ "bar") in state_is (Lwt.Return "foobar") p end; test "rejected" begin fun () -> let p = Lwt.fail Exception in let p = Lwt.backtrace_bind add_loc p (fun _ -> Lwt.return "foo") in state_is (Lwt.Fail Exception) p end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_bind add_loc p (fun s -> Lwt.return (s ^ "bar")) in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p end; test "pending, fulfilled, f raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_bind add_loc p (fun () -> raise Exception) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_bind add_loc p (fun _ -> Lwt.return "foo") in Lwt.wakeup_exn r Exception; state_is (Lwt.Fail Exception) p end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.backtrace_bind add_loc p1 (fun () -> Lwt.wakeup r2 (); Lwt.return_true) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup r1 (); p4 end; ] let suites = suites @ [backtrace_bind_tests] let map_tests = suite "map" [ test "fulfilled" begin fun () -> let p = Lwt.return "foo" in let p = Lwt.map (fun s -> s ^ "bar") p in state_is (Lwt.Return "foobar") p end; test "fulfilled, f raises" begin fun () -> let p = Lwt.return "foo" in let p = Lwt.map (fun _ -> raise Exception) p in state_is (Lwt.Fail Exception) p end; test "rejected" begin fun () -> let p = Lwt.fail Exception in let p = Lwt.map (fun _ -> "foo") p in state_is (Lwt.Fail Exception) p end; test "pending" begin fun () -> let f_ran = ref false in let p, _ = Lwt.wait () in let p = Lwt.map (fun _ -> f_ran := true) p in Lwt.bind (state_is Lwt.Sleep p) (fun correct -> Lwt.return (correct && !f_ran = false)) end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.map (fun s -> s ^ "bar") p in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p end; test "pending, fulfilled, f raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.map (fun () -> raise Exception) p in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.map (fun _ -> Lwt.return "foo") p in Lwt.wakeup_exn r Exception; state_is (Lwt.Fail Exception) p end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.map (fun () -> Lwt.wakeup r2 (); true) p1 in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup r1 (); p4 end; ] let suites = suites @ [map_tests] let catch_tests = suite "catch" [ test "fulfilled" begin fun () -> let p = Lwt.catch (fun () -> Lwt.return "foo") (fun _ -> Lwt.return "bar") in state_is (Lwt.Return "foo") p end; test "f raises" begin fun () -> let p = Lwt.catch (fun () -> raise Exception) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; test "rejected" begin fun () -> let p = Lwt.catch (fun () -> Lwt.fail Exception) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; test "rejected (raise)" begin fun () -> let p = Lwt.catch (fun () -> raise Exception) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; (* This is an analog of the "bind quirk," see https://github.com/ocsigen/lwt/issues/329 *) test "rejected, h raises" begin fun () -> try ignore @@ Lwt.catch (fun () -> Lwt.fail Exit) (fun _ -> raise Exception); Lwt.return_false with Exception -> Lwt.return_true end; test "pending" begin fun () -> let h_ran = ref false in let p = Lwt.catch (fun () -> fst (Lwt.wait ())) (fun _ -> h_ran := true; Lwt.return_unit) in Lwt.bind (state_is Lwt.Sleep p) (fun correct -> Lwt.return (correct && !h_ran = false)) end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.catch (fun () -> p) (fun _ -> Lwt.return "bar") in Lwt.wakeup r "foo"; state_is (Lwt.Return "foo") p end; test "pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.catch (fun () -> p) (fun exn -> Lwt.return exn) in Lwt.wakeup_exn r Exception; state_is (Lwt.Return Exception) p end; test "pending, rejected, h raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.catch (fun () -> p) (fun _ -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; test "pending, rejected, h pending" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.catch (fun () -> p1) (fun _ -> p2) in Lwt.wakeup_exn r1 Exception; assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r2 "foo"; state_is (Lwt.Return "foo") p end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.catch (fun () -> p1) (fun _exn -> Lwt.wakeup r2 (); Lwt.return_true) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup_exn r1 Exit; p4 end; test "catch with ocaml-runtime exception" begin fun () -> Lwt.Exception_filter.(set handle_all_except_runtime); try Lwt.catch (fun () -> raise Out_of_memory) (fun _ -> Lwt.return_false) with | Out_of_memory -> Lwt.return_true end; test "try_bind with ocaml-runtime exception" begin fun () -> Lwt.Exception_filter.(set handle_all_except_runtime); try Lwt.try_bind (fun () -> raise Out_of_memory) (fun () -> Lwt.return_false) (fun _ -> Lwt.return_false) with | Out_of_memory -> Lwt.return_true end; test "try_bind(2) with ocaml-runtime exception" begin fun () -> Lwt.Exception_filter.(set handle_all_except_runtime); try let _ = Lwt.try_bind (fun () -> Lwt.return_unit) (fun () -> raise Out_of_memory) (fun _ -> Lwt.return_false) in Lwt.return_false with | Out_of_memory -> Lwt.return_true end; ] let suites = suites @ [catch_tests] let backtrace_catch_tests = suite "backtrace_catch" [ test "fulfilled" begin fun () -> let p = Lwt.backtrace_catch add_loc (fun () -> Lwt.return "foo") (fun _ -> Lwt.return "bar") in state_is (Lwt.Return "foo") p end; test "f raises" begin fun () -> let p = Lwt.backtrace_catch add_loc (fun () -> raise Exception) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; test "rejected" begin fun () -> let p = Lwt.backtrace_catch add_loc (fun () -> raise Exception) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; test "pending" begin fun () -> let h_ran = ref false in let p = Lwt.backtrace_catch add_loc (fun () -> fst (Lwt.wait ())) (fun _ -> h_ran := true; Lwt.return_unit) in state_is Lwt.Sleep p end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_catch add_loc (fun () -> p) (fun _ -> Lwt.return "bar") in Lwt.wakeup r "foo"; state_is (Lwt.Return "foo") p end; test "pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_catch add_loc (fun () -> p) (fun exn -> Lwt.return exn) in Lwt.wakeup_exn r Exception; state_is (Lwt.Return Exception) p end; test "pending, rejected, h raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_catch add_loc (fun () -> p) (fun _ -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.backtrace_catch add_loc (fun () -> p1) (fun _exn -> Lwt.wakeup r2 (); Lwt.return_true) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup_exn r1 Exit; p4 end; ] let suites = suites @ [backtrace_catch_tests] let try_bind_tests = suite "try_bind" [ test "fulfilled" begin fun () -> let p = Lwt.try_bind (fun () -> Lwt.return "foo") (fun s -> Lwt.return (s ^ "bar")) (fun _ -> Lwt.return "!!1") in state_is (Lwt.Return "foobar") p end; (* An analog of the bind quirk. *) test "fulfilled, f' raises" begin fun () -> try ignore @@ Lwt.try_bind (fun () -> Lwt.return_unit) (fun () -> raise Exception) (fun _ -> Lwt.return_unit); Lwt.return_false with Exception -> Lwt.return_true end; test "rejected" begin fun () -> let p = Lwt.try_bind (fun () -> raise Exception) (fun _ -> Lwt.return Exit) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; test "f raises" begin fun () -> let p = Lwt.try_bind (fun () -> raise Exception) (fun _ -> Lwt.return Exit) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; (* Another analog of the bind quirk *) test "rejected, h raises" begin fun () -> try ignore @@ Lwt.try_bind (fun () -> raise Exit) (fun _ -> Lwt.return_unit) (fun _ -> raise Exception); Lwt.return_false with Exception -> Lwt.return_true end; test "pending" begin fun () -> let f_ran = ref false in let p, _ = Lwt.wait () in let p = Lwt.try_bind (fun () -> p) (fun _ -> f_ran := true; Lwt.return_unit) (fun _ -> f_ran := true; Lwt.return_unit) in Lwt.bind (state_is Lwt.Sleep p) (fun correct -> Lwt.return (correct && not !f_ran)) end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.try_bind (fun () -> p) (fun s -> Lwt.return (s ^ "bar")) (fun _ -> Lwt.return "!!1") in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p end; test "pending, fulfilled, f' raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.try_bind (fun () -> p) (fun _ -> raise Exception) (fun _ -> Lwt.return_unit) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, fulfilled, f' pending" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.try_bind (fun () -> p1) (fun () -> p2) (fun _ -> Lwt.return "bar") in Lwt.wakeup r1 (); assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r2 "foo"; state_is (Lwt.Return "foo") p end; test "pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.try_bind (fun () -> p) (fun _ -> Lwt.return Exit) (fun exn -> Lwt.return exn) in Lwt.wakeup_exn r Exception; state_is (Lwt.Return Exception) p end; test "pending, rejected, h raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.try_bind (fun () -> p) (fun _ -> Lwt.return_unit) (fun _ -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; test "pending, rejected, h pending" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.try_bind (fun () -> p1) (fun () -> Lwt.return "foo") (fun _ -> p2) in Lwt.wakeup_exn r1 Exception; assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r2 "bar"; state_is (Lwt.Return "bar") p end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback (fulfilled)" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.try_bind (fun () -> p1) (fun () -> Lwt.wakeup r2 (); Lwt.return_true) (fun _exn -> Lwt.return_false) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup r1 (); p4 end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback (rejected)" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.try_bind (fun () -> p1) (fun () -> Lwt.return_false) (fun _exn -> Lwt.wakeup r2 (); Lwt.return_true) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup_exn r1 Exit; p4 end; ] let suites = suites @ [try_bind_tests] let backtrace_try_bind_tests = suite "backtrace_try_bind" [ test "fulfilled" begin fun () -> let p = Lwt.backtrace_try_bind add_loc (fun () -> Lwt.return "foo") (fun s -> Lwt.return (s ^ "bar")) (fun _ -> Lwt.return "!!1") in state_is (Lwt.Return "foobar") p end; test "rejected" begin fun () -> let p = Lwt.backtrace_try_bind add_loc (fun () -> raise Exception) (fun _ -> Lwt.return Exit) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; test "f raises" begin fun () -> let p = Lwt.backtrace_try_bind add_loc (fun () -> raise Exception) (fun _ -> Lwt.return Exit) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p end; test "pending" begin fun () -> let f_ran = ref false in let p, _ = Lwt.wait () in let p = Lwt.backtrace_try_bind add_loc (fun () -> p) (fun _ -> f_ran := true; Lwt.return_unit) (fun _ -> f_ran := true; Lwt.return_unit) in state_is Lwt.Sleep p end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_try_bind add_loc (fun () -> p) (fun s -> Lwt.return (s ^ "bar")) (fun _ -> Lwt.return "!!1") in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p end; test "pending, fulfilled, f' raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_try_bind add_loc (fun () -> p) (fun _ -> raise Exception) (fun _ -> Lwt.return_unit) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_try_bind add_loc (fun () -> p) (fun _ -> Lwt.return Exit) (fun exn -> Lwt.return exn) in Lwt.wakeup_exn r Exception; state_is (Lwt.Return Exception) p end; test "pending, rejected, h raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_try_bind add_loc (fun () -> p) (fun _ -> Lwt.return_unit) (fun _ -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback (fulfilled)" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.backtrace_try_bind add_loc (fun () -> p1) (fun () -> Lwt.wakeup r2 (); Lwt.return_true) (fun _exn -> Lwt.return_false) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup r1 (); p4 end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback (rejected)" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.backtrace_try_bind add_loc (fun () -> p1) (fun () -> Lwt.return_false) (fun _exn -> Lwt.wakeup r2 (); Lwt.return_true) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup_exn r1 Exit; p4 end; ] let suites = suites @ [backtrace_try_bind_tests] let finalize_tests = suite "finalize" [ test "fulfilled" begin fun () -> let f'_ran = ref false in let p = Lwt.finalize (fun () -> Lwt.return "foo") (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> Lwt.return (correct && !f'_ran = true)) end; test "fulfilled, f' rejected" begin fun () -> let p = Lwt.finalize (fun () -> Lwt.return_unit) (fun () -> Lwt.fail Exception) in state_is (Lwt.Fail Exception) p end; (* An instance of the bind quirk. *) test "fulfilled, f' raises" begin fun () -> try ignore @@ Lwt.finalize (fun () -> Lwt.return_unit) (fun () -> raise Exception); Lwt.return_false with Exception -> Lwt.return_true end; test "rejected" begin fun () -> let f'_ran = ref false in let p = Lwt.finalize (fun () -> Lwt.fail Exception) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> Lwt.return (correct && !f'_ran = true)) end; test "rejected, f' rejected" begin fun () -> let p = Lwt.finalize (fun () -> Lwt.fail Exit) (fun () -> Lwt.fail Exception) in state_is (Lwt.Fail Exception) p end; (* An instance of the bind quirk. *) test "rejected, f' raises" begin fun () -> try ignore @@ Lwt.finalize (fun () -> raise Exit) (fun () -> raise Exception); Lwt.return_false with Exception -> Lwt.return_true end; test "pending" begin fun () -> let f'_ran = ref false in let p, _ = Lwt.wait () in let p = Lwt.finalize (fun () -> p) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.bind (state_is Lwt.Sleep p) (fun correct -> Lwt.return (correct && !f'_ran = false)) end; test "pending, fulfilled" begin fun () -> let f'_ran = ref false in let p, r = Lwt.wait () in let p = Lwt.finalize (fun () -> p) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.wakeup r "foo"; Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> Lwt.return (correct && !f'_ran = true)) end; test "pending, fulfilled, f' rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.finalize (fun () -> p) (fun () -> raise Exception) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, fulfilled, f' raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.finalize (fun () -> p) (fun () -> raise Exception) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, fulfilled, f' pending" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.finalize (fun () -> p1) (fun () -> p2) in Lwt.wakeup r1 "foo"; assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r2 (); state_is (Lwt.Return "foo") p end; test "pending, fulfilled, f' pending, rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.finalize (fun () -> p1) (fun () -> p2) in Lwt.wakeup r1 (); assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup_exn r2 Exception; state_is (Lwt.Fail Exception) p end; test "pending, rejected" begin fun () -> let f'_ran = ref false in let p, r = Lwt.wait () in let p = Lwt.finalize (fun () -> p) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.wakeup_exn r Exception; Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> Lwt.return (correct && !f'_ran = true)) end; test "pending, rejected, f' rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.finalize (fun () -> p) (fun () -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; test "pending, rejected, f' raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.finalize (fun () -> p) (fun () -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; test "pending, rejected, f' pending" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.finalize (fun () -> p1) (fun () -> p2) in Lwt.wakeup_exn r1 Exception; assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r2 (); state_is (Lwt.Fail Exception) p end; test "pending, rejected, f' pending, rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.finalize (fun () -> p1) (fun () -> p2) in Lwt.wakeup_exn r1 Exit; assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup_exn r2 Exception; state_is (Lwt.Fail Exception) p end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback (fulfilled)" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.finalize (fun () -> p1) (fun () -> Lwt.wakeup r2 (); Lwt.return_unit) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup r1 (); Lwt.bind p4 (fun () -> Lwt.return_true) end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback (rejected)" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.finalize (fun () -> p1) (fun () -> Lwt.wakeup r2 (); Lwt.return_unit) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup_exn r1 Exit; Lwt.catch (fun () -> p4) (fun _exn -> Lwt.return_true) end; ] let suites = suites @ [finalize_tests] let backtrace_finalize_tests = suite "backtrace_finalize" [ test "fulfilled" begin fun () -> let f'_ran = ref false in let p = Lwt.backtrace_finalize add_loc (fun () -> Lwt.return "foo") (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> Lwt.return (correct && !f'_ran = true)) end; test "fulfilled, f' rejected" begin fun () -> let p = Lwt.backtrace_finalize add_loc (fun () -> Lwt.return_unit) (fun () -> Lwt.fail Exception) in state_is (Lwt.Fail Exception) p end; (* Instance of the bind quirk. *) test "fulfilled, f' raises" begin fun () -> try ignore @@ Lwt.backtrace_finalize add_loc (fun () -> Lwt.return_unit) (fun () -> raise Exception); Lwt.return_false with Exception -> Lwt.return_true end; test "rejected" begin fun () -> let f'_ran = ref false in let p = Lwt.backtrace_finalize add_loc (fun () -> raise Exception) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> Lwt.return (correct && !f'_ran = true)) end; test "rejected, f' rejected" begin fun () -> let p = Lwt.backtrace_finalize add_loc (fun () -> Lwt.fail Exit) (fun () -> Lwt.fail Exception) in state_is (Lwt.Fail Exception) p end; (* Instance of the bind quirk. *) test "rejected, f' raises" begin fun () -> try ignore @@ Lwt.backtrace_finalize add_loc (fun () -> raise Exit) (fun () -> raise Exception); Lwt.return_false with Exception -> Lwt.return_true end; test "pending" begin fun () -> let f'_ran = ref false in let p, _ = Lwt.wait () in let p = Lwt.backtrace_finalize add_loc (fun () -> p) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.bind (state_is Lwt.Sleep p) (fun correct -> Lwt.return (correct && !f'_ran = false)) end; test "pending, fulfilled" begin fun () -> let f'_ran = ref false in let p, r = Lwt.wait () in let p = Lwt.backtrace_finalize add_loc (fun () -> p) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.wakeup r "foo"; Lwt.bind (state_is (Lwt.Return "foo") p) (fun correct -> Lwt.return (correct && !f'_ran = true)) end; test "pending, fulfilled, f' rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_finalize add_loc (fun () -> p) (fun () -> raise Exception) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, fulfilled, f' raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_finalize add_loc (fun () -> p) (fun () -> raise Exception) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "pending, rejected" begin fun () -> let f'_ran = ref false in let p, r = Lwt.wait () in let p = Lwt.backtrace_finalize add_loc (fun () -> p) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.wakeup_exn r Exception; Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> Lwt.return (correct && !f'_ran = true)) end; test "pending, rejected, f' rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_finalize add_loc (fun () -> p) (fun () -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; test "pending, rejected, f' raises" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.backtrace_finalize add_loc (fun () -> p) (fun () -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback (fulfilled)" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.backtrace_finalize add_loc (fun () -> p1) (fun () -> Lwt.wakeup r2 (); Lwt.return_unit) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup r1 (); Lwt.bind p4 (fun () -> Lwt.return_true) end; (* See "proxy during callback" in [bind] tests. *) test "proxy during callback (rejected)" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.backtrace_finalize add_loc (fun () -> p1) (fun () -> Lwt.wakeup r2 (); Lwt.return_unit) in let p4 = Lwt.bind p2 (fun () -> p3) in Lwt.wakeup_exn r1 Exit; Lwt.catch (fun () -> p4) (fun _exn -> Lwt.return_true) end; ] let suites = suites @ [backtrace_finalize_tests] let on_success_tests = suite "on_success" [ test "fulfilled" begin fun () -> let f_ran = ref false in Lwt.on_success (Lwt.return_unit) (fun () -> f_ran := true); later (fun () -> !f_ran = true) end; test ~sequential:true "fulfilled, f raises" begin fun () -> let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.on_success (Lwt.return_unit) (fun () -> raise Exception); later (fun () -> restore (); !saw = Some Exception) end; test "rejected" begin fun () -> let f_ran = ref false in Lwt.on_success (Lwt.fail Exception) (fun () -> f_ran := true); later (fun () -> !f_ran = false) end; test "pending" begin fun () -> let f_ran = ref false in Lwt.on_success (fst (Lwt.wait ())) (fun () -> f_ran := true); later (fun () -> !f_ran = false) end; test "pending, fulfilled" begin fun () -> let f_ran = ref false in let p, r = Lwt.wait () in Lwt.on_success p (fun () -> f_ran := true); assert (!f_ran = false); Lwt.wakeup r (); later (fun () -> !f_ran = true) end; test ~sequential:true "pending, fulfilled, f raises" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.on_success p (fun () -> raise Exception); let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.wakeup r (); later (fun () -> restore (); !saw = Some Exception) end; test "pending, rejected" begin fun () -> let f_ran = ref false in let p, r = Lwt.wait () in Lwt.on_success p (fun () -> f_ran := true); Lwt.wakeup_exn r Exception; later (fun () -> !f_ran = false) end; ] let suites = suites @ [on_success_tests] let on_failure_tests = suite "on_failure" [ test "fulfilled" begin fun () -> let f_ran = ref false in Lwt.on_failure (Lwt.return_unit) (fun _ -> f_ran := true); later (fun () -> !f_ran = false) end; test "rejected" begin fun () -> let saw = ref None in Lwt.on_failure (Lwt.fail Exception) (fun exn -> saw := Some exn); later (fun () -> !saw = Some Exception) end; test ~sequential:true "rejected, f raises" begin fun () -> let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.on_failure (Lwt.fail Exit) (fun _ -> raise Exception); later (fun () -> restore (); !saw = Some Exception) end; test "pending" begin fun () -> let f_ran = ref false in Lwt.on_failure (fst (Lwt.wait ())) (fun _ -> f_ran := true); later (fun () -> !f_ran = false) end; test "pending, fulfilled" begin fun () -> let f_ran = ref false in let p, r = Lwt.wait () in Lwt.on_failure p (fun _ -> f_ran := true); Lwt.wakeup r (); later (fun () -> !f_ran = false) end; test "pending, rejected" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.on_failure p (fun exn -> saw := Some exn); Lwt.wakeup_exn r Exception; later (fun () -> !saw = Some Exception) end; test ~sequential:true "pending, rejected, f raises" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.on_failure p (fun _ -> raise Exception); let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.wakeup_exn r Exit; later (fun () -> restore (); !saw = Some Exception) end; ] let suites = suites @ [on_failure_tests] let on_termination_tests = suite "on_termination" [ test "fulfilled" begin fun () -> let f_ran = ref false in Lwt.on_termination (Lwt.return_unit) (fun () -> f_ran := true); later (fun () -> !f_ran = true) end; test ~sequential:true "fulfilled, f raises" begin fun () -> let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.on_termination (Lwt.return_unit) (fun () -> raise Exception); later (fun () -> restore (); !saw = Some Exception) end; test "rejected" begin fun () -> let f_ran = ref false in Lwt.on_termination (Lwt.fail Exception) (fun () -> f_ran := true); later (fun () -> !f_ran = true) end; test ~sequential:true "rejected, f raises" begin fun () -> let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.on_termination (Lwt.fail Exit) (fun () -> raise Exception); later (fun () -> restore (); !saw = Some Exception) end; test "pending" begin fun () -> let f_ran = ref false in Lwt.on_termination (fst (Lwt.wait ())) (fun () -> f_ran := true); later (fun () -> !f_ran = false) end; test "pending, fulfilled" begin fun () -> let f_ran = ref false in let p, r = Lwt.wait () in Lwt.on_termination p (fun () -> f_ran := true); Lwt.wakeup r (); later (fun () -> !f_ran = true) end; test ~sequential:true "pending, fulfilled, f raises" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.on_termination p (fun () -> raise Exception); let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.wakeup r (); later (fun () -> restore (); !saw = Some Exception) end; test "pending, rejected" begin fun () -> let f_ran = ref false in let p, r = Lwt.wait () in Lwt.on_termination p (fun () -> f_ran := true); Lwt.wakeup_exn r Exception; later (fun () -> !f_ran = true) end; test ~sequential:true "pending, rejected, f raises" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.on_termination p (fun () -> raise Exception); let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.wakeup_exn r Exit; later (fun () -> restore (); !saw = Some Exception) end; ] let suites = suites @ [on_termination_tests] let on_any_tests = suite "on_any" [ test "fulfilled" begin fun () -> let f_ran = ref false in let g_ran = ref false in Lwt.on_any (Lwt.return_unit) (fun () -> f_ran := true) (fun _ -> g_ran := true); later (fun () -> !f_ran = true && !g_ran = false) end; test ~sequential:true "fulfilled, f raises" begin fun () -> let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.on_any (Lwt.return_unit) (fun () -> raise Exception) ignore; later (fun () -> restore (); !saw = Some Exception) end; test "rejected" begin fun () -> let saw = ref None in (* f can't run due to parametricity. *) Lwt.on_any (Lwt.fail Exception) ignore (fun exn -> saw := Some exn); later (fun () -> !saw = Some Exception) end; test ~sequential:true "rejected, f raises" begin fun () -> let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.on_any (Lwt.fail Exit) ignore (fun _ -> raise Exception); later (fun () -> restore (); !saw = Some Exception) end; test "pending" begin fun () -> let g_ran = ref false in (* f can't run due to parametricity. *) Lwt.on_any (fst (Lwt.wait ())) ignore (fun _ -> g_ran := true); later (fun () -> !g_ran = false) end; test "pending, fulfilled" begin fun () -> let f_ran = ref false in let g_ran = ref false in let p, r = Lwt.wait () in Lwt.on_any p (fun () -> f_ran := true) (fun _ -> g_ran := true); Lwt.wakeup r (); later (fun () -> !f_ran = true && !g_ran = false) end; test ~sequential:true "pending, fulfilled, f raises" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.on_any p (fun () -> raise Exception) ignore; let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.wakeup r (); later (fun () -> restore (); !saw = Some Exception) end; test "pending, rejected" begin fun () -> let saw = ref None in (* f can't run due to parametricity. *) let p, r = Lwt.wait () in Lwt.on_any p ignore (fun exn -> saw := Some exn); Lwt.wakeup_exn r Exception; later (fun () -> !saw = Some Exception) end; test ~sequential:true "pending, rejected, g raises" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.on_any p ignore (fun _ -> raise Exception); let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.wakeup_exn r Exit; later (fun () -> restore (); !saw = Some Exception) end; ] let suites = suites @ [on_any_tests] (* Concurrent composition tests, not including cancellation and sequence-associated storage. Also not including [Lwt.pick] and [Lwt.npick], as those interact with cancellation. *) let async_tests = suite "async" [ test "fulfilled" begin fun () -> let f_ran = ref false in Lwt.async (fun () -> f_ran := true; Lwt.return_unit); later (fun () -> !f_ran = true) end; test ~sequential:true "f raises" begin fun () -> let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.async (fun () -> raise Exception); later (fun () -> restore (); !saw = Some Exception) end; test ~sequential:true "rejected" begin fun () -> let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.async (fun () -> raise Exception); later (fun () -> restore (); !saw = Some Exception) end; test "pending, fulfilled" begin fun () -> let resolved = ref false in let p, r = Lwt.wait () in Lwt.async (fun () -> Lwt.bind p (fun () -> resolved := true; Lwt.return_unit)); Lwt.wakeup r (); later (fun () -> !resolved = true) end; test ~sequential:true "pending, rejected" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.async (fun () -> p); let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.wakeup_exn r Exception; later (fun () -> restore (); !saw = Some Exception) end; ] let suites = suites @ [async_tests] let dont_wait_tests = suite "dont_wait" [ test "fulfilled" begin fun () -> let f_ran = ref false in Lwt.dont_wait (fun () -> f_ran := true; Lwt.return_unit) (fun _ -> ()); later (fun () -> !f_ran = true) end; test "f raises" begin fun () -> let saw = ref None in Lwt.dont_wait (fun () -> raise Exception) (fun exn -> saw := Some exn); later (fun () -> !saw = Some Exception) end; test "rejected" begin fun () -> let saw = ref None in Lwt.dont_wait (fun () -> raise Exception) (fun exn -> saw := Some exn); later (fun () -> !saw = Some Exception) end; test "pending, fulfilled" begin fun () -> let resolved = ref false in let p, r = Lwt.wait () in Lwt.dont_wait (fun () -> Lwt.bind p (fun () -> resolved := true; Lwt.return_unit)) (fun _ -> ()); Lwt.wakeup r (); later (fun () -> !resolved = true) end; test "pending, rejected" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.dont_wait (fun () -> p) (fun exn -> saw := Some exn) ; Lwt.wakeup_exn r Exception; later (fun () -> !saw = Some Exception) end; ] let suites = suites @ [dont_wait_tests] let ignore_result_tests = suite "ignore_result" [ test "fulfilled" begin fun () -> Lwt.ignore_result (Lwt.return_unit); (* Reaching this without an exception is success. *) Lwt.return_true end; test "rejected" begin fun () -> try Lwt.ignore_result (Lwt.fail Exception); Lwt.return_false with Exception -> Lwt.return_true end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in Lwt.ignore_result p; Lwt.wakeup r (); (* Reaching this without process termination is success. *) Lwt.return_true end; test ~sequential:true "pending, rejected" begin fun () -> let saw = ref None in let p, r = Lwt.wait () in Lwt.ignore_result p; let restore = set_async_exception_hook (fun exn -> saw := Some exn) in Lwt.wakeup_exn r Exception; restore (); Lwt.return (!saw = Some Exception) end; ] let suites = suites @ [ignore_result_tests] let join_tests = suite "join" [ test "empty" begin fun () -> let p = Lwt.join [] in state_is (Lwt.Return ()) p end; test "all fulfilled" begin fun () -> let p = Lwt.join [Lwt.return_unit; Lwt.return_unit] in state_is (Lwt.Return ()) p end; test "all rejected" begin fun () -> let p = Lwt.join [Lwt.fail Exception; Lwt.fail Exception] in state_is (Lwt.Fail Exception) p end; test "fulfilled and pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.join [Lwt.return_unit; p] in Lwt.wakeup r (); state_is (Lwt.Return ()) p end; test "rejected and pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.join [Lwt.fail Exception; p] in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p end; test "fulfilled and pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.join [Lwt.return_unit; p] in Lwt.wakeup_exn r Exception; state_is (Lwt.Fail Exception) p end; test "rejected and pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.join [Lwt.fail Exception; p] in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; test "diamond" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.join [p; p] in Lwt.wakeup r (); state_is (Lwt.Return ()) p end; ] let suites = suites @ [join_tests] let list_init i f = Array.init i f |> Array.to_list let all_tests = suite "all" [ test "empty" begin fun () -> let p = Lwt.all [] in state_is (Lwt.Return []) p end; test "all fulfilled (one)" begin fun () -> let p = Lwt.all [Lwt.return 1] in state_is (Lwt.Return [1]) p end; test "all fulfilled (two)" begin fun () -> let p = Lwt.all [Lwt.return 1; Lwt.return 2] in state_is (Lwt.Return [1; 2]) p end; test "all fulfilled (three)" begin fun () -> let p = Lwt.all [Lwt.return 1; Lwt.return 2; Lwt.return 3] in state_is (Lwt.Return [1; 2; 3]) p end; test "all fulfilled (long)" begin fun () -> let p = Lwt.all (list_init 10 Lwt.return) in state_is (Lwt.Return (list_init 10 (fun i->i))) p end; test "all rejected" begin fun () -> let p = Lwt.all [Lwt.fail Exception; Lwt.fail Exception] in state_is (Lwt.Fail Exception) p end; test "fulfilled and pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.all [Lwt.return 1; p] in Lwt.wakeup r 2; state_is (Lwt.Return [1; 2]) p end; test "pending twice physically equal, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.all [p; p] in Lwt.wakeup r 2; state_is (Lwt.Return [2; 2]) p end; test "pending twice physically equal twice, fulfilled" begin fun () -> let p, r = Lwt.wait () in let q, s = Lwt.wait () in let p = Lwt.all [p; p; q; q] in Lwt.wakeup r 2; Lwt.wakeup s 4; state_is (Lwt.Return [2; 2; 4; 4]) p end; test "fulfilled and pending and fulfilled, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.all [Lwt.return 1; p; Lwt.return 3] in Lwt.wakeup r 2; state_is (Lwt.Return [1; 2; 3]) p end; test "fulfilled and pending, fulfilled (long)" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.all (list_init 10 Lwt.return @ [p]) in Lwt.wakeup r 10; state_is (Lwt.Return (list_init 11 (fun x->x))) p end; test "rejected and pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.all [Lwt.fail Exception; p] in Lwt.wakeup r 2; state_is (Lwt.Fail Exception) p end; test "fulfilled and pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.all [Lwt.return 1; p] in Lwt.wakeup_exn r Exception; state_is (Lwt.Fail Exception) p end; test "rejected and pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.all [Lwt.fail Exception; p] in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p end; test "diamond" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.all [p; p] in Lwt.wakeup r 1; state_is (Lwt.Return [1; 1]) p end; ] let suites = suites @ [all_tests] let both_tests = suite "both" [ test "both fulfilled" begin fun () -> let p = Lwt.both (Lwt.return 1) (Lwt.return 2) in state_is (Lwt.Return (1, 2)) p end; test "both rejected" begin fun () -> let p = Lwt.both (Lwt.fail Exception) (Lwt.fail Exit) in state_is (Lwt.Fail Exception) p end; test "rejected, fulfilled" begin fun () -> let p = Lwt.both (Lwt.fail Exception) (Lwt.return 2) in state_is (Lwt.Fail Exception) p end; test "fulfilled, rejected" begin fun () -> let p = Lwt.both (Lwt.return 1) (Lwt.fail Exception) in state_is (Lwt.Fail Exception) p end; test "both pending" begin fun () -> let p = Lwt.both (fst (Lwt.wait ())) (fst (Lwt.wait ())) in state_is Lwt.Sleep p end; test "pending, fulfilled" begin fun () -> let p = Lwt.both (fst (Lwt.wait ())) (Lwt.return 2) in state_is Lwt.Sleep p end; test "pending, rejected" begin fun () -> let p = Lwt.both (fst (Lwt.wait ())) (Lwt.fail Exception) in state_is Lwt.Sleep p end; test "fulfilled, pending" begin fun () -> let p = Lwt.both (Lwt.return 1) (fst (Lwt.wait ())) in state_is Lwt.Sleep p end; test "rejected, pending" begin fun () -> let p = Lwt.both (Lwt.fail Exception) (fst (Lwt.wait ())) in state_is Lwt.Sleep p end; test "pending, fulfilled, then fulfilled" begin fun () -> let p1, r1 = Lwt.wait () in let p = Lwt.both p1 (Lwt.return 2) in Lwt.wakeup_later r1 1; state_is (Lwt.Return (1, 2)) p end; test "pending, rejected, then fulfilled" begin fun () -> let p1, r1 = Lwt.wait () in let p = Lwt.both p1 (Lwt.fail Exception) in Lwt.wakeup_later r1 1; state_is (Lwt.Fail Exception) p end; test "pending, fulfilled, then rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p = Lwt.both p1 (Lwt.return 2) in Lwt.wakeup_later_exn r1 Exception; state_is (Lwt.Fail Exception) p end; test "pending, rejected, then rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p = Lwt.both p1 (Lwt.fail Exception) in Lwt.wakeup_later_exn r1 Exit; state_is (Lwt.Fail Exception) p end; test "fulfilled, pending, then fulfilled" begin fun () -> let p2, r2 = Lwt.wait () in let p = Lwt.both (Lwt.return 1) p2 in Lwt.wakeup_later r2 2; state_is (Lwt.Return (1, 2)) p end; test "rejected, pending, then fulfilled" begin fun () -> let p2, r2 = Lwt.wait () in let p = Lwt.both (Lwt.fail Exception) p2 in Lwt.wakeup_later r2 2; state_is (Lwt.Fail Exception) p end; test "fulfilled, pending, then rejected" begin fun () -> let p2, r2 = Lwt.wait () in let p = Lwt.both (Lwt.return 1) p2 in Lwt.wakeup_later_exn r2 Exception; state_is (Lwt.Fail Exception) p end; test "rejected, pending, then rejected" begin fun () -> let p2, r2 = Lwt.wait () in let p = Lwt.both (Lwt.fail Exception) p2 in Lwt.wakeup_later_exn r2 Exit; state_is (Lwt.Fail Exception) p end; test "pending, then first fulfilled" begin fun () -> let p1, r1 = Lwt.wait () in let p = Lwt.both p1 (fst (Lwt.wait ())) in Lwt.wakeup_later r1 1; state_is Lwt.Sleep p end; test "pending, then first rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p = Lwt.both p1 (fst (Lwt.wait ())) in Lwt.wakeup_later_exn r1 Exception; state_is Lwt.Sleep p end; test "pending, then second fulfilled" begin fun () -> let p2, r2 = Lwt.wait () in let p = Lwt.both (fst (Lwt.wait ())) p2 in Lwt.wakeup_later r2 2; state_is Lwt.Sleep p end; test "pending, then second rejected" begin fun () -> let p2, r2 = Lwt.wait () in let p = Lwt.both (fst (Lwt.wait ())) p2 in Lwt.wakeup_later_exn r2 Exception; state_is Lwt.Sleep p end; test "pending, then first fulfilled, then fulfilled" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.both p1 p2 in Lwt.wakeup_later r1 1; Lwt.wakeup_later r2 2; state_is (Lwt.Return (1, 2)) p end; test "pending, then first fulfilled, then rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.both p1 p2 in Lwt.wakeup_later r1 1; Lwt.wakeup_later_exn r2 Exception; state_is (Lwt.Fail Exception) p end; test "pending, then first rejected, then fulfilled" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.both p1 p2 in Lwt.wakeup_later_exn r1 Exception; Lwt.wakeup_later r2 2; state_is (Lwt.Fail Exception) p end; test "pending, then first rejected, then rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.both p1 p2 in Lwt.wakeup_later_exn r1 Exception; Lwt.wakeup_later_exn r2 Exit; state_is (Lwt.Fail Exception) p end; test "pending, then second fulfilled, then fulfilled" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.both p1 p2 in Lwt.wakeup_later r2 2; Lwt.wakeup_later r1 1; state_is (Lwt.Return (1, 2)) p end; test "pending, then second fulfilled, then rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.both p1 p2 in Lwt.wakeup_later r2 2; Lwt.wakeup_later_exn r1 Exception; state_is (Lwt.Fail Exception) p end; test "pending, then second rejected, then fulfilled" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.both p1 p2 in Lwt.wakeup_later_exn r2 Exception; Lwt.wakeup_later r1 1; state_is (Lwt.Fail Exception) p end; test "pending, then second rejected, then rejected" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.both p1 p2 in Lwt.wakeup_later_exn r2 Exception; Lwt.wakeup_later_exn r1 Exit; state_is (Lwt.Fail Exception) p end; test "diamond" begin fun () -> let p1, r1 = Lwt.wait () in let p = Lwt.both p1 p1 in Lwt.bind (state_is Lwt.Sleep p) (fun was_pending -> Lwt.wakeup_later r1 1; Lwt.bind (state_is (Lwt.Return (1, 1)) p) (fun is_fulfilled -> Lwt.return (was_pending && is_fulfilled))) end; ] let suites = suites @ [both_tests] let choose_tests = suite "choose" [ test "empty" begin fun () -> try ignore (Lwt.choose []); Lwt.return_false with Invalid_argument "Lwt.choose [] would return a \ promise that is pending forever" -> Lwt.return_true end [@ocaml.warning "-52"]; test "fulfilled" begin fun () -> let p = Lwt.choose [fst (Lwt.wait ()); Lwt.return "foo"] in state_is (Lwt.Return "foo") p end; test "rejected" begin fun () -> let p = Lwt.choose [fst (Lwt.wait ()); Lwt.fail Exception] in state_is (Lwt.Fail Exception) p end; test "multiple resolved" begin fun () -> (* This is run in a loop to check that it consistently returns the failed result as per documentation. *) let rec repeat n = n <= 0 || begin let p = Lwt.choose [fst (Lwt.wait ()); Lwt.return "foo"; Lwt.fail Exception; Lwt.return "bar"] in match Lwt.state p with | Lwt.Return "foo" -> false | Lwt.Fail Exception -> repeat (n - 1) | Lwt.Return "bar" -> false | _ -> assert false end [@ocaml.warning "-4"]; in let count = 100 in Lwt.return (repeat count) end; test "pending" begin fun () -> let p = Lwt.choose [fst (Lwt.wait ()); fst (Lwt.wait ())] in state_is Lwt.Sleep p end; test "pending, fulfilled" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p = Lwt.choose [p1; p2] in Lwt.wakeup r1 "foo"; Lwt.wakeup r2 "bar"; state_is (Lwt.Return "foo") p end; test "diamond" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.choose [p; p] in Lwt.wakeup r "foo"; state_is (Lwt.Return "foo") p end; ] let suites = suites @ [choose_tests] let nchoose_tests = suite "nchoose" [ test "empty" begin fun () -> try ignore (Lwt.nchoose []); Lwt.return_false with Invalid_argument "Lwt.nchoose [] would return a \ promise that is pending forever" -> Lwt.return_true end [@ocaml.warning "-52"]; test "all fulfilled" begin fun () -> let p = Lwt.nchoose [Lwt.return "foo"; Lwt.return "bar"] in Lwt.return (Lwt.state p = Lwt.Return ["foo"; "bar"]) end; test "fulfilled, rejected" begin fun () -> let p = Lwt.nchoose [Lwt.return "foo"; Lwt.fail Exception] in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "rejected, fulfilled" begin fun () -> let p = Lwt.nchoose [Lwt.fail Exception; Lwt.return "foo"] in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "some pending" begin fun () -> let p = Lwt.nchoose [Lwt.return "foo"; fst (Lwt.wait ()); Lwt.return "bar"] in Lwt.return (Lwt.state p = Lwt.Return ["foo"; "bar"]) end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.nchoose [fst (Lwt.wait ()); p] in assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return ["foo"]) end; test "pending, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.nchoose [fst (Lwt.wait ()); p] in Lwt.wakeup_exn r Exception; Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "diamond" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.nchoose [p; p] in Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return ["foo"; "foo"]) end; test "diamond, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.nchoose [p; p] in Lwt.wakeup_exn r Exception; Lwt.return (Lwt.state p = Lwt.Fail Exception) end; ] let suites = suites @ [nchoose_tests] let nchoose_split_tests = suite "nchoose_split" [ test "empty" begin fun () -> try ignore (Lwt.nchoose_split []); Lwt.return_false with Invalid_argument "Lwt.nchoose_split [] would return a \ promise that is pending forever" -> Lwt.return_true end [@ocaml.warning "-52"]; test "some fulfilled" begin fun () -> let p = Lwt.nchoose_split [Lwt.return "foo"; fst (Lwt.wait ()); Lwt.return "bar"] in begin match Lwt.state p with | Lwt.Return (["foo"; "bar"], [_]) -> Lwt.return_true | _ -> Lwt.return_false end [@ocaml.warning "-4"] end; test "fulfilled, rejected" begin fun () -> let p = Lwt.nchoose_split [Lwt.return_unit; Lwt.fail Exception] in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "rejected, fulfilled" begin fun () -> let p = Lwt.nchoose_split [Lwt.fail Exception; Lwt.return_unit] in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "pending, rejected" begin fun () -> let p = Lwt.nchoose_split [fst (Lwt.wait ()); Lwt.fail Exception] in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.nchoose_split [p; fst (Lwt.wait ())] in assert (Lwt.state p = Lwt.Sleep); Lwt.wakeup r "foo"; begin match Lwt.state p with | Lwt.Return (["foo"], [_]) -> Lwt.return_true | _ -> Lwt.return_false end [@ocaml.warning "-4"] end; test "pending, rejected 2" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.nchoose_split [p; fst (Lwt.wait ())] in Lwt.wakeup_exn r Exception; Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "diamond" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.nchoose_split [p; p; fst (Lwt.wait ())] in Lwt.wakeup r (); begin match Lwt.state p with | Lwt.Return ([(); ()], [_]) -> Lwt.return_true | _ -> Lwt.return_false end [@ocaml.warning "-4"] end; test "diamond, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.nchoose_split [p; p; fst (Lwt.wait ())] in Lwt.wakeup_exn r Exception; Lwt.return (Lwt.state p = Lwt.Fail Exception) end; ] let suites = suites @ [nchoose_split_tests] (* Tests functions related to [Lwt.state]; [Lwt.state] itself is tested in the preceding sections. *) let state_query_tests = suite "state query" [ test "is_sleeping: fulfilled" begin fun () -> Lwt.return (not @@ Lwt.is_sleeping (Lwt.return_unit)) end; test "is_sleeping: rejected" begin fun () -> Lwt.return (not @@ Lwt.is_sleeping (Lwt.fail Exception)) end; test "is_sleeping: pending" begin fun () -> Lwt.return (Lwt.is_sleeping (fst (Lwt.wait ()))) end; (* This tests an implementation detail. *) test "is_sleeping: proxy" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.wait () in Lwt.bind p1 (fun () -> p2) |> ignore; Lwt.wakeup r (); Lwt.return (Lwt.is_sleeping p2) end; (* This tests an internal API. *) test "poll: fulfilled" begin fun () -> Lwt.return (Lwt.poll (Lwt.return "foo") = Some "foo") end; test "poll: rejected" begin fun () -> try Lwt.poll (Lwt.fail Exception) |> ignore; Lwt.return_false with Exception -> Lwt.return_true end; test "poll: pending" begin fun () -> Lwt.return (Lwt.poll (fst (Lwt.wait ())) = None) end; (* This tests an internal API on an implementation detail... *) test "poll: proxy" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.wait () in Lwt.bind p1 (fun () -> p2) |> ignore; Lwt.wakeup r (); Lwt.return (Lwt.poll p2 = None) end; ] let suites = suites @ [state_query_tests] (* Preceding tests exercised most of [Lwt.wakeup], but here are more checks. *) let wakeup_tests = suite "wakeup" [ test "wakeup_result: nested" begin fun () -> let f_ran = ref false in let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in Lwt.on_success p2 (fun _ -> f_ran := true); Lwt.on_success p1 (fun s -> Lwt.wakeup_result r2 (Result.Ok (s ^ "bar")); assert (Lwt.state p2 = Lwt.Return "foobar"); assert (!f_ran = true)); Lwt.wakeup_result r1 (Result.Ok "foo"); Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Return "foobar") end; ] let suites = suites @ [wakeup_tests] let wakeup_later_tests = suite "wakeup_later" [ test "wakeup_later_result: immediate" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.bind p (fun s -> Lwt.return (s ^ "bar")) in Lwt.wakeup_later_result r (Result.Ok "foo"); state_is (Lwt.Return "foobar") p end; test "wakeup_later: double use on wait" begin fun () -> let _, r = Lwt.wait () in Lwt.wakeup r (); try Lwt.wakeup_later r (); Lwt.return_false with Invalid_argument "Lwt.wakeup_later" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_later: double use on task" begin fun () -> let _, r = Lwt.task () in Lwt.wakeup r (); try Lwt.wakeup_later r (); Lwt.return_false with Invalid_argument "Lwt.wakeup_later" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_later_result: double use on wait" begin fun () -> let _, r = Lwt.wait () in Lwt.wakeup r (); try Lwt.wakeup_later_result r (Result.Ok ()); Lwt.return_false with Invalid_argument "Lwt.wakeup_later_result" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_later_result: double use on task" begin fun () -> let _, r = Lwt.task () in Lwt.wakeup r (); try Lwt.wakeup_later_result r (Result.Ok ()); Lwt.return_false with Invalid_argument "Lwt.wakeup_later_result" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_later_exn: double use on wait" begin fun () -> let _, r = Lwt.wait () in Lwt.wakeup r (); try Lwt.wakeup_later_exn r Exception; Lwt.return_false with Invalid_argument "Lwt.wakeup_later_exn" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_later_exn: double use on task" begin fun () -> let _, r = Lwt.task () in Lwt.wakeup r (); try Lwt.wakeup_later_exn r Exception; Lwt.return_false with Invalid_argument "Lwt.wakeup_later_exn" -> Lwt.return_true end [@ocaml.warning "-52"]; test "wakeup_later_result: nested" begin fun () -> let f_ran = ref false in let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in Lwt.on_success p2 (fun _ -> f_ran := true); Lwt.on_success p1 (fun s -> Lwt.wakeup_later_result r2 (Result.Ok (s ^ "bar")); assert (Lwt.state p2 = Lwt.Return "foobar"); assert (!f_ran = false)); Lwt.wakeup_later_result r1 (Result.Ok "foo"); Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Return "foobar") end; (* Only basic tests for wakeup_later and wakeup_later_exn, as they are implemented in terms of wakeup_later_result. This isn't fully legitimate as a reason, but oh well. *) test "wakeup_later: basic" begin fun () -> let p, r = Lwt.wait () in Lwt.wakeup_later r "foo"; state_is (Lwt.Return "foo") p end; test "wakeup_later_exn: basic" begin fun () -> let p, r = Lwt.wait () in Lwt.wakeup_later_exn r Exception; state_is (Lwt.Fail Exception) p end; ] let suites = suites @ [wakeup_later_tests] (* Cancellation and its interaction with the rest of the API. *) let cancel_tests = suite "cancel" [ test "fulfilled" begin fun () -> let p = Lwt.return_unit in Lwt.cancel p; Lwt.return (Lwt.state p = Lwt.Return ()) end; test "rejected" begin fun () -> let p = Lwt.fail Exception in Lwt.cancel p; Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "wait" begin fun () -> let p, _ = Lwt.wait () in Lwt.cancel p; Lwt.return (Lwt.state p = Lwt.Sleep) end; test "task" begin fun () -> let p, _ = Lwt.task () in Lwt.cancel p; Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled) end; test "callback" begin fun () -> let saw = ref None in let p, _ = Lwt.task () in Lwt.on_failure p (fun exn -> saw := Some exn); Lwt.cancel p; Lwt.return (!saw = Some Lwt.Canceled) end; (* Behaves like wakeup rather than wakeup_later, even though that's probably wrong. Calling cancel in a (functional) loop will cause stack overflow. *) test "nested" begin fun () -> let f_ran = ref false in let p1, _ = Lwt.task () in let p2, _ = Lwt.task () in Lwt.on_failure p2 (fun _ -> f_ran := true); Lwt.on_failure p1 (fun _ -> Lwt.cancel p2; assert (Lwt.state p2 = Lwt.Fail Lwt.Canceled); assert (!f_ran = true)); Lwt.cancel p1; Lwt.return (!f_ran = true && Lwt.state p2 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_tests] let on_cancel_tests = suite "on_cancel" [ test "pending" begin fun () -> let f_ran = ref false in let p, _ = Lwt.task () in Lwt.on_cancel p (fun () -> f_ran := true); assert (!f_ran = false); Lwt.cancel p; Lwt.return (!f_ran = true) end; test "multiple" begin fun () -> let f_ran = ref false in let g_ran = ref false in let h_ran = ref false in let p, _ = Lwt.task () in Lwt.on_cancel p (fun () -> f_ran := true); Lwt.on_cancel p (fun () -> g_ran := true); Lwt.on_cancel p (fun () -> h_ran := true); Lwt.cancel p; Lwt.return (!f_ran = true && !g_ran = true && !h_ran = true) end; test "ordering" begin fun () -> (* Two cancel callbacks to make sure they both run before the ordinary callback. *) let on_cancel_1_ran = ref false in let on_cancel_2_ran = ref false in let callback_ran = ref false in let p, _ = Lwt.task () in Lwt.on_cancel p (fun () -> on_cancel_1_ran := true); Lwt.on_failure p (fun _ -> assert (!on_cancel_1_ran = true); assert (!on_cancel_2_ran = true); callback_ran := true); Lwt.on_cancel p (fun () -> on_cancel_2_ran := true); Lwt.cancel p; Lwt.return (!callback_ran = true) end; test "fulfilled" begin fun () -> let f_ran = ref false in Lwt.on_cancel (Lwt.return_unit) (fun () -> f_ran := true); Lwt.return (!f_ran = false) end; test "rejected" begin fun () -> let f_ran = ref false in Lwt.on_cancel (Lwt.fail Exception) (fun () -> f_ran := true); Lwt.return (!f_ran = false) end; test "already canceled" begin fun () -> let f_ran = ref false in Lwt.on_cancel (Lwt.fail Lwt.Canceled) (fun () -> f_ran := true); Lwt.return (!f_ran = true) end; (* More generally, this tests that rejecting with [Lwt.Canceled] is equivalent to calling [Lwt.cancel]. The difference is that [Lwt.cancel] can be called on promises without the need of a resolver. *) test "reject with Canceled" begin fun () -> let f_ran = ref false in let p, r = Lwt.wait () in Lwt.on_cancel p (fun () -> f_ran := true); Lwt.wakeup_exn r Lwt.Canceled; Lwt.return (!f_ran = true) end; ] let suites = suites @ [on_cancel_tests] let protected_tests = suite "protected" [ test "fulfilled" begin fun () -> let p = Lwt.protected (Lwt.return_unit) in (* If [p] starts fulfilled, it can't be canceled. *) Lwt.return (Lwt.state p = Lwt.Return ()) end; test "rejected" begin fun () -> let p = Lwt.protected (Lwt.fail Exception) in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "pending" begin fun () -> let p, _ = Lwt.task () in let p' = Lwt.protected p in Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.task () in let p' = Lwt.protected p in Lwt.wakeup r "foo"; Lwt.return (Lwt.state p' = Lwt.Return "foo") end; test "pending, canceled" begin fun () -> let p, _ = Lwt.task () in let p' = Lwt.protected p in Lwt.cancel p'; Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; test "pending, canceled, fulfilled" begin fun () -> let p, r = Lwt.task () in let p' = Lwt.protected p in Lwt.cancel p'; Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; (* Implementation detail: [p' = Lwt.protected _] can still be resolved if it becomes a proxy. *) test "pending, proxy" begin fun () -> let p1, r1 = Lwt.task () in let p2 = Lwt.protected p1 in (* Make p2 a proxy for p4; p3 is just needed to suspend the bind, in order to callback the code that makes p2 a proxy. *) let p3, r3 = Lwt.wait () in let _ = Lwt.bind p3 (fun () -> p2) in Lwt.wakeup r3 (); (* It should now be possible to resolve p2 by resolving p1. *) Lwt.wakeup r1 "foo"; Lwt.return (Lwt.state p2 = Lwt.Return "foo") end; ] let suites = suites @ [protected_tests] let cancelable_tests = suite "wrap_in_cancelable" [ test "fulfilled" begin fun () -> let p = Lwt.wrap_in_cancelable (Lwt.return_unit) in Lwt.return (Lwt.state p = Lwt.Return ()) end; test "rejected" begin fun () -> let p = Lwt.wrap_in_cancelable (Lwt.fail Exception) in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "pending(task)" begin fun () -> let p, _ = Lwt.task () in let p' = Lwt.wrap_in_cancelable p in Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; test "pending(task), fulfilled" begin fun () -> let p, r = Lwt.task () in let p' = Lwt.wrap_in_cancelable p in Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Return "foo") end; test "pending(task), canceled" begin fun () -> let p, _ = Lwt.task () in let p' = Lwt.wrap_in_cancelable p in Lwt.cancel p'; Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; test "pending(wait)" begin fun () -> let p, _ = Lwt.wait () in let p' = Lwt.wrap_in_cancelable p in Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; test "pending(wait), fulfilled" begin fun () -> let p, r = Lwt.wait () in let p' = Lwt.wrap_in_cancelable p in Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Return "foo") end; test "pending(wait), canceled" begin fun () -> let p, _ = Lwt.wait () in let p' = Lwt.wrap_in_cancelable p in Lwt.cancel p'; Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; test "pending(task), canceled, fulfilled" begin fun () -> let p, r = Lwt.task () in let p' = Lwt.wrap_in_cancelable p in Lwt.cancel p'; Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; test "pending(wait), canceled, fulfilled" begin fun () -> let p, r = Lwt.wait () in let p' = Lwt.wrap_in_cancelable p in Lwt.cancel p'; Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return "foo" && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; (* Implementation detail: [p' = Lwt.wrap_in_cancelable _] can still be resolved if it becomes a proxy. *) test "pending, proxy" begin fun () -> let p1, r1 = Lwt.task () in let p2 = Lwt.wrap_in_cancelable p1 in (* Make p2 a proxy for p4; p3 is just needed to suspend the bind, in order to callback the code that makes p2 a proxy. *) let p3, r3 = Lwt.wait () in let _ = Lwt.bind p3 (fun () -> p2) in Lwt.wakeup r3 (); (* It should now be possible to resolve p2 by resolving p1. *) Lwt.wakeup r1 "foo"; Lwt.return (Lwt.state p2 = Lwt.Return "foo") end; ] let suites = suites @ [cancelable_tests] let no_cancel_tests = suite "no_cancel" [ test "fulfilled" begin fun () -> let p = Lwt.no_cancel (Lwt.return_unit) in (* [p] starts fulfilled, so it can't be canceled. *) Lwt.return (Lwt.state p = Lwt.Return ()) end; test "rejected" begin fun () -> let p = Lwt.no_cancel (Lwt.fail Exception) in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "pending" begin fun () -> let p, _ = Lwt.task () in let p' = Lwt.no_cancel p in Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; test "pending, fulfilled" begin fun () -> let p, r = Lwt.task () in let p = Lwt.no_cancel p in Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return "foo") end; test "pending, cancel attempt" begin fun () -> let p, _ = Lwt.task () in let p' = Lwt.no_cancel p in Lwt.cancel p'; Lwt.return (Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; ] let suites = suites @ [no_cancel_tests] let resolve_already_canceled_promise_tests = suite "resolve canceled" [ test "wakeup: canceled" begin fun () -> let p, r = Lwt.task () in Lwt.cancel p; Lwt.wakeup r (); Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled) end; (* This test can start falsely passing if the entire test is run inside an Lwt promise resolution phase, e.g. inside an outer [Lwt.wakeup_later]. *) test "wakeup_later: canceled" begin fun () -> let p, r = Lwt.task () in Lwt.cancel p; Lwt.wakeup_later r (); Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [resolve_already_canceled_promise_tests] let pick_tests = suite "pick" [ test "empty" begin fun () -> try ignore (Lwt.pick []); Lwt.return_false with Invalid_argument "Lwt.pick [] would return a \ promise that is pending forever" -> Lwt.return_true end [@ocaml.warning "-52"]; test "fulfilled" begin fun () -> let p1, _ = Lwt.task () in let p2 = Lwt.pick [p1; Lwt.return "foo"] in Lwt.return (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p2 = Lwt.Return "foo") end; test "rejected" begin fun () -> let p1, _ = Lwt.task () in let p2 = Lwt.pick [p1; Lwt.fail Exception] in Lwt.return (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p2 = Lwt.Fail Exception) end; test "multiple resolved" begin fun () -> (* This is run in a loop to check that it consistently returns the failed result as per documentation. *) let rec repeat n = n <= 0 || begin let (waiter, _) = Lwt.task () in let p = Lwt.pick [waiter; Lwt.return "foo"; Lwt.fail Exception; Lwt.return "bar"] in match Lwt.state p with | Lwt.Return "foo" -> false | Lwt.Fail Exception -> Lwt.state waiter = Lwt.Fail Lwt.Canceled && repeat (n - 1) | Lwt.Return "bar" -> false | _ -> assert false end [@ocaml.warning "-4"]; in let count = 100 in Lwt.return (repeat count) end; test "pending" begin fun () -> let p = Lwt.pick [fst (Lwt.wait ()); fst (Lwt.wait ())] in Lwt.return (Lwt.state p = Lwt.Sleep) end; test "pending, fulfilled" begin fun () -> let p1, r1 = Lwt.task () in let p2, _ = Lwt.task () in let p = Lwt.pick [p1; p2] in Lwt.wakeup r1 "foo"; Lwt.return (Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p = Lwt.Return "foo") end; test "diamond" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.pick [p; p] in Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return "foo") end; test "pending, canceled" begin fun () -> let p1, _ = Lwt.task () in let p2, _ = Lwt.task () in let p = Lwt.pick [p1; p2] in Lwt.cancel p; Lwt.return (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p2 = Lwt.Fail Lwt.Canceled) end; test "cancellation/resolution order" begin fun () -> let a = [|0; 0|] in let i = ref 0 in let p1, r1 = Lwt.task () in let p2, _ = Lwt.task () in let p3 = Lwt.pick [p1; p2] in let _ = Lwt.catch (fun () -> p2) (fun _ -> a.(!i) <- 1; i := 1; Lwt.return_unit) in let _ = Lwt.bind p3 (fun _ -> a.(!i) <- 2; i := 1; Lwt.return_unit) in Lwt.wakeup_later r1 (); Lwt.return (a.(0) = 1 && a.(1) = 2) end; ] let suites = suites @ [pick_tests] let npick_tests = suite "npick" [ test "empty" begin fun () -> try ignore (Lwt.npick []); Lwt.return_false with Invalid_argument "Lwt.npick [] would return a \ promise that is pending forever" -> Lwt.return_true end [@ocaml.warning "-52"]; test "all fulfilled" begin fun () -> let p = Lwt.npick [Lwt.return "foo"; Lwt.return "bar"] in Lwt.return (Lwt.state p = Lwt.Return ["foo"; "bar"]) end; test "fulfilled, rejected" begin fun () -> let p = Lwt.npick [Lwt.return "foo"; Lwt.fail Exception] in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "rejected, fulfilled" begin fun () -> let p = Lwt.npick [Lwt.fail Exception; Lwt.return "foo"] in Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "some pending" begin fun () -> let p1, _ = Lwt.task () in let p2 = Lwt.npick [Lwt.return "foo"; p1; Lwt.return "bar"] in Lwt.return (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p2 = Lwt.Return ["foo"; "bar"]) end; test "pending" begin fun () -> let p = Lwt.npick [fst (Lwt.task ()); fst (Lwt.task ())] in Lwt.return (Lwt.state p = Lwt.Sleep) end; test "pending, fulfilled" begin fun () -> let p1, _ = Lwt.task () in let p2, r = Lwt.task () in let p = Lwt.npick [p1; p2] in Lwt.wakeup r "foo"; Lwt.return (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p = Lwt.Return ["foo"]) end; test "pending, rejected" begin fun () -> let p1, _ = Lwt.task () in let p2, r = Lwt.task () in let p = Lwt.npick [p1; p2] in Lwt.wakeup_exn r Exception; Lwt.return (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p = Lwt.Fail Exception) end; test "diamond" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.npick [p; p] in Lwt.wakeup r "foo"; Lwt.return (Lwt.state p = Lwt.Return ["foo"; "foo"]) end; test "diamond, rejected" begin fun () -> let p, r = Lwt.wait () in let p = Lwt.npick [p; p] in Lwt.wakeup_exn r Exception; Lwt.return (Lwt.state p = Lwt.Fail Exception) end; test "pending, canceled" begin fun () -> let p1, _ = Lwt.task () in let p2, _ = Lwt.task () in let p = Lwt.npick [p1; p2] in Lwt.cancel p; Lwt.return (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p2 = Lwt.Fail Lwt.Canceled) end; test "cancellation/resolution order" begin fun () -> let a = [|0; 0|] in let i = ref 0 in let p1, r1 = Lwt.task () in let p2, _ = Lwt.task () in let p3 = Lwt.npick [p1; p2] in let _ = Lwt.catch (fun () -> p2) (fun _ -> a.(!i) <- 1; i := 1; Lwt.return_unit) in let _ = Lwt.bind p3 (fun _ -> a.(!i) <- 2; i := 1; Lwt.return_unit) in Lwt.wakeup_later r1 (); Lwt.return (a.(0) = 1 && a.(1) = 2) end; ] let suites = suites @ [npick_tests] let cancel_bind_tests = suite "cancel bind" [ test "wait, pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.wait () in let p' = Lwt.bind p (fun () -> f_ran := true; Lwt.return_unit) in Lwt.cancel p'; Lwt.return (!f_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; test "task, pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.task () in let p' = Lwt.bind p (fun () -> f_ran := true; Lwt.return_unit) in Lwt.cancel p'; Lwt.return (!f_ran = false && Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; test "pending, wait, canceled" begin fun () -> let p, r = Lwt.wait () in let p', _ = Lwt.wait () in let p'' = Lwt.bind p (fun () -> p') in Lwt.wakeup r (); (* [bind]'s [f] ran, and now [p'] and [p''] should share the same state. *) Lwt.cancel p''; Lwt.return (Lwt.state p' = Lwt.Sleep && Lwt.state p'' = Lwt.Sleep) end; test "pending, task, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.bind p1 (fun () -> p2) in Lwt.wakeup r (); Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled && p2 != p3) end; test "pending, task, canceled, chain" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.bind p1 (fun () -> p2) in let p4 = Lwt.bind p1 (fun () -> p3) in Lwt.wakeup r (); (* At this point, [p4] and [p3] share the same state, and canceling [p4] should chain to [p2], because [p3] is obtained by binding on [p2]. *) Lwt.cancel p4; Lwt.return (Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled && Lwt.state p4 = Lwt.Fail Lwt.Canceled) end; test "pending, on_cancel callbacks" begin fun () -> let f_ran = ref false in let g_ran = ref false in let p1, _ = Lwt.task () in let p2 = Lwt.bind (fst (Lwt.task ())) (fun () -> p1) in Lwt.on_cancel p1 (fun () -> f_ran := true); Lwt.on_cancel p2 (fun () -> g_ran := true); Lwt.cancel p2; (* Canceling [p2] doesn't cancel [p1], because the function passed to [Lwt.bind] never ran. *) Lwt.return (!f_ran = false && !g_ran = true) end; test "pending, fulfilled, on_cancel callbacks" begin fun () -> let f_ran = ref false in let g_ran = ref false in let p1, r = Lwt.task () in let p2, _ = Lwt.task () in let p3 = Lwt.bind p1 (fun () -> p2) in Lwt.on_cancel p2 (fun () -> f_ran := true); Lwt.on_cancel p3 (fun () -> g_ran := true); Lwt.wakeup r (); Lwt.cancel p3; (* Canceling [p3] cancels [p2], because the function passed to [Lwt.bind] did run, and evaluated to [p2]. *) Lwt.return (!f_ran = true && !g_ran = true) end; ] let suites = suites @ [cancel_bind_tests] let cancel_map_tests = suite "cancel map" [ test "wait, pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.wait () in let p' = Lwt.map (fun () -> f_ran := true) p in Lwt.cancel p'; Lwt.return (!f_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; test "task, pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.task () in let p' = Lwt.map (fun () -> f_ran := true) p in Lwt.cancel p'; Lwt.return (!f_ran = false && Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_map_tests] let cancel_catch_tests = suite "cancel catch" [ (* In [p' = Lwt.catch (fun () -> p) f], if [p] is not cancelable, [p'] is also not cancelable. *) test "wait, pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.wait () in let p' = Lwt.catch (fun () -> p) (fun _ -> f_ran := true; Lwt.return_unit) in Lwt.cancel p'; Lwt.return (!f_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; (* In [p' = Lwt.catch (fun () -> p) f], if [p] is cancelable, canceling [p'] propagates to [p], and then the cancellation exception can be "intercepted" by [f], which can resolve [p'] in an arbitrary way. *) test "task, pending, canceled" begin fun () -> let saw = ref None in let p, _ = Lwt.task () in let p' = Lwt.catch (fun () -> p) (fun exn -> saw := Some exn; Lwt.return "foo") in Lwt.cancel p'; Lwt.return (!saw = Some Lwt.Canceled && Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Return "foo") end; (* In [p' = Lwt.catch (fun () -> p) f], if [p] is cancelable, and cancel callbacks are added to both [p] and [p'], and [f] does not resolve [p'] with [Lwt.Fail Lwt.Canceled], only the callback on [p] runs. *) test "task, pending, canceled, on_cancel, intercepted" begin fun () -> let on_cancel_1_ran = ref false in let on_cancel_2_ran = ref false in let p, _ = Lwt.task () in let p' = Lwt.catch (fun () -> p) (fun _ -> assert (!on_cancel_1_ran = true && !on_cancel_2_ran = false); Lwt.return "foo") in Lwt.on_cancel p (fun () -> on_cancel_1_ran := true); Lwt.on_cancel p' (fun () -> on_cancel_2_ran := true); Lwt.cancel p'; Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Return "foo" && !on_cancel_2_ran = false) end; (* Same as above, except this time, cancellation is passed on to the outer promise, so we can expect both cancel callbacks to run. *) test "task, pending, canceled, on_cancel, forwarded" begin fun () -> let on_cancel_2_ran = ref false in let p, _ = Lwt.task () in let p' = Lwt.catch (fun () -> p) Lwt.reraise in Lwt.on_cancel p' (fun () -> on_cancel_2_ran := true); Lwt.cancel p'; Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Fail Lwt.Canceled && !on_cancel_2_ran = true) end; (* (2 tests) If the handler passed to [Lwt.catch] already ran, canceling the outer promise is the same as canceling the promise returned by the handler. *) test "pending, wait, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.catch (fun () -> p1) (fun _ -> p2) in Lwt.wakeup_exn r Exception; Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "pending, task, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.catch (fun () -> p1) (fun _ -> p2) in Lwt.wakeup_exn r Exception; Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_catch_tests] let cancel_try_bind_tests = suite "cancel try_bind" [ test "wait, pending, canceled" begin fun () -> let f_or_g_ran = ref false in let p, _ = Lwt.wait () in let p' = Lwt.try_bind (fun () -> p) (fun () -> f_or_g_ran := true; Lwt.return_unit) (fun _ -> f_or_g_ran := true; Lwt.return_unit) in Lwt.cancel p'; Lwt.return (!f_or_g_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; test "task, pending, canceled" begin fun () -> let f_ran = ref false in let saw = ref None in let p, _ = Lwt.task () in let p' = Lwt.try_bind (fun () -> p) (fun () -> f_ran := true; Lwt.return "foo") (fun exn -> saw := Some exn; Lwt.return "bar") in Lwt.cancel p'; Lwt.return (!f_ran = false && !saw = Some Lwt.Canceled && Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Return "bar") end; test "pending, fulfilled, wait, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.try_bind (fun () -> p1) (fun () -> p2) (fun _ -> Lwt.return "foo") in Lwt.wakeup r (); Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "pending, fulfilled, task, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.try_bind (fun () -> p1) (fun () -> p2) (fun _ -> Lwt.return "foo") in Lwt.wakeup r (); Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; test "pending, rejected, wait, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.try_bind (fun () -> p1) (fun () -> Lwt.return "foo") (fun _ -> p2) in Lwt.wakeup_exn r Exception; Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "pending, rejected, task, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.try_bind (fun () -> p1) (fun () -> Lwt.return "foo") (fun _ -> p2) in Lwt.wakeup_exn r Exception; Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_try_bind_tests] let cancel_finalize_tests = suite "cancel finalize" [ test "wait, pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.wait () in let p' = Lwt.finalize (fun () -> p) (fun () -> f_ran := true; Lwt.return_unit) in Lwt.cancel p'; Lwt.return (!f_ran = false && Lwt.state p = Lwt.Sleep && Lwt.state p' = Lwt.Sleep) end; test "task, pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.task () in let p' = Lwt.finalize (fun () -> p) (fun () -> f_ran := true; Lwt.return_unit) in Lwt.cancel p'; Lwt.return (!f_ran = true && Lwt.state p = Lwt.Fail Lwt.Canceled && Lwt.state p' = Lwt.Fail Lwt.Canceled) end; test "task, canceled, cancel exception replaced" begin fun () -> let p, _ = Lwt.task () in let p' = Lwt.finalize (fun () -> p) (fun () -> Lwt.fail Exception) in Lwt.cancel p; Lwt.return (Lwt.state p' = Lwt.Fail Exception) end; test "pending, wait, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.finalize (fun () -> p1) (fun () -> p2) in Lwt.wakeup r (); Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "pending, task, canceled" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.finalize (fun () -> p1) (fun () -> p2) in Lwt.wakeup r (); Lwt.cancel p3; Lwt.return (Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_finalize_tests] let cancel_direct_handler_tests = suite "cancel with direct handler" [ test "on_success: pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.task () in Lwt.on_success p (fun () -> f_ran := true); Lwt.cancel p; Lwt.return (!f_ran = false) end; test "on_failure: pending, canceled" begin fun () -> let saw = ref None in let p, _ = Lwt.task () in Lwt.on_failure p (fun exn -> saw := Some exn); Lwt.cancel p; Lwt.return (!saw = Some Lwt.Canceled) end; test "on_termination: pending, canceled" begin fun () -> let f_ran = ref false in let p, _ = Lwt.task () in Lwt.on_termination p (fun () -> f_ran := true); Lwt.cancel p; Lwt.return (!f_ran = true) end; test "on_any: pending, canceled" begin fun () -> let f_ran = ref false in let saw = ref None in let p, _ = Lwt.task () in Lwt.on_any p (fun () -> f_ran := true) (fun exn -> saw := Some exn); Lwt.cancel p; Lwt.return (!f_ran = false && !saw = Some Lwt.Canceled) end; ] let suites = suites @ [cancel_direct_handler_tests] let cancel_join_tests = suite "cancel join" [ test "wait, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.join [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "task, pending, cancel" begin fun () -> let p1, _ = Lwt.task () in let p2, _ = Lwt.task () in let p3 = Lwt.join [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Fail Lwt.Canceled && Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; test "wait and task, pending, cancel" begin fun () -> let p1, r = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.join [p1; p2] in Lwt.cancel p3; assert (Lwt.state p1 = Lwt.Sleep); assert (Lwt.state p2 = Lwt.Fail Lwt.Canceled); assert (Lwt.state p3 = Lwt.Sleep); Lwt.wakeup r (); Lwt.return (Lwt.state p1 = Lwt.Return () && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; (* In [p' = Lwt.join [p; p]], if [p'] is canceled, the cancel handler on [p] is called only once, even though it is reachable by two paths in the cancellation graph. *) test "cancel diamond" begin fun () -> let ran = ref 0 in let p, _ = Lwt.task () in let p' = Lwt.join [p; p] in Lwt.on_cancel p (fun () -> ran := !ran + 1); Lwt.cancel p'; Lwt.return (!ran = 1) end; ] let suites = suites @ [cancel_join_tests] let cancel_choose_tests = suite "cancel choose" [ test "wait, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.choose [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "wait and task, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.choose [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_choose_tests] let cancel_pick_tests = suite "cancel pick" [ test "wait, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.pick [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "wait and task, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.pick [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_pick_tests] let cancel_nchoose_tests = suite "cancel nchoose" [ test "wait, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.nchoose [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "wait and task, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.nchoose [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_nchoose_tests] let cancel_npick_tests = suite "cancel npick" [ test "wait, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.npick [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "wait and task, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.npick [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_npick_tests] let cancel_nchoose_split_tests = suite "cancel nchoose_split" [ test "wait, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = Lwt.nchoose_split [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Sleep && Lwt.state p3 = Lwt.Sleep) end; test "wait and task, pending, cancel" begin fun () -> let p1, _ = Lwt.wait () in let p2, _ = Lwt.task () in let p3 = Lwt.nchoose_split [p1; p2] in Lwt.cancel p3; Lwt.return (Lwt.state p1 = Lwt.Sleep && Lwt.state p2 = Lwt.Fail Lwt.Canceled && Lwt.state p3 = Lwt.Fail Lwt.Canceled) end; ] let suites = suites @ [cancel_nchoose_split_tests] (* Sequence-associated storage, and its interaction with the rest of the API. *) let storage_tests = suite "storage" [ test "initial" begin fun () -> let key = Lwt.new_key () in Lwt.return (Lwt.get key = None) end; test "store, retrieve" begin fun () -> let key = Lwt.new_key () in Lwt.with_value key (Some 42) (fun () -> Lwt.return (Lwt.get key = Some 42)) end; test "store, restore" begin fun () -> let key = Lwt.new_key () in Lwt.with_value key (Some 42) ignore; Lwt.return (Lwt.get key = None) end; test "store, f raises, restore" begin fun () -> let key = Lwt.new_key () in try Lwt.with_value key (Some 42) (fun () -> raise Exception) |> ignore; Lwt.return_false with Exception -> Lwt.return (Lwt.get key = None) end; test "store, overwrite, retrieve" begin fun () -> let key = Lwt.new_key () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.return (Lwt.get key = Some 1337))) end; test "store, blank, retrieve" begin fun () -> let key = Lwt.new_key () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key None (fun () -> Lwt.return (Lwt.get key = None))) end; test "distinct keys" begin fun () -> let key1 = Lwt.new_key () in let key2 = Lwt.new_key () in Lwt.with_value key1 (Some 42) (fun () -> Lwt.return (Lwt.get key2 = None)) end; test "bind" begin fun () -> let key = Lwt.new_key () in let f = fun () -> Lwt.return (Lwt.get key) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> let p' = Lwt.with_value key (Some 1337) (fun () -> Lwt.bind p f) in Lwt.wakeup r (); Lwt.return (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42)) end; test "map" begin fun () -> let key = Lwt.new_key () in let f = fun () -> Lwt.get key in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> let p' = Lwt.with_value key (Some 1337) (fun () -> Lwt.map f p) in Lwt.wakeup r (); Lwt.return (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42)) end; test "catch" begin fun () -> let key = Lwt.new_key () in let f = fun _ -> Lwt.return (Lwt.get key) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> let p' = Lwt.with_value key (Some 1337) (fun () -> Lwt.catch (fun () -> p) f) in Lwt.wakeup_exn r Exception; Lwt.return (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42)) end; test "try_bind, fulfilled" begin fun () -> let key = Lwt.new_key () in let f = fun () -> Lwt.return (Lwt.get key) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> let p' = Lwt.with_value key (Some 1337) (fun () -> Lwt.try_bind (fun () -> p) f Lwt.reraise) in Lwt.wakeup r (); Lwt.return (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42)) end; test "try_bind, rejected" begin fun () -> let key = Lwt.new_key () in let f = fun _ -> Lwt.return (Lwt.get key) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> let p' = Lwt.with_value key (Some 1337) (fun () -> Lwt.try_bind (fun () -> p) Lwt.return f) in Lwt.wakeup_exn r Exception; Lwt.return (Lwt.state p' = Lwt.Return (Some 1337) && Lwt.get key = Some 42)) end; test "finalize" begin fun () -> let key = Lwt.new_key () in let f = fun () -> assert (Lwt.get key = Some 1337); Lwt.return_unit in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.finalize (fun () -> p) f) |> ignore; Lwt.wakeup r (); Lwt.return (Lwt.get key = Some 42)) end; test "on_success" begin fun () -> let key = Lwt.new_key () in let f = fun () -> assert (Lwt.get key = Some 1337) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.on_success p f); Lwt.wakeup r (); Lwt.return (Lwt.get key = Some 42)) end; test "on_failure" begin fun () -> let key = Lwt.new_key () in let f = fun _ -> assert (Lwt.get key = Some 1337) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.on_failure p f); Lwt.wakeup_exn r Exception; Lwt.return (Lwt.get key = Some 42)) end; test "on_termination, fulfilled" begin fun () -> let key = Lwt.new_key () in let f = fun () -> assert (Lwt.get key = Some 1337) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.on_termination p f); Lwt.wakeup r (); Lwt.return (Lwt.get key = Some 42)) end; test "on_termination, rejected" begin fun () -> let key = Lwt.new_key () in let f = fun () -> assert (Lwt.get key = Some 1337) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.on_termination p f); Lwt.wakeup_exn r Exception; Lwt.return (Lwt.get key = Some 42)) end; test "on_any, fulfilled" begin fun () -> let key = Lwt.new_key () in let f = fun () -> assert (Lwt.get key = Some 1337) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.on_any p f ignore); Lwt.wakeup r (); Lwt.return (Lwt.get key = Some 42)) end; test "on_any, rejected" begin fun () -> let key = Lwt.new_key () in let f = fun _ -> assert (Lwt.get key = Some 1337) in let p, r = Lwt.wait () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.on_any p ignore f); Lwt.wakeup r (); Lwt.return (Lwt.get key = Some 42)) end; test "on_cancel" begin fun () -> let key = Lwt.new_key () in let f = fun () -> assert (Lwt.get key = Some 1337) in let p, _ = Lwt.task () in Lwt.with_value key (Some 42) (fun () -> Lwt.with_value key (Some 1337) (fun () -> Lwt.on_cancel p f); Lwt.cancel p; Lwt.return (Lwt.get key = Some 42)) end; ] let suites = suites @ [storage_tests] (* These basically just test that the infix operators are exposed in the API, and are defined "more or less" as they should be. *) let infix_operator_tests = suite "infix operators" [ test ">>=" begin fun () -> let open Lwt.Infix in let p, r = Lwt.wait () in let p' = p >>= (fun s -> Lwt.return (s ^ "bar")) in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p' end; test "=<<" begin fun () -> let open Lwt.Infix in let p, r = Lwt.wait () in let p' = (fun s -> Lwt.return (s ^ "bar")) =<< p in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p' end; test ">|=" begin fun () -> let open Lwt.Infix in let p, r = Lwt.wait () in let p' = p >|= (fun s -> s ^ "bar") in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p' end; test "=|<" begin fun () -> let open Lwt.Infix in let p, r = Lwt.wait () in let p' = (fun s -> s ^ "bar") =|< p in Lwt.wakeup r "foo"; state_is (Lwt.Return "foobar") p' end; test "<&>" begin fun () -> let open Lwt.Infix in let p, r = Lwt.wait () in let p' = p <&> Lwt.return_unit in Lwt.wakeup r (); state_is (Lwt.Return ()) p' end; test "" begin fun () -> let open Lwt.Infix in let p1, r = Lwt.wait () in let p2, _ = Lwt.wait () in let p3 = p1 p2 in Lwt.wakeup r (); state_is (Lwt.Return ()) p3 end; ] let suites = suites @ [infix_operator_tests] (* Like the infix operator tests, these just check that the necessary functions exist in Lwt.Infix.Let_syntax, and do roughly what they should. We are not testing the full syntax to avoid large dependencies for the test suite. *) let ppx_let_tests = suite "ppx_let" [ test "return" begin fun () -> let p = Lwt.Let_syntax.Let_syntax.return () in state_is (Lwt.Return ()) p end; test "map" begin fun () -> let p = Lwt.Let_syntax.Let_syntax.map (Lwt.return 1) ~f:(fun x -> x + 1) in state_is (Lwt.Return 2) p end; test "bind" begin fun () -> let p = Lwt.Let_syntax.Let_syntax.bind (Lwt.return 1) ~f:(fun x -> Lwt.return (x + 1)) in state_is (Lwt.Return 2) p end; test "both" begin fun () -> let p = Lwt.both (Lwt.return 1) (Lwt.return 2) in state_is (Lwt.Return (1, 2)) p end; test "Open_on_rhs" begin fun () -> let module Local = struct module type Empty = sig end end in let x : (module Local.Empty) = (module Lwt.Let_syntax.Let_syntax.Open_on_rhs) in ignore x; Lwt.return_true end; ] let suites = suites @ [ppx_let_tests] let let_syntax_tests = suite "let syntax" [ test "let*" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p' = let open Lwt.Syntax in let* s1 = p1 in let* s2 = p2 in Lwt.return (s1 ^ s2) in Lwt.wakeup r1 "foo"; Lwt.wakeup r2 "bar"; state_is (Lwt.Return "foobar") p' end; test "and*" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p' = let open Lwt.Syntax in let* s1 = p1 and* s2 = p2 in Lwt.return (s1 ^ s2) in Lwt.wakeup r1 "foo"; Lwt.wakeup r2 "bar"; state_is (Lwt.Return "foobar") p' end; test "let+/and+" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p' = let open Lwt.Syntax in let+ s1 = p1 and+ s2 = p2 in (s1 ^ s2) in Lwt.wakeup r1 "foo"; Lwt.wakeup r2 "bar"; state_is (Lwt.Return "foobar") p' end; ] let suites = suites @ [let_syntax_tests] (* Tests for [Lwt.add_task_l] and [Lwt.add_task_r]. *) let lwt_sequence_contains sequence list = let step item ((contains_so_far, list_tail) as state) = if not contains_so_far then state else match list_tail with | item'::rest -> item == item', rest | [] -> failwith "Sequence and list not of the same length" in fst (Lwt_sequence.fold_l step sequence (true, list)) let lwt_sequence_tests = suite "add_task_l and add_task_r" [ test "add_task_r" begin fun () -> let sequence = Lwt_sequence.create () in let p = (Lwt.add_task_r [@ocaml.warning "-3"]) sequence in let p' = (Lwt.add_task_r [@ocaml.warning "-3"]) sequence in assert (Lwt.state p = Lwt.Sleep); assert (lwt_sequence_contains sequence [Obj.magic p; Obj.magic p']); Lwt.cancel p; Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled && lwt_sequence_contains sequence [Obj.magic p']) end; test "add_task_l" begin fun () -> let sequence = Lwt_sequence.create () in let p = (Lwt.add_task_l [@ocaml.warning "-3"]) sequence in let p' = (Lwt.add_task_l [@ocaml.warning "-3"]) sequence in assert (Lwt.state p = Lwt.Sleep); assert (lwt_sequence_contains sequence [Obj.magic p'; Obj.magic p]); Lwt.cancel p; Lwt.return (Lwt.state p = Lwt.Fail Lwt.Canceled && lwt_sequence_contains sequence [Obj.magic p']) end; ] let suites = suites @ [lwt_sequence_tests] let pause_tests = suite "pause" [ test "initial state" begin fun () -> Lwt.return (Lwt.paused_count () = 0) end; test "one promise" begin fun () -> let p = Lwt.pause () in assert (Lwt.paused_count () = 1); Lwt.bind (state_is Lwt.Sleep p) (fun initial_state_correct -> Lwt.wakeup_paused (); assert (Lwt.paused_count () = 0); Lwt.bind (state_is (Lwt.Return ()) p) (fun final_state_correct -> Lwt.return (initial_state_correct && final_state_correct))) end; test "multiple promises" begin fun () -> let p1 = Lwt.pause () in let p2 = Lwt.pause () in assert (Lwt.paused_count () = 2); Lwt.bind (state_is Lwt.Sleep p1) (fun initial_state_correct_1 -> Lwt.bind (state_is Lwt.Sleep p2) (fun initial_state_correct_2 -> Lwt.wakeup_paused (); assert (Lwt.paused_count () = 0); Lwt.bind (state_is (Lwt.Return ()) p1) (fun final_state_correct_1 -> Lwt.bind (state_is (Lwt.Return ()) p2) (fun final_state_correct_2 -> Lwt.return (initial_state_correct_1 && initial_state_correct_2 && final_state_correct_1 && final_state_correct_2))))) end; test "wakeup with no promises" begin fun () -> assert (Lwt.paused_count () = 0); Lwt.wakeup_paused (); assert (Lwt.paused_count () = 0); Lwt.return_true end; test "pause notifier" begin fun () -> let seen = ref None in Lwt.register_pause_notifier (fun count -> seen := Some count); Lwt.pause () |> ignore; assert (Lwt.paused_count () = 1); assert (!seen = Some 1); Lwt.wakeup_paused (); Lwt.register_pause_notifier ignore; Lwt.return_true end; test "pause in unpause" begin fun () -> let p1 = Lwt.pause () in (* let p2 = ref return_unit in *) Lwt.bind p1 (fun () -> Lwt.pause ()) |> ignore; assert (Lwt.paused_count () = 1); Lwt.wakeup_paused (); later (fun () -> assert (Lwt.paused_count () = 1); Lwt.wakeup_paused (); true) end; test "recursive pause in notifier" begin fun () -> Lwt.register_pause_notifier (fun _count -> (* This will be called in response to a call to [Lwt.pause ()], so we can expect one paused promise to already be in the queue. *) assert (Lwt.paused_count () = 1); Lwt.register_pause_notifier ignore; Lwt.pause () |> ignore); Lwt.pause () |> ignore; assert (Lwt.paused_count () = 2); Lwt.wakeup_paused (); Lwt.return_true end; test "unpause in pause" begin fun () -> Lwt.register_pause_notifier (fun _count -> assert (Lwt.paused_count () = 1); Lwt.wakeup_paused ()); Lwt.pause () |> ignore; assert (Lwt.paused_count () = 0); Lwt.register_pause_notifier ignore; Lwt.return_true end; ] let suites = suites @ [pause_tests] (* [Lwt.apply] and [Lwt.wrapN]. *) let lift_tests = suite "apply and wrap" [ test "apply" begin fun () -> let p = Lwt.apply (fun s -> Lwt.return (s ^ "bar")) "foo" in state_is (Lwt.Return "foobar") p end; test "apply: raises" begin fun () -> let p = Lwt.apply (fun () -> raise Exception) () in state_is (Lwt.Fail Exception) p end; test "wrap" begin fun () -> let p = Lwt.wrap (fun () -> "foo") in state_is (Lwt.Return "foo") p end; test "wrap: raises" begin fun () -> let p = Lwt.wrap (fun () -> raise Exception) in state_is (Lwt.Fail Exception) p end; test "wrap1" begin fun () -> let p = Lwt.wrap1 (fun x1 -> x1) 1 in state_is (Lwt.Return 1) p end; test "wrap1: raises" begin fun () -> let p = Lwt.wrap1 (fun _ -> raise Exception) () in state_is (Lwt.Fail Exception) p end; test "wrap2" begin fun () -> let p = Lwt.wrap2 (fun x1 x2 -> x1 + x2) 1 2 in state_is (Lwt.Return 3) p end; test "wrap2: raises" begin fun () -> let p = Lwt.wrap2 (fun _ _ -> raise Exception) () () in state_is (Lwt.Fail Exception) p end; test "wrap3" begin fun () -> let p = Lwt.wrap3 (fun x1 x2 x3 -> x1 + x2 + x3) 1 2 3 in state_is (Lwt.Return 6) p end; test "wrap3: raises" begin fun () -> let p = Lwt.wrap3 (fun _ _ _ -> raise Exception) () () () in state_is (Lwt.Fail Exception) p end; test "wrap4" begin fun () -> let p = Lwt.wrap4 (fun x1 x2 x3 x4 -> x1 + x2 + x3 + x4) 1 2 3 4 in state_is (Lwt.Return 10) p end; test "wrap4: raises" begin fun () -> let p = Lwt.wrap4 (fun _ _ _ _ -> raise Exception) () () () () in state_is (Lwt.Fail Exception) p end; test "wrap5" begin fun () -> let p = Lwt.wrap5 (fun x1 x2 x3 x4 x5 -> x1 + x2 + x3 + x4 + x5) 1 2 3 4 5 in state_is (Lwt.Return 15) p end; test "wrap5: raises" begin fun () -> let p = Lwt.wrap5 (fun _ _ _ _ _ -> raise Exception) () () () () () in state_is (Lwt.Fail Exception) p end; test "wrap6" begin fun () -> let p = Lwt.wrap6 (fun x1 x2 x3 x4 x5 x6 -> x1 + x2 + x3 + x4 + x5 + x6) 1 2 3 4 5 6 in state_is (Lwt.Return 21) p end; test "wrap6: raises" begin fun () -> let p = Lwt.wrap6 (fun _ _ _ _ _ _ -> raise Exception) () () () () () () in state_is (Lwt.Fail Exception) p end; test "wrap7" begin fun () -> let p = Lwt.wrap7 (fun x1 x2 x3 x4 x5 x6 x7 -> x1 + x2 + x3 + x4 + x5 + x6 + x7) 1 2 3 4 5 6 7 in state_is (Lwt.Return 28) p end; test "wrap7: raises" begin fun () -> let p = Lwt.wrap7 (fun _ _ _ _ _ _ _ -> raise Exception) () () () () () () () in state_is (Lwt.Fail Exception) p end; ] let suites = suites @ [lift_tests] (* These tests exercise the callback cleanup mechanism of the Lwt core, which is an implementation detail. When a promise [p] is repeatedly used in functions such as [Lwt.choose], but remains pending, while other promises passed to [Lwt.choose] resolve, [p] accumulates disabled callback cells. They need to be occasionally cleaned up; in particular, this should happen every [callback_cleanup_point] [Lwt.choose] operations. As an extra twist, if [f] in [p' = Lwt.bind _ f] returns a pending promise [p], that pending promise's callback cells, including the disabled ones, are appended to the callback cells of [p']. If the sum of [Lwt.choose] operations performed on [p] and [p'] is more than [callback_cleanup_point], disabled callback cells also need to be cleaned up on [p']. The tests below callback the cleanup code, and make sure that non-disabled callback cells survive the cleanup. *) let callback_cleanup_point = 42 let callback_list_tests = suite "callback cleanup" [ test "choose" begin fun () -> let p1, r1 = Lwt.wait () in let p2 = Lwt.bind p1 (fun s -> Lwt.return (s ^ "bar")) in let p3 = Lwt.choose [p1; fst (Lwt.wait ())] in let rec repeat = function | 0 -> () | n -> let p4, r4 = Lwt.wait () in Lwt.choose [p1; p4] |> ignore; Lwt.wakeup r4 ""; repeat (n - 1) in repeat (callback_cleanup_point + 1); Lwt.wakeup r1 "foo"; Lwt.return (Lwt.state p2 = Lwt.Return "foobar" && Lwt.state p3 = Lwt.Return "foo") end; test "bind" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p3 = Lwt.bind p1 (fun () -> p2) in let p4 = Lwt.map ignore p2 in let p5 = Lwt.map ignore p3 in let rec repeat = function | 0 -> () | n -> let p6, r6 = Lwt.wait () in Lwt.choose [p2; p3; p6] |> ignore; Lwt.wakeup r6 (); repeat (n - 1) in repeat ((callback_cleanup_point / 2) + 1); Lwt.wakeup r1 (); Lwt.wakeup r2 (); Lwt.return (Lwt.state p4 = Lwt.Return () && Lwt.state p5 = Lwt.Return ()) end; ] let suites = suites @ [callback_list_tests] (* Lwt should preserve tail-recursion. When a recursive function [f] lives in the [Lwt] monad, a programmer must assume that [f] is only call in tail position in [Lwt.bind]. Given that robustness to stack overflows cannot be ignored by OCaml programmers, this property should be documented, be part of [Lwt] specification, and probably never be broken in the future. This test tries to ensure that [Lwt.bind x f] indeed calls [f] only in tail position. *) let tailrec_tests = suite "tailrec" [ test "tailrec" begin fun () -> let rec aux f accu n = if n = 0 then Lwt.return accu else Lwt.bind (f n) (fun s -> aux f (s + accu) (n - 1)) in let f n = Lwt.return n in try ignore (aux f 0 10000000); Lwt.return_true with _ -> Lwt.return_false end; ] let suites = suites @ [tailrec_tests] lwt-5.9.1/test/core/test_lwt_condition.ml000066400000000000000000000040111476253734400205230ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test exception Dummy_error let suite = suite "lwt_condition" [ test "basic wait" begin fun () -> let c = Lwt_condition.create () in let w = Lwt_condition.wait c in let () = Lwt_condition.signal c 1 in Lwt.bind w (fun v -> Lwt.return (v = 1)) end; test "mutex unlocked during wait" begin fun () -> let c = Lwt_condition.create () in let m = Lwt_mutex.create () in let _ = Lwt_mutex.lock m in let w = Lwt_condition.wait ~mutex:m c in Lwt.return (Lwt.state w = Lwt.Sleep && not (Lwt_mutex.is_locked m)) end; test "mutex relocked after wait" begin fun () -> let c = Lwt_condition.create () in let m = Lwt_mutex.create () in let _ = Lwt_mutex.lock m in let w = Lwt_condition.wait ~mutex:m c in let () = Lwt_condition.signal c 1 in Lwt.bind w (fun v -> Lwt.return (v = 1 && Lwt_mutex.is_locked m)) end; test "signal is not sticky" begin fun () -> let c = Lwt_condition.create () in let () = Lwt_condition.signal c 1 in let w = Lwt_condition.wait c in Lwt.return (Lwt.state w = Lwt.Sleep) end; test "broadcast" begin fun () -> let c = Lwt_condition.create () in let w1 = Lwt_condition.wait c in let w2 = Lwt_condition.wait c in let () = Lwt_condition.broadcast c 1 in Lwt.bind w1 (fun v1 -> Lwt.bind w2 (fun v2 -> Lwt.return (v1 = 1 && v2 = 1))) end; test "broadcast exception" begin fun () -> let c = Lwt_condition.create () in let w1 = Lwt_condition.wait c in let w2 = Lwt_condition.wait c in let () = Lwt_condition.broadcast_exn c Dummy_error in Lwt.try_bind (fun () -> w1) (fun _ -> Lwt.return_false) (fun exn1 -> Lwt.try_bind (fun () -> w2) (fun _ -> Lwt.return_false) (fun exn2 -> Lwt.return (exn1 = Dummy_error && exn2 = Dummy_error))) end; ] lwt-5.9.1/test/core/test_lwt_list.ml000066400000000000000000000422421476253734400175200ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix let (<=>) v v' = assert (Lwt.state v = v') let test_iter f test_list = let incr_ x = Lwt.return (incr x) in let () = let l = [ref 0; ref 0; ref 0] in let t = f incr_ l in t <=> Lwt.Return (); List.iter2 (fun v r -> assert (v = !r)) [1; 1; 1] l in let () = let l = [ref 0; ref 0; ref 0] in let t, w = Lwt.wait () in let r = ref [incr_; (fun x -> t >>= (fun () -> incr_ x)); incr_] in let t' = f (fun x -> let f = List.hd !r in let t = f x in r := List.tl !r; t) l in t' <=> Sleep; List.iter2 (fun v r -> assert (v = !r)) test_list l; Lwt.wakeup w (); List.iter2 (fun v r -> assert (v = !r)) [1; 1; 1] l; t' <=> Lwt.Return () in () let test_exception list_combinator = let exception Exception in let number_of_callback_calls = ref 0 in let callback _ = incr number_of_callback_calls; match !number_of_callback_calls with | 2 -> raise Exception | _ -> Lwt.return_unit in (* Even though the callback will raise immediately for one of the list elements, we expect the final promise that represents the entire list operation to be created (and rejected with the raised exception). The raised exception should not be leaked up past the creation of the promise. *) let p = try list_combinator callback [(); (); ()] with _exn -> assert false in (* Check that the promise was rejected with the expected exception. *) assert (Lwt.state p = Lwt.Fail Exception) let test_map f test_list = let t, w = Lwt.wait () in let t', _ = Lwt.task () in let get = let r = ref 0 in let c = ref 0 in fun () -> let th = incr c; match !c with | 5 -> t | 8 -> t' | _ -> Lwt.return_unit in th >>= (fun () -> incr r; Lwt.return (!r)) in let () = let l = [(); (); ()] in let t1 = f get l in t1 <=> Lwt.Return [1; 2; 3]; let t2 = f get l in t2 <=> Lwt.Sleep; let t3 = f get l in t3 <=> Lwt.Sleep; Lwt.cancel t'; t3 <=> Lwt.Fail Lwt.Canceled; Lwt.wakeup w (); t2 <=> Lwt.Return test_list; in () let test_parallelism map = let t, w = Lwt.wait () in let g _ = Lwt.wakeup_later w (); Lwt.return_unit in let f x = if x = 0 then t >>= (fun _ -> Lwt.return_unit) else g x in let p = map f [0; 1] in p >>= (fun _ -> Lwt.return_true) let test_serialization ?(rev=false) map = let other_ran = ref false in let k = if rev then 1 else 0 in let f x = if x = k then Lwt.pause () >>= fun () -> assert(not !other_ran); Lwt.return_unit else begin other_ran := true; Lwt.return_unit end in let p = map f [0; 1] in p >>= (fun _ -> Lwt.return_true) let test_for_all_true f = let l = [true; true] in f (fun x -> Lwt.return (x = true)) l let test_for_all_false f = let l = [true; true] in f (fun x -> Lwt.return (x = false)) l >>= fun b -> Lwt.return (not b) let test_exists_true f = let l = [true; false] in f (fun x -> Lwt.return (x = true)) l >>= fun b -> Lwt.return b let test_exists_false f = let l = [true; true] in f (fun x -> Lwt.return (x = false)) l >>= fun b -> Lwt.return (not b) let test_filter f = let l = [1; 2; 3; 4] in f (fun x -> Lwt.return (x mod 2 = 0)) l >>= fun after -> Lwt.return (after = [2; 4]) let test_partition f = let l = [1; 2; 3; 4] in f (fun x -> Lwt.return (x <= 2)) l >>= fun (a, b) -> Lwt.return (a = [1; 2] && b = [3; 4]) let test_filter_map f = let l = [1; 2; 3; 4] in let fn = (fun x -> if x mod 2 = 0 then Lwt.return_some (x * 2) else Lwt.return_none) in f fn l >>= fun after -> Lwt.return (after = [4; 8]) let test_iter_i f = let count = ref 0 in let l = [1; 2; 3] in f (fun i n -> count := !count + i + n; Lwt.return_unit) l >>= fun () -> Lwt.return (!count = 9) let test_map_i f = let l = [0; 0; 0] in f (fun i n -> Lwt.return (i + n)) l >>= fun after -> Lwt.return (after = [0; 1; 2]) let test_rev_map f = let l = [1; 2; 3] in f (fun n -> Lwt.return (n * 2)) l >>= fun after -> Lwt.return (after = [6; 4; 2]) let suite_primary = suite "lwt_list" [ test "iter_p" begin fun () -> test_iter Lwt_list.iter_p [1; 0; 1]; test_exception Lwt_list.iter_p; Lwt.return_true end; test "iter_s" begin fun () -> test_iter Lwt_list.iter_s [1; 0; 0]; test_exception Lwt_list.iter_s; Lwt.return_true end; test "map_p" begin fun () -> test_map Lwt_list.map_p [4; 8; 5]; test_exception Lwt_list.map_p; Lwt.return_true end; test "map_s" begin fun () -> test_map Lwt_list.map_s [4; 7; 8]; test_exception Lwt_list.map_s; Lwt.return_true end; test "fold_left_s" begin fun () -> let l = [1; 2; 3] in let f acc v = Lwt.return (v::acc) in let t = Lwt_list.fold_left_s f [] l in t <=> Lwt.Return (List.rev l); Lwt.return_true end; test "for_all_s" (fun () -> test_for_all_true Lwt_list.for_all_s); test "for_all_p" (fun () -> test_for_all_true Lwt_list.for_all_p); test "exists_s true" (fun () -> test_exists_true Lwt_list.exists_s); test "exists_p true" (fun () -> test_exists_true Lwt_list.exists_p); test "exists_s false" (fun () -> test_exists_false Lwt_list.exists_s); test "exists_p false" (fun () -> test_exists_false Lwt_list.exists_p); test "filter_s" (fun () -> test_filter Lwt_list.filter_s); test "filter_p" (fun () -> test_filter Lwt_list.filter_p); test "partition_p" (fun () -> test_partition Lwt_list.partition_p); test "partition_s" (fun () -> test_partition Lwt_list.partition_s); test "filter_map_p" (fun () -> test_filter_map Lwt_list.filter_map_p); test "filter_map_s" (fun () -> test_filter_map Lwt_list.filter_map_s); test "iteri_p" (fun () -> test_iter_i Lwt_list.iteri_p); test "iteri_s" (fun () -> test_iter_i Lwt_list.iteri_s); test "mapi_p" (fun () -> test_map_i Lwt_list.mapi_p); test "mapi_s" (fun () -> test_map_i Lwt_list.mapi_s); test "find_s existing" begin fun () -> let l = [1; 2; 3] in Lwt_list.find_s (fun n -> Lwt.return ((n mod 2) = 0)) l >>= fun result -> Lwt.return (result = 2) end; test "find_s missing" begin fun () -> let l = [1; 3] in Lwt.catch (fun () -> Lwt_list.find_s (fun n -> Lwt.return ((n mod 2) = 0)) l >>= fun _result -> Lwt.return_false) (function | Not_found -> Lwt.return_true | _ -> Lwt.return_false) end; test "rev_map_p" (fun () -> test_rev_map Lwt_list.rev_map_p); test "rev_map_s" (fun () -> test_rev_map Lwt_list.rev_map_s); test "fold_right_s" begin fun () -> let l = [1; 2; 3] in Lwt_list.fold_right_s (fun a n -> Lwt.return (a + n)) l 0 >>= fun result -> Lwt.return (result = 6) end; test "iteri_p exception" begin fun () -> let i f = Lwt_list.iteri_p (fun _ x -> f x) in test_exception i; Lwt.return_true end; test "iteri_s exception" begin fun () -> let i f = Lwt_list.iteri_s (fun _ x -> f x) in test_exception i; Lwt.return_true end; test "map_s exception" begin fun () -> test_exception Lwt_list.map_s; Lwt.return_true end; test "map_p exception" begin fun () -> test_exception Lwt_list.map_p; Lwt.return_true end; test "mapi_s exception" begin fun () -> let m f = Lwt_list.mapi_s (fun _ x -> f x) in test_exception m; Lwt.return_true end; test "mapi_p exception" begin fun () -> let m f = Lwt_list.mapi_p (fun _ x -> f x) in test_exception m; Lwt.return_true end; test "rev_map_s exception" begin fun () -> test_exception Lwt_list.rev_map_s; Lwt.return_true end; test "rev_map_p exception" begin fun () -> test_exception Lwt_list.rev_map_p; Lwt.return_true end; test "fold_left_s exception" begin fun () -> let m f = Lwt_list.fold_left_s (fun _ x -> f x) () in test_exception m; Lwt.return_true end; test "fold_right_s exception" begin fun() -> let m f l = Lwt_list.fold_right_s (fun x _ -> f x) l () in test_exception m; Lwt.return_true end; test "for_all_p exception" begin fun () -> let m f = Lwt_list.for_all_p (fun x -> f x >>= (fun _ -> Lwt.return_true)) in test_exception m; Lwt.return_true end; test "for_all_s exception" begin fun () -> let m f = Lwt_list.for_all_s (fun x -> f x >>= (fun _ -> Lwt.return_true)) in test_exception m; Lwt.return_true end; test "exists_p exception" begin fun () -> let m f = Lwt_list.exists_p (fun x -> f x >>= (fun _ -> Lwt.return_false)) in test_exception m; Lwt.return_true end; test "exists_s exception" begin fun () -> let m f = Lwt_list.exists_s (fun x -> f x >>= (fun _ -> Lwt.return_false)) in test_exception m; Lwt.return_true end; test "find_s exception" begin fun () -> let m f = Lwt_list.find_s (fun x -> f x >>= (fun _ -> Lwt.return_false)) in test_exception m; Lwt.return_true end; test "filter_p exception" begin fun () -> let m f = Lwt_list.filter_p (fun x -> f x >>= (fun _ -> Lwt.return_false)) in test_exception m; Lwt.return_true; end; test "filter_s exception" begin fun () -> let m f = Lwt_list.filter_s (fun x -> f x >>= (fun _ -> Lwt.return_false)) in test_exception m; Lwt.return_true; end; test "filter_map_p exception" begin fun () -> let m f = Lwt_list.filter_map_p (fun x -> f x >>= (fun _ -> Lwt.return (Some ()))) in test_exception m; Lwt.return_true; end; test "filter_map_s exception" begin fun () -> let m f = Lwt_list.filter_map_s (fun x -> f x >>= (fun _ -> Lwt.return (Some ()))) in test_exception m; Lwt.return_true; end; test "partition_p exception" begin fun () -> let m f = Lwt_list.partition_p (fun x -> f x >>= (fun _ -> Lwt.return_false)) in test_exception m; Lwt.return_true; end; test "partition_s exception" begin fun () -> let m f = Lwt_list.partition_s (fun x -> f x >>= (fun _ -> Lwt.return_false)) in test_exception m; Lwt.return_true; end; test "iter_p parallelism" begin fun () -> test_parallelism Lwt_list.iter_p end; test "iter_s serialization" begin fun () -> test_serialization Lwt_list.iter_s end; test "iteri_p parallelism" begin fun () -> let iter f = Lwt_list.iteri_p (fun _ x -> f x) in test_parallelism iter end; test "iteri_s serialization" begin fun () -> let iter f = Lwt_list.iteri_s (fun _ x -> f x) in test_serialization iter end; test "map_p parallelism" begin fun () -> test_parallelism Lwt_list.map_p end; test "map_s serialization" begin fun () -> test_serialization Lwt_list.map_s end; test "mapi_p parallelism" begin fun () -> let m f = Lwt_list.mapi_p (fun _ x -> f x) in test_parallelism m end; test "mapi_s serialization" begin fun () -> let m f = Lwt_list.mapi_s (fun _ x -> f x) in test_serialization m end; test "rev_map_p parallelism" begin fun () -> test_parallelism Lwt_list.rev_map_p end; test "rev_map_s serialization" begin fun () -> test_serialization Lwt_list.rev_map_s end; test "fold_left_s serialization" begin fun () -> let m f = Lwt_list.fold_left_s (fun _ x -> f x >>= fun _ -> Lwt.return_unit) () in test_serialization m end; test "fold_right_s serialization" begin fun () -> let m f l = Lwt_list.fold_right_s (fun x _ -> f x >>= fun _ -> Lwt.return_unit) l () in test_serialization ~rev:true m end; test "filter_map_p parallelism" begin fun () -> let m f = Lwt_list.filter_map_p (fun x -> f x >>= fun u -> Lwt.return (Some u)) in test_parallelism m end; test "filter_map_s serlialism" begin fun () -> let m f = Lwt_list.filter_map_s (fun x -> f x >>= fun u -> Lwt.return (Some u)) in test_serialization m end; test "for_all_p parallelism" begin fun () -> let m f = Lwt_list.for_all_p (fun x -> f x >>= fun _ -> Lwt.return_true) in test_parallelism m end; test "for_all_s serialization" begin fun () -> let m f = Lwt_list.for_all_s (fun x -> f x >>= fun _ -> Lwt.return_true) in test_serialization m end; test "exists_p parallelism" begin fun () -> let m f = Lwt_list.exists_p (fun x -> f x >>= fun _ -> Lwt.return_false) in test_parallelism m end; test "exists_s serialization" begin fun () -> let m f = Lwt_list.exists_s (fun x -> f x >>= fun _ -> Lwt.return_false) in test_serialization m end; test "find_s serialization" begin fun () -> let m f = Lwt_list.find_s (fun x -> f x >>= fun _ -> Lwt.return_false) in let handler e = if e = Not_found then Lwt.return_true else Lwt.return_false in Lwt.catch (fun () -> test_serialization m) handler end; test "filter_p parallelism" begin fun () -> let m f = Lwt_list.filter_p (fun x -> f x >>= fun _ -> Lwt.return_true) in test_parallelism m end; test "filter_s serialization" begin fun () -> let m f = Lwt_list.filter_s (fun x -> f x >>= fun _ -> Lwt.return_true) in test_serialization m end; test "filter_map_s serialization" begin fun () -> let m f = Lwt_list.filter_map_s (fun x -> f x >>= fun u -> Lwt.return (Some u)) in test_serialization m end; test "partition_p parallelism" begin fun () -> let m f l = Lwt_list.partition_p (fun x -> f x >>= fun _ -> Lwt.return_true) l in test_parallelism m end; test "partition_s serialization" begin fun () -> let m f l = Lwt_list.partition_s (fun x -> f x >>= fun _ -> Lwt.return_true) l in test_serialization m end; ] let test_big_list m = let make_list n = Array.to_list @@ Array.init n (fun x -> x) in let f _ = Lwt.return_unit in m f (make_list 10_000_000) >>= (fun _ -> Lwt.return_true) let suite_intensive = suite "lwt_list big lists" ~only_if:(fun () -> try Sys.getenv "LWT_STRESS_TEST" = "true" with | Not_found -> false) [ test "iter_p big list" begin fun () -> test_big_list Lwt_list.iter_p end; test "iter_s big list" begin fun () -> test_big_list Lwt_list.iter_s end; test "iteri_p big list" begin fun () -> let iter f = Lwt_list.iteri_p (fun _ x -> f x) in test_big_list iter end; test "iteri_s big list" begin fun () -> let iter f = Lwt_list.iteri_s (fun _ x -> f x) in test_serialization iter end; test "map_p big list" begin fun () -> test_big_list Lwt_list.map_p end; test "map_s big list" begin fun () -> test_serialization Lwt_list.map_s end; test "mapi_p big list" begin fun () -> let m f = Lwt_list.mapi_p (fun _ x -> f x) in test_big_list m end; test "mapi_s big list" begin fun () -> let m f = Lwt_list.mapi_s (fun _ x -> f x) in test_big_list m end; test "rev_map_p big list" begin fun () -> test_big_list Lwt_list.rev_map_p end; test "rev_map_s big list" begin fun () -> test_big_list Lwt_list.rev_map_s end; test "fold_left_s big list" begin fun () -> let m f = Lwt_list.fold_left_s (fun _ x -> f x >>= fun _ -> Lwt.return_unit) () in test_big_list m end; test "fold_right_s big list" begin fun () -> let m f l = Lwt_list.fold_right_s (fun x _ -> f x >>= fun _ -> Lwt.return_unit) l () in test_big_list m end; test "for_all_p big list" begin fun () -> let m f = Lwt_list.for_all_p (fun x -> f x >>= fun _ -> Lwt.return_true) in test_big_list m end; test "for_all_s big list" begin fun () -> let m f = Lwt_list.for_all_s (fun x -> f x >>= fun _ -> Lwt.return_true) in test_big_list m end; test "exists_p big list" begin fun () -> let m f = Lwt_list.exists_p (fun x -> f x >>= fun _ -> Lwt.return_false) in test_big_list m end; test "exists_s big list" begin fun () -> let m f = Lwt_list.exists_s (fun x -> f x >>= fun _ -> Lwt.return_false) in test_big_list m end; test "find_s big list" begin fun () -> let m f = Lwt_list.find_s (fun x -> f x >>= fun _ -> Lwt.return_false) in let handler e = if e = Not_found then Lwt.return_true else Lwt.return_false in Lwt.catch (fun () -> test_big_list m) handler end; test "filter_p big list" begin fun () -> let m f = Lwt_list.filter_p (fun x -> f x >>= fun _ -> Lwt.return_true) in test_big_list m end; test "filter_s big list" begin fun () -> let m f = Lwt_list.filter_s (fun x -> f x >>= fun _ -> Lwt.return_true) in test_big_list m end; test "filter_map_p big list" begin fun () -> let m f = Lwt_list.filter_map_p (fun x -> f x >>= fun u -> Lwt.return (Some u)) in test_big_list m end; test "filter_map_s big list" begin fun () -> let m f = Lwt_list.filter_map_s (fun x -> f x >>= fun u -> Lwt.return (Some u)) in test_big_list m end; test "partition_p big list" begin fun () -> let m f l = Lwt_list.partition_p (fun x -> f x >>= fun _ -> Lwt.return_true) l in test_big_list m end; test "partition_s big list" begin fun () -> let m f l = Lwt_list.partition_s (fun x -> f x >>= fun _ -> Lwt.return_true) l in test_big_list m end; ] lwt-5.9.1/test/core/test_lwt_mutex.ml000066400000000000000000000070271476253734400177110ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix open Test let suite = suite "lwt_mutex" [ (* See https://github.com/ocsigen/lwt/pull/202#issue-123451878. *) test "cancel" (fun () -> let mutex = Lwt_mutex.create () in (* Thread 1: take the mutex and wait. *) let thread_1_wait, resume_thread_1 = Lwt.wait () in let thread_1 = Lwt_mutex.with_lock mutex (fun () -> thread_1_wait) in (* Thread 2: block on the mutex. *) let thread_2_locked_mutex = ref false in let thread_2 = Lwt_mutex.lock mutex >|= fun () -> thread_2_locked_mutex := true in (* Cancel thread 2, and make sure it is canceled. *) Lwt.cancel thread_2; Lwt.catch (fun () -> thread_2 >>= fun () -> Lwt.return_false) (function | Lwt.Canceled -> Lwt.return_true | _ -> Lwt.return_false) >>= fun thread_2_canceled -> (* Thread 1: release the mutex. *) Lwt.wakeup resume_thread_1 (); thread_1 >>= fun () -> (* Thread 3: try to take the mutex. Thread 2 should not have it locked, since thread 2 was canceled. *) Lwt_mutex.lock mutex >|= fun () -> not !thread_2_locked_mutex && thread_2_canceled); (* See https://github.com/ocsigen/lwt/pull/202#issuecomment-227092595. *) test "cancel while queued by unlock" (fun () -> let mutex = Lwt_mutex.create () in (* Thread 1: take the mutex and wait. *) let thread_1_wait, resume_thread_1 = Lwt.wait () in let thread_1 = Lwt_mutex.with_lock mutex (fun () -> thread_1_wait) in (* Thread 2: block on the mutex, then set a flag and release it. *) let thread_2_waiter_executed = ref false in let thread_2 = Lwt_mutex.lock mutex >|= fun () -> thread_2_waiter_executed := true; Lwt_mutex.unlock mutex in (* Thread 3: wrap the wakeup of thread 2 in a wakeup of thread 3. *) let top_level_waiter, wake_top_level_waiter = Lwt.wait () in let while_waking = top_level_waiter >>= fun () -> (* Inside thread 3 wakeup. *) (* Thread 1: release the mutex. This queues thread 2 using wakeup_later inside Lwt_mutex.unlock. *) Lwt.wakeup resume_thread_1 (); thread_1 >>= fun () -> (* Confirm the mutex is now considered locked by thread 2. *) let mutex_passed = Lwt_mutex.is_locked mutex in (* Confirm thread 2 hasn't executed its bind (well, map). It is queued. *) let thread_2_was_queued = not !thread_2_waiter_executed in (* Try to cancel thread 2. *) Lwt.cancel thread_2; (* Complete thread 2 and check it has not been canceled. *) Lwt.catch (fun () -> thread_2 >>= fun () -> Lwt.return_false) (function | Lwt.Canceled -> Lwt.return_true | _ -> Lwt.return_false) >|= fun thread_2_canceled -> (* Confirm that thread 2 ran, and released the mutex. *) mutex_passed && thread_2_was_queued && not thread_2_canceled && !thread_2_waiter_executed && not (Lwt_mutex.is_locked mutex) in (* Run thread 3. * Keep this as wakeup_later to test the issue on 2.3.2 reported in * https://github.com/ocsigen/lwt/pull/202 * See also: * https://github.com/ocsigen/lwt/pull/261 *) Lwt.wakeup_later wake_top_level_waiter (); while_waking); ] lwt-5.9.1/test/core/test_lwt_mvar.ml000066400000000000000000000043241476253734400175110ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix open Test let state_is = Lwt.debug_state_is let suite = suite "lwt_mvar" [ test "basic take" begin fun () -> let x = Lwt_mvar.create 0 in let y = Lwt_mvar.take x in state_is (Lwt.Return 0) y end; test "take_available (full)" begin fun () -> let x = Lwt_mvar.create 0 in let y = Lwt_mvar.take_available x in Lwt.return (y = Some 0) end; test "take_available (empty)" begin fun () -> let x = Lwt_mvar.create_empty () in let y = Lwt_mvar.take_available x in Lwt.return (y = None) end; test "take_available (twice)" begin fun () -> let x = Lwt_mvar.create 0 in let (_ : int option) = Lwt_mvar.take_available x in let y = Lwt_mvar.take_available x in Lwt.return (y = None) end; test "is_empty (full)" begin fun () -> let x = Lwt_mvar.create 0 in let y = Lwt_mvar.is_empty x in Lwt.return (not y) end; test "is_empty (empty)" begin fun () -> let x = Lwt_mvar.create_empty () in let y = Lwt_mvar.is_empty x in Lwt.return y end; test "blocking put" begin fun () -> let x = Lwt_mvar.create 0 in let y = Lwt_mvar.put x 1 in Lwt.return (Lwt.state y = Lwt.Sleep) end; test "put-take" begin fun () -> let x = Lwt_mvar.create_empty () in let _ = Lwt_mvar.put x 0 in let y = Lwt_mvar.take x in state_is (Lwt.Return 0) y end; test "take-put" begin fun () -> let x = Lwt_mvar.create 0 in let _ = Lwt_mvar.take x in let y = Lwt_mvar.put x 1 in state_is (Lwt.Return ()) y end; test "enqueued writer" begin fun () -> let x = Lwt_mvar.create 1 in let y = Lwt_mvar.put x 2 in let z = Lwt_mvar.take x in state_is (Lwt.Return ()) y >>= fun y_correct -> state_is (Lwt.Return 1) z >>= fun z_correct -> Lwt.return (y_correct && z_correct) end; test "writer cancellation" begin fun () -> let y = Lwt_mvar.create 1 in let r1 = Lwt_mvar.put y 2 in Lwt.cancel r1; Lwt.return ((Lwt.state (Lwt_mvar.take y) = Lwt.Return 1) && (Lwt.state (Lwt_mvar.take y) = Lwt.Sleep)) end; ] lwt-5.9.1/test/core/test_lwt_pool.ml000066400000000000000000000151121476253734400175120ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test exception Dummy_error let suite = suite "lwt_pool" [ test "basic create-use" begin fun () -> let gen = fun () -> Lwt.return_unit in let p = Lwt_pool.create 1 gen in Lwt.return (Lwt.state (Lwt_pool.use p Lwt.return) = Lwt.Return ()) end; test "creator exception" begin fun () -> let gen = fun () -> raise Dummy_error in let p = Lwt_pool.create 1 gen in let u = Lwt_pool.use p (fun _ -> Lwt.return 0) in Lwt.return (Lwt.state u = Lwt.Fail Dummy_error) end; test "pool elements are reused" begin fun () -> let gen = (fun () -> let n = ref 0 in Lwt.return n) in let p = Lwt_pool.create 1 gen in let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.return !n) in let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in Lwt.return (Lwt.state u2 = Lwt.Return 1) end; test "pool elements are validated when returned" begin fun () -> let gen = (fun () -> let n = ref 0 in Lwt.return n) in let v l = Lwt.return (!l = 0) in let p = Lwt_pool.create 1 ~validate:v gen in let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.return !n) in let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in Lwt.return (Lwt.state u2 = Lwt.Return 0) end; test "validation exceptions are propagated to users" begin fun () -> let c = Lwt_condition.create () in let gen = (fun () -> let l = ref 0 in Lwt.return l) in let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in let p = Lwt_pool.create 1 ~validate:v gen in let u1 = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait c) in let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in let () = Lwt_condition.signal c "done" in Lwt.bind u1 (fun v1 -> Lwt.try_bind (fun () -> u2) (fun _ -> Lwt.return_false) (fun exn2 -> Lwt.return (v1 = "done" && exn2 = Dummy_error))) end; test "multiple creation" begin fun () -> let gen = (fun () -> let n = ref 0 in Lwt.return n) in let p = Lwt_pool.create 2 gen in let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.pause ()) in let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in Lwt.return (Lwt.state u2 = Lwt.Return 0) end; test "users of an empty pool will wait" begin fun () -> let gen = (fun () -> Lwt.return 0) in let p = Lwt_pool.create 1 gen in let _ = Lwt_pool.use p (fun _ -> Lwt.pause ()) in let u2 = Lwt_pool.use p Lwt.return in Lwt.return (Lwt.state u2 = Lwt.Sleep) end; test "on check, good elements are retained" begin fun () -> let gen = (fun () -> let n = ref 1 in Lwt.return n) in let c = (fun x f -> f (!x > 0)) in let p = Lwt_pool.create 1 ~check: c gen in let _ = Lwt_pool.use p (fun n -> n := 2; Lwt.fail Dummy_error) in let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in Lwt.return (Lwt.state u2 = Lwt.Return 2) end; test "on check, bad elements are disposed of and replaced" begin fun () -> let gen = (fun () -> let n = ref 1 in Lwt.return n) in let check = (fun n f -> f (!n > 0)) in let disposed = ref false in let dispose _ = disposed := true; Lwt.return_unit in let p = Lwt_pool.create 1 ~check ~dispose gen in let task = (fun n -> incr n; Lwt.return !n) in let _ = Lwt_pool.use p (fun n -> n := 0; Lwt.fail Dummy_error) in let u2 = Lwt_pool.use p task in Lwt.return (Lwt.state u2 = Lwt.Return 2 && !disposed) end; test "clear disposes of all elements" begin fun () -> let gen = (fun () -> let n = ref 1 in Lwt.return n) in let count = ref 0 in let dispose _ = incr count; Lwt.return_unit in let p = Lwt_pool.create 2 ~dispose gen in let u = Lwt_pool.use p (fun _ -> Lwt.pause ()) in let _ = Lwt_pool.use p (fun _ -> Lwt.return_unit) in let _ = Lwt_pool.clear p in Lwt.bind u (fun () -> Lwt.return (!count = 2)) end; test "waiter are notified on replacement" begin fun () -> let c = Lwt_condition.create () in let gen = (fun () -> let l = ref 0 in Lwt.return l) in let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in let p = Lwt_pool.create 1 ~validate:v gen in let u1 = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait c) in let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in let () = Lwt_condition.signal c "done" in Lwt.bind u1 (fun v1 -> Lwt.bind u3 (fun v3 -> Lwt.try_bind (fun () -> u2) (fun _ -> Lwt.return_false) (fun exn2 -> Lwt.return (v1 = "done" && exn2 = Dummy_error && v3 = 0)))) end; test "waiter are notified on replacement exception" begin fun () -> let c = Lwt_condition.create () in let k = ref true in let gen = fun () -> if !k then let l = ref 0 in Lwt.return l else raise Dummy_error in let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in let p = Lwt_pool.create 1 ~validate:v gen in let u1 = Lwt_pool.use p (fun l -> l := 1; k:= false; Lwt_condition.wait c) in let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in let () = Lwt_condition.signal c "done" in Lwt.bind u1 (fun v1 -> Lwt.try_bind (fun () -> u2) (fun _ -> Lwt.return_false) (fun exn2 -> Lwt.try_bind (fun () -> u3) (fun _ -> Lwt.return_false) (fun exn3 -> Lwt.return (v1 = "done" && exn2 = Dummy_error && exn3 = Dummy_error)))) end; test "check and validate can be used together" begin fun () -> let gen = (fun () -> let l = ref 0 in Lwt.return l) in let v l = Lwt.return (!l > 0) in let c l f = f (!l > 1) in let cond = Lwt_condition.create() in let p = Lwt_pool.create 1 ~validate:v ~check:c gen in let _ = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait cond) in let _ = Lwt_pool.use p (fun l -> l := 2; raise Dummy_error) in let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in let () = Lwt_condition.signal cond "done" in Lwt.bind u3 (fun v -> Lwt.return (v = 2)) end; test "verify default check behavior" begin fun () -> let gen = (fun () -> let l = ref 0 in Lwt.return l) in let cond = Lwt_condition.create() in let p = Lwt_pool.create 1 gen in let _ = Lwt_pool.use p (fun l -> Lwt.bind (Lwt_condition.wait cond) (fun _ -> l:= 1; raise Dummy_error)) in let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in let () = Lwt_condition.signal cond "done" in Lwt.bind u2 (fun v -> Lwt.return (v = 1)) end; ] lwt-5.9.1/test/core/test_lwt_result.ml000066400000000000000000000177541476253734400200750ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test exception Dummy_error let state_is = Lwt.debug_state_is let suite = suite "lwt_result" [ test "maps" (fun () -> let x = Lwt_result.return 0 in let correct = Lwt_result.return 1 in Lwt.return (Lwt_result.map ((+) 1) x = correct) ); test ">|= is a variant of map" (fun () -> let x = Lwt_result.return 0 in let correct = Lwt_result.return 1 in Lwt.return (Lwt_result.(>|=) x ((+) 1) = correct) ); test "map, error case" (fun () -> let x = Lwt_result.fail 0 in Lwt.return (Lwt_result.map ((+) 1) x = x) ); test "map_error" (fun () -> let x = Lwt_result.return 0 in Lwt.return (Lwt_result.map_error ((+) 1) x = x) ); test "map_error, error case" (fun () -> let x = Lwt_result.fail 0 in let correct = Lwt_result.fail 1 in Lwt.return (Lwt_result.map_error ((+) 1) x = correct) ); test "bind" (fun () -> let x = Lwt_result.return 0 in let correct = Lwt_result.return 1 in let actual = Lwt_result.bind x (fun y -> Lwt_result.return (y + 1)) in Lwt.return (actual = correct) ); test "bind, error case" (fun () -> let x = Lwt_result.fail 0 in let actual = Lwt_result.bind x (fun y -> Lwt_result.return (y + 1)) in Lwt.return (actual = x) ); test "bind_error" (fun () -> let x = Lwt_result.return 0 in let actual = Lwt_result.bind_error x (fun y -> Lwt_result.return (y + 1)) in Lwt.return (actual = x) ); test "bind_error, error case" (fun () -> let x = Lwt_result.fail 0 in let correct = Lwt_result.return 1 in let actual = Lwt_result.bind_error x (fun y -> Lwt_result.return (y + 1)) in Lwt.return (actual = correct) ); test "ok" (fun () -> let x = Lwt.return 0 in Lwt.return (Lwt_result.ok x = Lwt_result.return 0) ); test "error" (fun () -> let x = Lwt.return 0 in Lwt.return (Lwt_result.error x = Lwt_result.fail 0) ); test "catch" (fun () -> let x () = Lwt.return 0 in Lwt.return (Lwt_result.catch x = Lwt_result.return 0) ); test "catch, error case" (fun () -> let x () = raise Dummy_error in Lwt.return (Lwt_result.catch x = Lwt_result.fail Dummy_error) ); test "catch, bound raise" (fun () -> let x () = Lwt.bind Lwt.return_unit (fun () -> raise Dummy_error) in Lwt.return (Lwt_result.catch x = Lwt_result.fail Dummy_error) ); test "catch, immediate raise" (fun () -> let x () = raise Dummy_error in Lwt.return (Lwt_result.catch x = Lwt_result.fail Dummy_error) ); test "get_exn" (fun () -> let x = Lwt_result.return 0 in Lwt.return (Lwt_result.get_exn x = Lwt.return 0) ); test "get_exn, error case" (fun () -> let x = Lwt_result.fail Dummy_error in Lwt.return (Lwt_result.get_exn x = Lwt.fail Dummy_error) ); test "bind_lwt" (fun () -> let x = Lwt_result.return 0 in let f y = Lwt.return (y + 1) in Lwt.return (Lwt_result.bind_lwt x f = Lwt_result.return 1) ); test "bind_lwt, error case" (fun () -> let x = Lwt_result.fail 0 in let f y = Lwt.return (y + 1) in Lwt.return (Lwt_result.bind_lwt x f = Lwt_result.fail 0) ); test "bind_lwt_error" (fun () -> let x = Lwt_result.return 0 in let f y = Lwt.return (y + 1) in Lwt.return (Lwt_result.bind_lwt_error x f = Lwt_result.return 0) ); test "bind_lwt_error, error case" (fun () -> let x = Lwt_result.fail 0 in let f y = Lwt.return (y + 1) in Lwt.return (Lwt_result.bind_lwt_error x f = Lwt_result.fail 1) ); test "bind_result" (fun () -> let x = Lwt_result.return 0 in let f y = Result.Ok (y + 1) in Lwt.return (Lwt_result.bind_result x f = Lwt_result.return 1) ); test "bind_result, error case" (fun () -> let x = Lwt_result.fail 0 in let f y = Result.Ok (y + 1) in Lwt.return (Lwt_result.bind_result x f = Lwt_result.fail 0) ); test "both ok" (fun () -> let p = Lwt_result.both (Lwt_result.return 0) (Lwt_result.return 1) in state_is (Lwt.Return (Result.Ok (0,1))) p ); test "both only fst error" (fun () -> let p = Lwt_result.both (Lwt_result.fail 0) (Lwt_result.return 1) in state_is (Lwt.Return (Result.Error 0)) p ); test "both only snd error" (fun () -> let p = Lwt_result.both (Lwt_result.return 0) (Lwt_result.fail 1) in state_is (Lwt.Return (Result.Error 1)) p ); test "both error, fst" (fun () -> let p2, r2 = Lwt.wait () in let p = Lwt_result.both (Lwt_result.fail 0) p2 in Lwt.wakeup_later r2 (Result.Error 1); Lwt.bind p (fun x -> Lwt.return (x = Result.Error 0)) ); test "both error, snd" (fun () -> let p1, r1 = Lwt.wait () in let p = Lwt_result.both p1 (Lwt_result.fail 1) in Lwt.wakeup_later r1 (Result.Error 0); Lwt.bind p (fun x -> Lwt.return (x = Result.Error 1)) ); test "iter" (fun () -> let x = Lwt_result.return 1 in let actual = ref 0 in Lwt.bind (Lwt_result.iter (fun y -> actual := y + 1; Lwt.return_unit) x) (fun () -> Lwt.return (!actual = 2)) ); test "iter, error case" (fun () -> let x = Lwt_result.fail 1 in let actual = ref 0 in Lwt.bind (Lwt_result.iter (fun y -> actual := y + 1; Lwt.return_unit) x) (fun () -> Lwt.return (!actual <> 2)) ); test "iter_error" (fun () -> let x = Lwt_result.fail 1 in let actual = ref 0 in Lwt.bind (Lwt_result.iter_error (fun y -> actual := y + 1; Lwt.return_unit) x) (fun () -> Lwt.return (!actual = 2)) ); test "iter_error, success case" (fun () -> let x = Lwt_result.return 1 in let actual = ref 0 in Lwt.bind (Lwt_result.iter_error (fun y -> actual := y + 1; Lwt.return_unit) x) (fun () -> Lwt.return (!actual <> 2)) ); test "let*" (fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p' = let open Lwt_result.Syntax in let* s1 = p1 in let* s2 = p2 in Lwt.return (Result.Ok (s1 ^ s2)) in Lwt.wakeup r1 (Result.Ok "foo"); Lwt.wakeup r2 (Result.Ok "bar"); state_is (Lwt.Return (Result.Ok "foobar")) p' ); test "and*" (fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p' = let open Lwt_result.Syntax in let* s1 = p1 and* s2 = p2 in Lwt.return (Result.Ok (s1 ^ s2)) in Lwt.wakeup r1 (Result.Ok "foo"); Lwt.wakeup r2 (Result.Ok "bar"); state_is (Lwt.Return (Result.Ok "foobar")) p' ); test "let+/and+" (fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let p' = let open Lwt_result.Syntax in let+ s1 = p1 and+ s2 = p2 in s1 ^ s2 in Lwt.wakeup r1 (Result.Ok "foo"); Lwt.wakeup r2 (Result.Ok "bar"); state_is (Lwt.Return (Result.Ok "foobar")) p' ); ] lwt-5.9.1/test/core/test_lwt_seq.ml000066400000000000000000000230531476253734400173340ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Syntax open Test let l = [1; 2; 3; 4; 5] let a = Lwt_seq.of_list l let rec pause n = if n <= 0 then Lwt.return_unit else let* () = Lwt.pause () in pause (n - 1) let pause n = pause (n mod 5) let b = Lwt_seq.unfold_lwt (function | [] -> let+ () = pause 2 in None | x::xs -> let+ () = pause (x+2) in Some (x, xs)) l let suite_base = suite "lwt_seq" [ test "fold_left" begin fun () -> let n = ref 1 in Lwt_seq.fold_left (fun acc x -> let r = x = !n && acc in incr n; r) true a end; test "fold_left_s" begin fun () -> let n = ref 1 in Lwt_seq.fold_left_s (fun acc x -> let r = x = !n && acc in incr n; Lwt.return r) true a end; test "map" begin fun () -> let v = Lwt_seq.map (fun x -> (x * 2)) a in let+ l' = Lwt_seq.to_list v in l' = [2; 4; 6; 8; 10] end; test "map_s" begin fun () -> let v = Lwt_seq.map_s (fun x -> Lwt.return (x * 2)) a in let+ l' = Lwt_seq.to_list v in l' = [2; 4; 6; 8; 10] end; test "filter" begin fun () -> let v = Lwt_seq.filter (fun x -> (x mod 2 = 0)) a in let+ l' = Lwt_seq.to_list v in l' = [2; 4] end; test "filter_s" begin fun () -> let v = Lwt_seq.filter_s (fun x -> Lwt.return (x mod 2 = 0)) a in let+ l' = Lwt_seq.to_list v in l' = [2; 4] end; test "iter_n(1)" begin fun () -> let max_concurrency = 1 in let running = ref 0 in let sum = ref 0 in let f x = incr running; assert (!running <= max_concurrency); let* () = pause x in sum := !sum + x; decr running; Lwt.return_unit in let* () = Lwt_seq.iter_n ~max_concurrency f a in assert (!sum = List.fold_left (+) 0 l); sum := 0; let* () = Lwt_seq.iter_n ~max_concurrency f b in assert (!sum = List.fold_left (+) 0 l); Lwt.return_true end; test "iter_n(2)" begin fun () -> let max_concurrency = 2 in let running = ref 0 in let sum = ref 0 in let f x = incr running; assert (!running <= max_concurrency); let* () = pause x in sum := !sum + x; decr running; Lwt.return_unit in let* () = Lwt_seq.iter_n ~max_concurrency f a in assert (!sum = List.fold_left (+) 0 l); sum := 0; let* () = Lwt_seq.iter_n ~max_concurrency f b in assert (!sum = List.fold_left (+) 0 l); Lwt.return_true end; test "iter_n(100)" begin fun () -> let max_concurrency = 100 in let running = ref 0 in let sum = ref 0 in let f x = incr running; assert (!running <= max_concurrency); let* () = pause x in sum := !sum + x; decr running; Lwt.return_unit in let* () = Lwt_seq.iter_n ~max_concurrency f a in assert (!sum = List.fold_left (+) 0 l); sum := 0; let* () = Lwt_seq.iter_n ~max_concurrency f b in assert (!sum = List.fold_left (+) 0 l); Lwt.return_true end; test "filter_map" begin fun () -> let v = Lwt_seq.filter_map (fun x -> if x mod 2 = 0 then Some (x * 2) else None) a in let+ l' = Lwt_seq.to_list v in l' = [4; 8] end; test "filter_map_s" begin fun () -> let v = Lwt_seq.filter_map_s (fun x -> Lwt.return (if x mod 2 = 0 then Some (x * 2) else None)) a in let+ l' = Lwt_seq.to_list v in l' = [4; 8] end; test "unfold" begin fun () -> let range first last = let step i = if i > last then None else Some (i, succ i) in Lwt_seq.unfold step first in let* a = Lwt_seq.to_list (range 1 3) in let+ b = Lwt_seq.to_list (range 1 0) in ([1;2;3] = a) && ([] = b) end; test "unfold_lwt" begin fun () -> let range first last = let step i = if i > last then Lwt.return_none else Lwt.return_some (i, succ i) in Lwt_seq.unfold_lwt step first in let* a = Lwt_seq.to_list (range 1 3) in let+ b = Lwt_seq.to_list (range 1 0) in ([1;2;3] = a) && ([] = b) end; test "fold-into-exception-from-of-seq" begin fun () -> let fail = fun () -> failwith "XXX" in let seq = fun () -> Seq.Cons (1, (fun () -> Seq.Cons (2, fail))) in let a = Lwt_seq.of_seq seq in let+ n = Lwt.catch (fun () -> Lwt_seq.fold_left (+) 0 a) (function | Failure x when x = "XXX" -> Lwt.return (-1) | exc -> raise exc) in n = (-1) end; test "fold-into-immediate-exception-from-of-seq" begin fun () -> let fail = fun () -> failwith "XXX" in let seq = fail in let a = Lwt_seq.of_seq seq in let+ n = Lwt.catch (fun () -> Lwt_seq.fold_left (+) 0 a) (function | Failure x when x = "XXX" -> Lwt.return (-1) | exc -> raise exc) in n = (-1) end; test "fold-into-exception-from-of-seq-lwt" begin fun () -> let fail = fun () -> failwith "XXX" in let seq: int Lwt.t Seq.t = fun () -> Seq.Cons (Lwt.return 1, fun () -> Seq.Cons (Lwt.return 2, fail)) in let a = Lwt_seq.of_seq_lwt seq in let+ n = Lwt.catch (fun () -> Lwt_seq.fold_left (+) 0 a) (function | Failure x when x = "XXX" -> Lwt.return (-1) | exc -> raise exc) in n = (-1) end; test "fold-into-immediate-exception-from-of-seq-lwt" begin fun () -> let fail = fun () -> failwith "XXX" in let seq: int Lwt.t Seq.t = fail in let a = Lwt_seq.of_seq_lwt seq in let+ n = Lwt.catch (fun () -> Lwt_seq.fold_left (+) 0 a) (function | Failure x when x = "XXX" -> Lwt.return (-1) | exc -> raise exc) in n = (-1) end; ] let fs = [(+); (-); (fun x _ -> x); min; max] let ls = [ []; l; l@l@l; List.rev l; [0;0;0]; [max_int;0;min_int]; [max_int;max_int]; ] let cs = [0;1;max_int;min_int;44;5] let with_flc test = Lwt_list.for_all_s (fun f -> Lwt_list.for_all_s (fun l -> Lwt_list.for_all_s (fun c -> test f l c) cs) ls) fs let equals l1 seq2 = let* l2 = Lwt_seq.to_list seq2 in Lwt.return (l1 = l2) let commutes lf sf l = equals (lf l) (sf (Lwt_seq.of_list l)) let suite_fuzzing = suite "lwt_seq(pseudo-fuzzing)" [ test "map" begin fun () -> with_flc (fun f l c -> let lf = List.map (fun x -> f x c) in let sf = Lwt_seq.map (fun x -> f x c) in commutes lf sf l ) end; test "map_s" begin fun () -> with_flc (fun f l c -> let lf = List.map (fun x -> f x c) in let sf = Lwt_seq.map_s (fun x -> Lwt.return (f x c)) in commutes lf sf l ) end; test "iter" begin fun () -> with_flc (fun f l c -> let lf l = let r = ref c in List.iter (fun x -> r := f !r x) l; [!r] in let sf s = let r = ref c in fun () -> let* () = Lwt_seq.iter (fun x -> r := f !r x) s in Lwt.return (Lwt_seq.Cons (!r, Lwt_seq.empty)) in commutes lf sf l ) end; test "iter_s" begin fun () -> with_flc (fun f l c -> let lf l = let r = ref c in List.iter (fun x -> r := f !r x) l; [!r] in let sf s = let r = ref c in fun () -> let* () = Lwt_seq.iter_s (fun x -> r := f !r x; Lwt.return_unit) s in Lwt.return (Lwt_seq.Cons (!r, Lwt_seq.empty)) in commutes lf sf l ) end; (* the [f]s commute sufficiently for parallel execution *) test "iter_p" begin fun () -> with_flc (fun f l c -> let lf l = let r = ref c in List.iter (fun x -> r := f !r x) l; [!r] in let sf s = Lwt_seq.return_lwt @@ let r = ref c in let+ () = Lwt_seq.iter_p (fun x -> r := f !r x; Lwt.return_unit) s in !r in commutes lf sf l ) end; test "iter_p (pause)" begin fun () -> with_flc (fun f l c -> let lf l = let r = ref c in List.iter (fun x -> r := f !r x) l; [!r] in let sf s = Lwt_seq.return_lwt @@ let r = ref c in let+ () = Lwt_seq.iter_p (fun x -> let* () = pause x in r := f !r x; pause x) s in !r in commutes lf sf l ) end; test "iter_n" begin fun () -> l |> Lwt_list.for_all_s @@ fun max_concurrency -> with_flc (fun f l c -> let lf l = let r = ref c in List.iter (fun x -> r := f !r x) l; [!r] in let sf s = Lwt_seq.return_lwt @@ let r = ref c in let+ () = Lwt_seq.iter_n ~max_concurrency (fun x -> r := f !r x; Lwt.return_unit) s in !r in commutes lf sf l ) end; test "iter_n (pause)" begin fun () -> l |> Lwt_list.for_all_s @@ fun max_concurrency -> with_flc (fun f l c -> let lf l = let r = ref c in List.iter (fun x -> r := f !r x) l; [!r] in let sf s = Lwt_seq.return_lwt @@ let r = ref c in let+ () = Lwt_seq.iter_n ~max_concurrency (fun x -> let* () = pause x in r := f !r x; pause x) s in !r in commutes lf sf l ) end; ] lwt-5.9.1/test/core/test_lwt_sequence.ml000066400000000000000000000305201476253734400203510ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] let filled_sequence () = let s = Lwt_sequence.create () in let _ = Lwt_sequence.add_r 1 s in let _ = Lwt_sequence.add_r 2 s in let _ = Lwt_sequence.add_r 3 s in let _ = Lwt_sequence.add_r 4 s in let _ = Lwt_sequence.add_r 5 s in let _ = Lwt_sequence.add_r 6 s in s let filled_length = 6 let leftmost_value = 1 let rightmost_value = 6 let transfer_sequence () = let s = Lwt_sequence.create () in let _ = Lwt_sequence.add_r 7 s in let _ = Lwt_sequence.add_r 8 s in s let transfer_length = 2 let empty_array = [||] let l_filled_array = [|1; 2; 3; 4; 5; 6|] let r_filled_array = [|6; 5; 4; 3; 2; 1|] let factorial_sequence = 720 let test_iter iter_f array_values seq = let index = ref 0 in Lwt.catch (fun () -> iter_f (fun v -> assert (v = array_values.(!index)); index := (!index + 1)) seq; Lwt.return_true) (function _ -> Lwt.return_false) let test_iter_node iter_f array_values seq = let index = ref 0 in Lwt.catch (fun () -> iter_f (fun n -> assert ((Lwt_sequence.get n) = array_values.(!index)); index := (!index + 1)) seq; Lwt.return_true) (function _ -> Lwt.return_false) let test_iter_rem iter_f array_values seq = let index = ref 0 in Lwt.catch (fun () -> iter_f (fun n -> assert ((Lwt_sequence.get n) = array_values.(!index)); Lwt_sequence.remove n; index := (!index + 1)) seq; Lwt.return_true) (function _ -> Lwt.return_false) let suite = suite "lwt_sequence" [ test "create" begin fun () -> let s = Lwt_sequence.create () in let _ = assert (Lwt_sequence.is_empty s) in let len = Lwt_sequence.length s in Lwt.return (len = 0) end; test "add_l" begin fun () -> let s = Lwt_sequence.create () in let n = Lwt_sequence.add_l 1 s in let _ = assert ((Lwt_sequence.get n) = 1) in let len = Lwt_sequence.length s in Lwt.return (len = 1) end; test "add_r" begin fun () -> let s = Lwt_sequence.create () in let n = Lwt_sequence.add_r 1 s in let _ = assert ((Lwt_sequence.get n) = 1) in let len = Lwt_sequence.length s in Lwt.return (len = 1) end; test "take_l Empty" begin fun () -> let s = Lwt_sequence.create () in Lwt.catch (fun () -> let _ = Lwt_sequence.take_l s in Lwt.return_false) (function | Lwt_sequence.Empty -> Lwt.return_true | _ -> Lwt.return_false) end; test "take_l" begin fun () -> let s = filled_sequence () in Lwt.catch (fun () -> let v = Lwt_sequence.take_l s in Lwt.return (leftmost_value = v)) (function _ -> Lwt.return_false) end; test "take_r Empty" begin fun () -> let s = Lwt_sequence.create () in Lwt.catch (fun () -> let _ = Lwt_sequence.take_r s in Lwt.return_false) (function | Lwt_sequence.Empty -> Lwt.return_true | _ -> Lwt.return_false) end; test "take_r" begin fun () -> let s = filled_sequence () in Lwt.catch (fun () -> let v = Lwt_sequence.take_r s in Lwt.return (rightmost_value = v)) (function _ -> Lwt.return_false) end; test "take_opt_l Empty" begin fun () -> let s = Lwt_sequence.create () in match Lwt_sequence.take_opt_l s with | None -> Lwt.return_true | _ -> Lwt.return_false end; test "take_opt_l" begin fun () -> let s = filled_sequence () in match Lwt_sequence.take_opt_l s with | None -> Lwt.return_false | Some v -> Lwt.return (leftmost_value = v) end; test "take_opt_r Empty" begin fun () -> let s = Lwt_sequence.create () in match Lwt_sequence.take_opt_r s with | None -> Lwt.return_true | _ -> Lwt.return_false end; test "take_opt_r" begin fun () -> let s = filled_sequence () in match Lwt_sequence.take_opt_r s with | None -> Lwt.return_false | Some v -> Lwt.return (rightmost_value = v) end; test "transfer_l Empty" begin fun () -> let s = filled_sequence () in let ts = Lwt_sequence.create () in let _ = Lwt_sequence.transfer_l ts s in let len = Lwt_sequence.length s in Lwt.return (filled_length = len) end; test "transfer_l " begin fun () -> let s = filled_sequence () in let ts = transfer_sequence () in let _ = Lwt_sequence.transfer_l ts s in let len = Lwt_sequence.length s in let _ = assert ((filled_length + transfer_length) = len) in match Lwt_sequence.take_opt_l s with | None -> Lwt.return_false | Some v -> Lwt.return (7 = v) end; test "transfer_r Empty" begin fun () -> let s = filled_sequence () in let ts = Lwt_sequence.create () in let _ = Lwt_sequence.transfer_r ts s in let len = Lwt_sequence.length s in Lwt.return (filled_length = len) end; test "transfer_r " begin fun () -> let s = filled_sequence () in let ts = transfer_sequence () in let _ = Lwt_sequence.transfer_r ts s in let len = Lwt_sequence.length s in let _ = assert ((filled_length + transfer_length) = len) in match Lwt_sequence.take_opt_r s with | None -> Lwt.return_false | Some v -> Lwt.return (8 = v) end; test "iter_l Empty" begin fun () -> test_iter Lwt_sequence.iter_l empty_array (Lwt_sequence.create ()) end; test "iter_l" begin fun () -> test_iter Lwt_sequence.iter_l l_filled_array (filled_sequence ()) end; test "iter_r Empty" begin fun () -> test_iter Lwt_sequence.iter_r empty_array (Lwt_sequence.create ()) end; test "iter_r" begin fun () -> test_iter Lwt_sequence.iter_r r_filled_array (filled_sequence ()) end; test "iter_node_l Empty" begin fun () -> test_iter_node Lwt_sequence.iter_node_l empty_array (Lwt_sequence.create ()) end; test "iter_node_l" begin fun () -> test_iter_node Lwt_sequence.iter_node_l l_filled_array (filled_sequence ()) end; test "iter_node_r Empty" begin fun () -> test_iter_node Lwt_sequence.iter_node_r empty_array (Lwt_sequence.create ()) end; test "iter_node_r" begin fun () -> test_iter_node Lwt_sequence.iter_node_r r_filled_array (filled_sequence ()) end; test "iter_node_l with removal" begin fun () -> test_iter_rem Lwt_sequence.iter_node_l l_filled_array (filled_sequence ()) end; test "iter_node_r with removal" begin fun () -> test_iter_rem Lwt_sequence.iter_node_r r_filled_array (filled_sequence ()) end; test "fold_l" begin fun () -> let acc = Lwt_sequence.fold_l (fun v e -> v * e) (filled_sequence ()) 1 in Lwt.return (factorial_sequence = acc) end; test "fold_l Empty" begin fun () -> let acc = Lwt_sequence.fold_l (fun v e -> v * e) (Lwt_sequence.create ()) 1 in Lwt.return (acc = 1) end; test "fold_r" begin fun () -> let acc = Lwt_sequence.fold_r (fun v e -> v * e) (filled_sequence ()) 1 in Lwt.return (factorial_sequence = acc) end; test "fold_r Empty" begin fun () -> let acc = Lwt_sequence.fold_r (fun v e -> v * e) (Lwt_sequence.create ()) 1 in Lwt.return (acc = 1) end; test "find_node_opt_l Empty" begin fun () -> let s = Lwt_sequence.create () in match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with | None -> Lwt.return_true | _ -> Lwt.return_false end; test "find_node_opt_l not found " begin fun () -> let s = transfer_sequence () in match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with | None -> Lwt.return_true | _ -> Lwt.return_false end; test "find_node_opt_l" begin fun () -> let s = filled_sequence () in match Lwt_sequence.find_node_opt_l (fun v -> v = 1) s with | None -> Lwt.return_false | Some n -> if ((Lwt_sequence.get n) = 1) then Lwt.return_true else Lwt.return_false end; test "find_node_opt_r Empty" begin fun () -> let s = Lwt_sequence.create () in match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with | None -> Lwt.return_true | _ -> Lwt.return_false end; test "find_node_opt_r not found " begin fun () -> let s = transfer_sequence () in match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with | None -> Lwt.return_true | _ -> Lwt.return_false end; test "find_node_opt_r" begin fun () -> let s = filled_sequence () in match Lwt_sequence.find_node_opt_r (fun v -> v = 1) s with | None -> Lwt.return_false | Some n -> if ((Lwt_sequence.get n) = 1) then Lwt.return_true else Lwt.return_false end; test "find_node_l Empty" begin fun () -> let s = Lwt_sequence.create () in Lwt.catch (fun () -> let n = Lwt_sequence.find_node_l (fun v -> v = 1) s in if ((Lwt_sequence.get n) = 1) then Lwt.return_false else Lwt.return_false) (function | Not_found -> Lwt.return_true | _ -> Lwt.return_false) end; test "find_node_l" begin fun () -> let s = filled_sequence () in Lwt.catch (fun () -> let n = Lwt_sequence.find_node_l (fun v -> v = 1) s in if ((Lwt_sequence.get n) = 1) then Lwt.return_true else Lwt.return_false) (function _ -> Lwt.return_false) end; test "find_node_r Empty" begin fun () -> let s = Lwt_sequence.create () in Lwt.catch (fun () -> let n = Lwt_sequence.find_node_r (fun v -> v = 1) s in if ((Lwt_sequence.get n) = 1) then Lwt.return_false else Lwt.return_false) (function | Not_found -> Lwt.return_true | _ -> Lwt.return_false) end; test "find_node_r" begin fun () -> let s = filled_sequence () in Lwt.catch (fun () -> let n = Lwt_sequence.find_node_r (fun v -> v = 1) s in if ((Lwt_sequence.get n) = 1) then Lwt.return_true else Lwt.return_false) (function _ -> Lwt.return_false) end; test "set" begin fun () -> let s = filled_sequence () in match Lwt_sequence.find_node_opt_l (fun v -> v = 4) s with | None -> Lwt.return_false | Some n -> let _ = Lwt_sequence.set n 10 in let data = [|1; 2; 3; 10; 5; 6|] in test_iter Lwt_sequence.iter_l data s end; test "fold_r with multiple removal" begin fun () -> let s = filled_sequence () in let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in let n_two = Lwt_sequence.find_node_r (fun v' -> v' = 2) s in let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in let acc = Lwt_sequence.fold_r begin fun v e -> if v = 3 then begin let _ = Lwt_sequence.remove n_three in let _ = Lwt_sequence.remove n_two in ignore(Lwt_sequence.remove n_four) end; v * e end s 1 in Lwt.return (acc = (factorial_sequence / 2)) end; test "fold_l multiple removal" begin fun () -> let s = filled_sequence () in let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in let n_five = Lwt_sequence.find_node_r (fun v' -> v' = 5) s in let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in let acc = Lwt_sequence.fold_l begin fun v e -> if v = 4 then begin let _ = Lwt_sequence.remove n_four in let _ = Lwt_sequence.remove n_five in ignore(Lwt_sequence.remove n_three) end; v * e end s 1 in Lwt.return (acc = (factorial_sequence / 5)) end; test "find_node_r with multiple removal" begin fun () -> let s = filled_sequence () in let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in let n_two = Lwt_sequence.find_node_r (fun v' -> v' = 2) s in Lwt.catch begin fun () -> let n = Lwt_sequence.find_node_r begin fun v -> if v = 3 then ( let _ = Lwt_sequence.remove n_three in ignore(Lwt_sequence.remove n_two)); v = 1 end s in let v = Lwt_sequence.get n in Lwt.return (v = 1) end (function _ -> Lwt.return_false) end; test "find_node_l with multiple removal" begin fun () -> let s = filled_sequence () in let n_three = Lwt_sequence.find_node_r (fun v' -> v' = 3) s in let n_four = Lwt_sequence.find_node_r (fun v' -> v' = 4) s in Lwt.catch begin fun () -> let n = Lwt_sequence.find_node_l begin fun v -> if v = 3 then ( let _ = Lwt_sequence.remove n_three in ignore(Lwt_sequence.remove n_four)); v = 6 end s in let v = Lwt_sequence.get n in Lwt.return (v = 6) end (function _ -> Lwt.return_false) end; ] lwt-5.9.1/test/core/test_lwt_stream.ml000066400000000000000000000421261476253734400200410ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt open Test let expect_exit f = Lwt.catch (fun () -> f () >>= fun _ -> Lwt.return_false) (function | Exit -> Lwt.return_true | e -> Lwt.reraise e) let suite = suite "lwt_stream" [ test "from" (fun () -> let mvar = Lwt_mvar.create_empty () in let stream = Lwt_stream.from (fun () -> Lwt_mvar.take mvar >>= fun x -> return (Some x)) in let t1 = Lwt_stream.next stream in let t2 = Lwt_stream.next stream in let t3 = Lwt_stream.next stream in Lwt_mvar.put mvar 1 >>= fun () -> t1 >>= fun x1 -> t2 >>= fun x2 -> t3 >>= fun x3 -> return ([x1; x2; x3] = [1; 1; 1])); test "return" (fun () -> let stream = Lwt_stream.return 123 in if Lwt_stream.is_closed stream then Lwt_stream.next stream >>= fun x -> return (x = 123) else Lwt.return_false); test "return_lwt" (fun () -> let lwt = Lwt.return 123 in let stream = Lwt_stream.return_lwt lwt in Lwt_stream.next stream >>= fun x -> return (x = 123 && Lwt_stream.is_closed stream)); test "return_lwt_with_pause" (fun () -> let lwt = Lwt.pause () >>= fun () -> Lwt.return 123 in let stream = Lwt_stream.return_lwt lwt in Lwt_stream.next stream >>= fun x -> return (x = 123 && Lwt_stream.is_closed stream)); test "return_lwt_with_fail" (fun () -> let lwt = Lwt.pause () >>= fun () -> raise (Failure "not today no") in let stream = Lwt_stream.return_lwt lwt in Lwt.catch (fun () -> Lwt_stream.next stream >>= fun _ -> Lwt.return_false) (function | Lwt_stream.Empty -> Lwt.return_true | exc -> raise exc)); test "of_seq" (fun () -> let x = ref false in let nil = fun () -> x := not !x; Seq.Nil in let seq = fun () -> Seq.Cons (1, nil) in let stream = Lwt_stream.of_seq seq in let x_before = !x in let closed_before = Lwt_stream.is_closed stream in Lwt_stream.get stream >>= fun x1 -> let x_middle = !x in Lwt_stream.get stream >>= fun x2 -> let x_after = !x in let closed_after = Lwt_stream.is_closed stream in return ([closed_before; closed_after] = [false; true] && [x_before; x_middle; x_after] = [false; false; true] && [x1; x2] = [Some 1; None])); test "of_lwt_seq" (fun () -> let x = ref false in let nil = fun () -> Lwt.pause () >|= fun () -> x := not !x; Lwt_seq.Nil in let seq = fun () -> Lwt.pause () >|= fun () -> Lwt_seq.Cons (1, nil) in let stream = Lwt_stream.of_lwt_seq seq in let x_before = !x in let closed_before = Lwt_stream.is_closed stream in Lwt_stream.get stream >>= fun x1 -> let x_middle = !x in Lwt_stream.get stream >>= fun x2 -> let x_after = !x in let closed_after = Lwt_stream.is_closed stream in return ([closed_before; closed_after] = [false; true] && [x_before; x_middle; x_after] = [false; false; true] && [x1; x2] = [Some 1; None])); test "of_list" (fun () -> let stream = Lwt_stream.of_list [1; 2; 3] in Lwt_stream.next stream >>= fun x1 -> Lwt_stream.next stream >>= fun x2 -> Lwt_stream.next stream >>= fun x3 -> return ([x1; x2; x3] = [1; 2; 3])); test "clone" (fun () -> let stream1 = Lwt_stream.of_list [1; 2; 3] in let stream2 = Lwt_stream.clone stream1 in Lwt_stream.next stream1 >>= fun x1_1 -> Lwt_stream.next stream2 >>= fun x2_1 -> Lwt_stream.next stream1 >>= fun x1_2 -> Lwt_stream.next stream1 >>= fun x1_3 -> Lwt_stream.next stream2 >>= fun x2_2 -> Lwt_stream.next stream2 >>= fun x2_3 -> return ([x1_1; x1_2; x1_3] = [1; 2; 3] && [x2_1; x2_2; x2_3] = [1; 2; 3])); test "clone 2" (fun () -> let stream1, push = Lwt_stream.create () in push (Some 1); let stream2 = Lwt_stream.clone stream1 in let x1_1 = poll (Lwt_stream.next stream1) in let x1_2 = poll (Lwt_stream.next stream1) in let x2_1 = poll (Lwt_stream.next stream2) in let x2_2 = poll (Lwt_stream.next stream2) in return ([x1_1;x1_2;x2_1;x2_2] = [Some 1;None;Some 1;None])); test "create" (fun () -> let stream, push = Lwt_stream.create () in push (Some 1); push (Some 2); push (Some 3); push None; Lwt_stream.to_list stream >>= fun l -> return (l = [1; 2; 3])); test "create 2" (fun () -> let stream, push = Lwt_stream.create () in push None; let t = Lwt_stream.next stream in return (Lwt.state t = Fail Lwt_stream.Empty)); test "create_bounded" (fun () -> let stream, push = Lwt_stream.create_bounded 3 in let acc = true in let acc = acc && state (push#push 1) = Return () in let acc = acc && state (push#push 2) = Return () in let acc = acc && state (push#push 3) = Return () in let t = push#push 4 in let acc = acc && state t = Sleep in let acc = acc && state (push#push 5) = Fail Lwt_stream.Full in let acc = acc && state (push#push 6) = Fail Lwt_stream.Full in let acc = acc && state (Lwt_stream.get stream) = Return (Some 1) in (* Lwt_stream uses wakeup_later so we have to wait a bit. *) Lwt.pause () >>= fun () -> let acc = acc && state t = Return () in let acc = acc && state (Lwt_stream.get stream) = Return (Some 2) in let acc = acc && state (push#push 7) = Return () in push#close; let acc = acc && state (push#push 8) = Fail Lwt_stream.Closed in let acc = acc && state (Lwt_stream.to_list stream) = Return [3; 4; 7] in return acc); test "create_bounded close" (fun () -> let stream, push = Lwt_stream.create_bounded 1 in let acc = true in let acc = acc && state (push#push 1) = Return () in let iter_delayed = Lwt_stream.to_list stream in Lwt.pause () >>= fun () -> push#close; Lwt.pause () >>= fun () -> let acc = acc && state iter_delayed = Return [1] in return acc ); test "get_while" (fun () -> let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in Lwt_stream.get_while (fun x -> x < 3) stream >>= fun l1 -> Lwt_stream.to_list stream >>= fun l2 -> return (l1 = [1; 2] && l2 = [3; 4; 5])); test "peek" (fun () -> let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in Lwt_stream.peek stream >>= fun x -> Lwt_stream.peek stream >>= fun y -> Lwt_stream.to_list stream >>= fun l -> return (x = Some 1 && y = Some 1 && l = [1; 2; 3; 4; 5])); test "npeek" (fun () -> let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in Lwt_stream.npeek 3 stream >>= fun x -> Lwt_stream.npeek 1 stream >>= fun y -> Lwt_stream.to_list stream >>= fun l -> return (x = [1; 2; 3] && y = [1] && l = [1; 2; 3; 4; 5])); test "get_available" (fun () -> let stream, push = Lwt_stream.create () in push (Some 1); push (Some 2); push (Some 3); let l = Lwt_stream.get_available stream in push (Some 4); Lwt_stream.get stream >>= fun x -> return (l = [1; 2; 3] && x = Some 4)); test "get_available_up_to" (fun () -> let stream, push = Lwt_stream.create () in push (Some 1); push (Some 2); push (Some 3); push (Some 4); let l = Lwt_stream.get_available_up_to 2 stream in Lwt_stream.get stream >>= fun x -> return (l = [1; 2] && x = Some 3)); test "filter" (fun () -> let stream, push = Lwt_stream.create () in push (Some 1); push (Some 2); push (Some 3); push (Some 4); let filtered = Lwt_stream.filter ((=) 3) stream in Lwt_stream.get filtered >>= fun x -> let l = Lwt_stream.get_available filtered in return (x = Some 3 && l = [])); test "filter_map" (fun () -> let stream, push = Lwt_stream.create () in push (Some 1); push (Some 2); push (Some 3); push (Some 4); let filtered = Lwt_stream.filter_map (function 3 -> Some "3" | _ -> None ) stream in Lwt_stream.get filtered >>= fun x -> let l = Lwt_stream.get_available filtered in return (x = Some "3" && l = [])); test "last_new" (fun () -> let stream, push = Lwt_stream.create () in push (Some 1); push (Some 2); push (Some 3); Lwt_stream.last_new stream >>= fun x -> return (x = 3)); test_direct "junk_available" (fun () -> let s, push = Lwt_stream.create () in let b0 = Lwt_stream.get_available s = [] in let () = Lwt_stream.junk_available s in let b1 = Lwt_stream.get_available s = [] in let () = push (Some 1); push (Some 2); push (Some 4) in let () = Lwt_stream.junk_available s in let b2 = Lwt_stream.get_available s = [] in let () = push (Some 66); push (Some 77); push (Some 99) in let () = Lwt_stream.junk_available s in let b3 = Lwt_stream.get_available s = [] in b0 && b1 && b2 && b3); test "junk_old" (fun () -> let open Lwt.Syntax in let s, push = Lwt_stream.create () in let b0 = Lwt_stream.get_available s = [] in let* () = Lwt_stream.junk_old s in let b1 = Lwt_stream.get_available s = [] in let () = push (Some 1); push (Some 2); push (Some 4) in let* () = Lwt_stream.junk_old s in let b2 = Lwt_stream.get_available s = [] in let () = push (Some 66); push (Some 77); push (Some 99) in let* () = Lwt_stream.junk_old s in let b3 = Lwt_stream.get_available s = [] in Lwt.return (b0 && b1 && b2 && b3)) [@ocaml.alert "-deprecated"]; test "cancel push stream 1" (fun () -> let stream, _ = Lwt_stream.create () in let t = Lwt_stream.next stream in cancel t; return (state t = Fail Canceled)); test "cancel push stream 2" (fun () -> let stream, push = Lwt_stream.create () in let t = Lwt_stream.next stream in cancel t; push (Some 1); let t' = Lwt_stream.next stream in return (state t' = Return 1)); test "cancel push stream 3" (fun () -> let stream, push = Lwt_stream.create () in let t1 = Lwt_stream.next stream in let t2 = Lwt_stream.next stream in cancel t1; push (Some 1); t2 >>= fun t2_value -> return (state t1 = Fail Canceled && t2_value = 1)); (* check if the push function keeps references to the elements in the stream *) test "push and GC" (fun () -> let w = Weak.create 5 in (* Count the number of reachable elements in the stream. *) let count () = let rec loop acc idx = if idx = Weak.length w then acc else match Weak.get w idx with | None -> loop acc (idx + 1) | Some _ -> loop (acc + 1) (idx + 1) in loop 0 0 in (* Run some test and return the push function of the stream. *) let test () = let stream, push = Lwt_stream.create () in assert (count () = 0); let r1 = Some(ref 1) in push r1; Weak.set w 1 r1; let r2 = Some(ref 2) in push r2; Weak.set w 2 r2; let r3 = Some(ref 3) in push r3; Weak.set w 3 r3; assert (count () = 3); assert (state (Lwt_stream.next stream) = Return {contents = 1}); Gc.full_major (); (* Ocaml can consider that stream is unreachable before the next line, hence freeing the whole data. *) assert (count () <= 3); push in let push = test () in Gc.full_major (); (* At this point [stream] is unreachable. *) assert (count () = 0); (* We have that to force caml to keep a reference on [push]. *) push (Some(ref 4)); return true); test "map_exn" (fun () -> let l = [Result.Ok 1; Result.Error Exit; Result.Error (Failure "plop"); Result.Ok 42; Result.Error End_of_file] in let q = ref l in let stream = Lwt_stream.from (fun () -> match !q with | [] -> return None | (Result.Ok x)::l -> q := l; return (Some x) | (Result.Error e)::l -> q := l; raise e) in Lwt_stream.to_list (Lwt_stream.wrap_exn stream) >>= fun l' -> return (l = l')); test "is_closed" (fun () -> let b1 = Lwt_stream.(is_closed (of_list [])) in let b2 = Lwt_stream.(is_closed (of_list [1;2;3])) in let b3 = Lwt_stream.(is_closed (of_array [||])) in let b4 = Lwt_stream.(is_closed (of_array [|1;2;3;|])) in let b5 = Lwt_stream.(is_closed (of_string "")) in let b6 = Lwt_stream.(is_closed (of_string "123")) in let b7 = Lwt_stream.(is_closed (from_direct (fun () -> Some 1))) in let st = Lwt_stream.from_direct (fun () -> None) in let b8 = Lwt_stream.is_closed st in ignore (Lwt_stream.junk st); let b9 = Lwt_stream.is_closed st in return (b1 && b2 && b3 && b4 && b5 && b6 && not b7 && not b8 && b9)); test "closed(bind)" (fun () -> let st = Lwt_stream.from_direct ( let value = ref (Some 1) in fun () -> let r = !value in value := None; r) in let b = ref false in Lwt.async (fun () -> Lwt_stream.closed st >|= fun () -> b := Lwt_stream.is_closed st); ignore (Lwt_stream.peek st); let b1 = !b = false in ignore (Lwt_stream.junk st); ignore (Lwt_stream.peek st); let b2 = !b = true in return (b1 && b2)); test "closed(on_termination)" (fun () -> let st = Lwt_stream.from_direct ( let value = ref (Some 1) in fun () -> let r = !value in value := None; r) in let b = ref false in (Lwt.on_termination (Lwt_stream.closed st) (fun () -> b := true)); ignore (Lwt_stream.peek st); let b1 = !b = false in ignore (Lwt_stream.junk st); ignore (Lwt_stream.peek st); let b2 = !b = true in let b3 = Lwt_stream.is_closed st in Lwt.return (b1 && b2 && b3)); test "closed when closed" (fun () -> let st = Lwt_stream.of_list [] in let b = ref false in let b1 = Lwt_stream.is_closed st in (Lwt.on_termination (Lwt_stream.closed st) (fun () -> b := true)); Lwt.return (b1 && !b)); test "choose_exhausted" (fun () -> let open! Lwt_stream in to_list (choose [of_list []]) >|= fun _ -> true); test "exception passing: basic, from" (fun () -> let stream = Lwt_stream.from (fun () -> raise Exit) in expect_exit (fun () -> Lwt_stream.get stream)); test "exception passing: basic, from_direct" (fun () -> let stream = Lwt_stream.from_direct (fun () -> raise Exit) in expect_exit (fun () -> Lwt_stream.get stream)); test "exception passing: to_list" (fun () -> let stream = Lwt_stream.from (fun () -> raise Exit) in expect_exit (fun () -> Lwt_stream.to_list stream)); test "exception passing: mapped" (fun () -> let stream = Lwt_stream.from (fun () -> raise Exit) in let stream = Lwt_stream.map (fun v -> v) stream in expect_exit (fun () -> Lwt_stream.get stream)); test "exception passing: resume, not closed, from" (fun () -> let to_feed = ref (Lwt.fail Exit) in let stream = Lwt_stream.from (fun () -> !to_feed) in expect_exit (fun () -> Lwt_stream.get stream) >>= fun got_exit -> let closed_after_exit = Lwt_stream.is_closed stream in to_feed := Lwt.return (Some 0); Lwt_stream.get stream >>= fun v -> let got_zero = (v = Some 0) in to_feed := Lwt.return_none; Lwt_stream.get stream >>= fun v -> let got_none = (v = None) in let closed_at_end = Lwt_stream.is_closed stream in Lwt.return (got_exit && not closed_after_exit && got_zero && got_none && closed_at_end)); test "exception passing: resume, not closed, from_direct" (fun () -> let to_feed = ref (fun () -> raise Exit) in let stream = Lwt_stream.from_direct (fun () -> !to_feed ()) in expect_exit (fun () -> Lwt_stream.get stream) >>= fun got_exit -> let closed_after_exit = Lwt_stream.is_closed stream in to_feed := (fun () -> Some 0); Lwt_stream.get stream >>= fun v -> let got_zero = (v = Some 0) in to_feed := (fun () -> None); Lwt_stream.get stream >>= fun v -> let got_none = (v = None) in let closed_at_end = Lwt_stream.is_closed stream in Lwt.return (got_exit && not closed_after_exit && got_zero && got_none && closed_at_end)); ] lwt-5.9.1/test/core/test_lwt_switch.ml000066400000000000000000000112401476253734400200400ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix open Test let suite = suite "lwt_switch" [ test "turn_off, add_hook" (fun () -> let hook_1_calls = ref 0 in let hook_2_calls = ref 0 in let hook call_counter () = call_counter := !call_counter + 1; Lwt.return_unit in let switch = Lwt_switch.create () in Lwt_switch.add_hook (Some switch) (hook hook_1_calls); Lwt_switch.add_hook (Some switch) (hook hook_2_calls); let check_1 = !hook_1_calls = 0 in let check_2 = !hook_2_calls = 0 in Lwt_switch.turn_off switch >>= fun () -> let check_3 = !hook_1_calls = 1 in let check_4 = !hook_2_calls = 1 in Lwt_switch.turn_off switch >|= fun () -> let check_5 = !hook_1_calls = 1 in let check_6 = !hook_2_calls = 1 in let check_7 = try Lwt_switch.add_hook (Some switch) (fun () -> Lwt.return_unit); false with Lwt_switch.Off -> true in check_1 && check_2 && check_3 && check_4 && check_5 && check_6 && check_7); test "turn_off: hook exception" (fun () -> let hook () = raise Exit in let switch = Lwt_switch.create () in Lwt_switch.add_hook (Some switch) hook; Lwt.catch (fun () -> Lwt_switch.turn_off switch >|= fun () -> false) (function | Exit -> Lwt.return_true | _ -> Lwt.return_false)); test "with_switch: regular exit" (fun () -> let hook_called = ref false in Lwt_switch.with_switch (fun switch -> Lwt_switch.add_hook (Some switch) (fun () -> hook_called := true; Lwt.return_unit); Lwt.return_unit) >|= fun () -> !hook_called); test "with_switch: exception" (fun () -> let hook_called = ref false in let exception_caught = ref false in Lwt.catch (fun () -> Lwt_switch.with_switch (fun switch -> Lwt_switch.add_hook (Some switch) (fun () -> hook_called := true; Lwt.return_unit); raise Exit)) (function | Exit -> exception_caught := true; Lwt.return_unit | _ -> Lwt.return_unit) >|= fun () -> !hook_called && !exception_caught); test "check" (fun () -> Lwt_switch.check None; let switch = Lwt_switch.create () in Lwt_switch.check (Some switch); Lwt_switch.turn_off switch >|= fun () -> try Lwt_switch.check (Some switch); false with Lwt_switch.Off -> true); test "is_on" (fun () -> let switch = Lwt_switch.create () in let check_1 = Lwt_switch.is_on switch in Lwt_switch.turn_off switch >|= fun () -> let check_2 = not (Lwt_switch.is_on switch) in check_1 && check_2); test "add_hook_or_exec" (fun () -> let hook_calls = ref 0 in let hook () = hook_calls := !hook_calls + 1; Lwt.return_unit in Lwt_switch.add_hook_or_exec None hook >>= fun () -> let check_1 = !hook_calls = 0 in let switch = Lwt_switch.create () in Lwt_switch.add_hook_or_exec (Some switch) hook >>= fun () -> let check_2 = !hook_calls = 0 in Lwt_switch.turn_off switch >>= fun () -> let check_3 = !hook_calls = 1 in Lwt_switch.add_hook_or_exec (Some switch) hook >|= fun () -> let check_4 = !hook_calls = 2 in check_1 && check_2 && check_3 && check_4); test "turn_off waits for hooks: regular exit" (fun () -> let hooks_finished = ref 0 in let hook () = Lwt.pause () >>= fun () -> hooks_finished := !hooks_finished + 1; Lwt.return_unit in let switch = Lwt_switch.create () in Lwt_switch.add_hook (Some switch) hook; Lwt_switch.add_hook (Some switch) hook; Lwt_switch.turn_off switch >|= fun () -> !hooks_finished = 2); test "turn_off waits for hooks: hook exception" (fun () -> let hooks_finished = ref 0 in let successful_hook () = Lwt.pause () >>= fun () -> hooks_finished := !hooks_finished + 1; Lwt.return_unit in let failing_hook () = hooks_finished := !hooks_finished + 1; raise Exit in let switch = Lwt_switch.create () in Lwt_switch.add_hook (Some switch) successful_hook; Lwt_switch.add_hook (Some switch) failing_hook; Lwt_switch.add_hook (Some switch) successful_hook; Lwt.catch (fun () -> Lwt_switch.turn_off switch) (fun _ -> Lwt.return_unit) >|= fun () -> !hooks_finished = 3); ] lwt-5.9.1/test/dune000066400000000000000000000001141476253734400142040ustar00rootroot00000000000000(library (name lwttester) (wrapped false) (libraries lwt unix lwt.unix)) lwt-5.9.1/test/ppx/000077500000000000000000000000001476253734400141415ustar00rootroot00000000000000lwt-5.9.1/test/ppx/dune000066400000000000000000000002031476253734400150120ustar00rootroot00000000000000(test (name main) (package lwt_ppx) (libraries lwttester) (preprocess (pps lwt_ppx)) (flags (:standard -warn-error -22))) lwt-5.9.1/test/ppx/main.ml000066400000000000000000000073031476253734400154220ustar00rootroot00000000000000open Test open Lwt (* Used for the "structure let" test, below. This is wrapped up by the PPX in a call to Lwt_main.run, which is executed at module load time. We can't use a local module inside the tester function, because that function is run inside an outer call to Lwt_main.run, and nested calls to Lwt_main.run are not allowed. *) let%lwt structure_let_result = Lwt.return_true let suite = suite "ppx" [ test "let" (fun () -> let%lwt x = return 3 in return (x + 1 = 4) ) ; test "nested let" (fun () -> let%lwt x = return 3 in let%lwt y = return 4 in return (x + y = 7) ) ; test "and let" (fun () -> let%lwt x = return 3 and y = return 4 in return (x + y = 7) ) ; test "match" (fun () -> let x = Lwt.return (Some 3) in match%lwt x with | Some x -> return (x + 1 = 4) | None -> return false ) ; test "match-exn" (fun () -> let x = Lwt.return (Some 3) in let x' = Lwt.fail Not_found in let%lwt a = match%lwt x with | exception Not_found -> return false | Some x -> return (x = 3) | None -> return false and b = match%lwt x' with | exception Not_found -> return true | _ -> return false in Lwt.return (a && b) ) ; test "if" (fun () -> let x = Lwt.return_true in let%lwt a = if%lwt x then Lwt.return_true else Lwt.return_false in let%lwt b = if%lwt x>|= not then Lwt.return_false else Lwt.return_true in (if%lwt x >|= not then Lwt.return_unit) >>= fun () -> Lwt.return (a && b) ) ; test "for" (* Test for proper sequencing *) (fun () -> let r = ref [] in let f x = let%lwt () = Lwt_unix.sleep 0.2 in Lwt.return (r := x :: !r) in let%lwt () = for%lwt x = 3 to 5 do f x done in return (!r = [5 ; 4 ; 3]) ) ; test "while" (* Test for proper sequencing *) (fun () -> let r = ref [] in let f x = let%lwt () = Lwt_unix.sleep 0.2 in Lwt.return (r := x :: !r) in let%lwt () = let c = ref 2 in while%lwt !c < 5 do incr c ; f !c done in return (!r = [5 ; 4 ; 3]) ) ; test "assert" (fun () -> let%lwt () = assert%lwt true in return true ) ; test "try" (fun () -> try%lwt Lwt.fail Not_found with _ -> return true ) [@warning("@8@11")] ; test "try raise" (fun () -> try%lwt raise Not_found with _ -> return true ) [@warning("@8@11")] ; test "try fallback" (fun () -> try%lwt try%lwt Lwt.fail Not_found with Failure _ -> return false with Not_found -> return true ) [@warning("@8@11")] ; test "finally body" (fun () -> let x = ref false in begin (try%lwt return_unit with | _ -> return_unit ) [%finally x := true; return_unit] end >>= fun () -> return !x ) ; test "finally exn" (fun () -> let x = ref false in begin (try%lwt raise Not_found with | _ -> return_unit ) [%finally x := true; return_unit] end >>= fun () -> return !x ) ; test "finally exn default" (fun () -> let x = ref false in try%lwt ( raise Not_found )[%finally x := true; return_unit] >>= fun () -> return false with Not_found -> return !x ) ; test "structure let" (fun () -> Lwt.return structure_let_result ) ; ] let _ = Test.run "ppx" [ suite ] lwt-5.9.1/test/ppx_let/000077500000000000000000000000001476253734400150055ustar00rootroot00000000000000lwt-5.9.1/test/ppx_let/dune000066400000000000000000000003071476253734400156630ustar00rootroot00000000000000(test (name test) (package lwt_ppx) ;; technically not part of lwt_ppx, but we want it tested and the dependency to ppxlib is already there (preprocess (pps ppx_let)) (libraries lwt lwt.unix)) lwt-5.9.1/test/ppx_let/test.ml000066400000000000000000000007101476253734400163140ustar00rootroot00000000000000let () = let p1 = let open Lwt.Let_syntax in let%bind x = Lwt.return 1 in let%map y = Lwt.return (x + 1) in y + 1 in let p2 = let open Lwt_result.Let_syntax in let%bind x = Lwt_result.return 2 in let%map y = Lwt_result.return (x + 3) in x + y in let p = let%bind.Lwt p1 = p1 in let%map.Lwt_result p2 = p2 in p1 + p2 in let x = Lwt_main.run p in if x = Ok 10 then exit 0 else exit 1 lwt-5.9.1/test/react/000077500000000000000000000000001476253734400144305ustar00rootroot00000000000000lwt-5.9.1/test/react/dune000066400000000000000000000001121476253734400153000ustar00rootroot00000000000000(test (name main) (package lwt_react) (libraries lwt_react lwttester)) lwt-5.9.1/test/react/main.ml000066400000000000000000000003501476253734400157040ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) Test.run "react" [ Test_lwt_event.suite; Test_lwt_signal.suite; ] lwt-5.9.1/test/react/test_lwt_event.ml000066400000000000000000000067011476253734400200340ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt let suite = suite "lwt_event" [ test "to_stream" (fun () -> let event, push = React.E.create () in let stream = Lwt_react.E.to_stream event in let t = Lwt_stream.next stream in assert (state t = Sleep); push 42; return (state t = Return 42)); test "to_stream 2" (fun () -> let event, push = React.E.create () in let stream = Lwt_react.E.to_stream event in push 1; push 2; push 3; Lwt.bind (Lwt_stream.nget 3 stream) (fun l -> return (l = [1; 2; 3]))); test "map_s" (fun () -> let l = ref [] in let event, push = React.E.create () in let event' = Lwt_react.E.map_s (fun x -> l := x :: !l; return ()) event in ignore event'; push 1; return (!l = [1])); test "map_p" (fun () -> let l = ref [] in let event, push = React.E.create () in let event' = Lwt_react.E.map_p (fun x -> l := x :: !l; return ()) event in ignore event'; push 1; return (!l = [1])); test "limit_race" (fun () -> let l = ref [] in let event, push = Lwt_react.E.create() in let prepend n = l := n :: !l in let event' = event |> Lwt_react.E.limit (fun () -> let p = Lwt_unix.sleep 1. in Lwt.async (fun () -> Lwt_unix.sleep 0.1 >|= fun () -> Lwt.on_success p (fun () -> push 2)); p) |> React.E.map prepend in push 0; push 1; Lwt_unix.sleep 2.5 >>= fun () -> let result = !l = [2; 2; 0] in if not result then begin List.iter (Printf.eprintf "%i ") !l; prerr_newline () end; ignore (Sys.opaque_identity event'); return result); test "of_stream" (fun () -> let stream, push = Lwt_stream.create () in let l = ref [] in let event = React.E.map (fun x -> l := x :: !l) (Lwt_react.E.of_stream stream) in ignore event; push (Some 1); push (Some 2); push (Some 3); Lwt.wakeup_paused (); return (!l = [3; 2; 1])); test "limit" (fun () -> let event, push = React.E.create () in let cond = Lwt_condition.create () in let event' = Lwt_react.E.limit (fun () -> Lwt_condition.wait cond) event in let l = ref [] in let event'' = React.E.map (fun x -> l := x :: !l) event' in ignore event'; ignore event''; push 1; push 0; push 2; (* overwrites previous 0 *) Lwt_condition.signal cond (); Lwt.pause () >>= fun () -> push 3; Lwt_condition.signal cond (); Lwt.pause () >>= fun () -> push 4; Lwt_condition.signal cond (); Lwt.pause () >>= fun () -> return (!l = [4; 3; 2; 1])); test "with_finaliser lifetime" begin fun () -> let e, push = React.E.create () in let finalizer_ran = ref false in let e' = Lwt_react.E.with_finaliser (fun () -> finalizer_ran := true) e in Gc.full_major (); let check1 = !finalizer_ran = false in let p = Lwt_react.E.next e' in push (); p >>= fun () -> Gc.full_major (); let check2 = !finalizer_ran = true in Lwt.return (check1 && check2) end; ] lwt-5.9.1/test/react/test_lwt_signal.ml000066400000000000000000000036731476253734400201750ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt let suite = suite "lwt_signal" [ test "limit" (fun () -> let s, push = React.S.create 0 in let cond = Lwt_condition.create () in let s' = Lwt_react.S.limit (fun () -> Lwt_condition.wait cond) s in let l = ref [] in let e = React.E.map (fun x -> l := x :: !l) (React.S.changes s') in ignore e; Lwt_condition.signal cond (); Lwt.pause () >>= fun () -> push 1; push 0; push 2; (* overwrites previous 0 *) Lwt_condition.signal cond (); Lwt.pause () >>= fun () -> push 3; Lwt_condition.signal cond (); Lwt.pause () >>= fun () -> push 4; Lwt_condition.signal cond (); Lwt.pause () >>= fun () -> return (!l = [4; 3; 2; 1])); test "limit race condition" begin fun () -> let change_count = ref 0 in let underlying_signal, set = React.S.create 0 in underlying_signal |> Lwt_react.S.limit (fun () -> let p = Lwt_unix.sleep 1. in Lwt.async (fun () -> Lwt_unix.sleep 0.1 >|= fun () -> Lwt.on_success p (fun () -> set 2)); p) |> React.S.changes |> React.E.map (fun _ -> incr change_count) |> ignore; set 1; Lwt_unix.sleep 2. >|= fun () -> !change_count = 1 end; test "with_finaliser lifetime" begin fun () -> let s, set = React.S.create 0 in let finalizer_ran = ref false in let s' = Lwt_react.S.with_finaliser (fun () -> finalizer_ran := true) s in Gc.full_major (); let check1 = !finalizer_ran = false in let p = Lwt_react.E.next (React.S.changes s') in set 1; p >>= fun _ -> Gc.full_major (); let check2 = !finalizer_ran = true in Lwt.return (check1 && check2) end; ] lwt-5.9.1/test/retry/000077500000000000000000000000001476253734400144775ustar00rootroot00000000000000lwt-5.9.1/test/retry/dune000066400000000000000000000001121476253734400153470ustar00rootroot00000000000000(test (name main) (package lwt_retry) (libraries lwttester lwt_retry)) lwt-5.9.1/test/retry/main.ml000066400000000000000000000131171476253734400157600ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix open Lwt.Syntax module Retry = Lwt_retry let pp = Retry.pp_error ~retry:Format.pp_print_float ~fatal:Format.pp_print_int let suite = suite "lwt_retry" [ test_direct "can format retries outcomes" (fun () -> Format.asprintf "%a" pp (`Retry 3.0) = "`Retry 3."); test_direct "can format fatal outcomes" (fun () -> Format.asprintf "%a" pp (`Fatal 42) = "`Fatal 42"); test_direct "can format with default printer" (fun () -> Format.asprintf "%a" (fun x -> Retry.pp_error x) (`Fatal 42) = "`Fatal "); test "success without retry" (fun () -> let strm = Retry.on_error (fun () -> Lwt.return_ok 42) in let* actual = Lwt_stream.next strm in assert (actual = Ok 42); (* ensure the post condition of an empty stream *) Lwt_stream.is_empty strm); test "does not run extra attempts" (fun () -> let count = ref 0 in let strm = Retry.on_error (fun () -> incr count; Lwt.return_ok 42) in let* actual = Lwt_stream.next strm in assert (actual = Ok 42); (* Force another attempt on the stream *) let+ _ = Lwt_stream.is_empty strm in (* We should have run 1 and only 1 attempt, or else the execution logic is wrong. *) !count = 1); test "just retries" (fun () -> let strm = Retry.on_error (fun () -> Lwt.return_error (`Retry ())) in let retry_attempts = 5 in let expected_retries = List.init retry_attempts (fun i -> Error (`Retry (), i + 1)) in let+ actual_retries = Lwt_stream.nget retry_attempts strm in actual_retries = expected_retries); test "retries before fatal error" (fun () -> let retries_before_fatal = 3 in let i = ref 0 in let strm = Retry.on_error (fun () -> if !i < retries_before_fatal then ( incr i; Lwt.return_error (`Retry ()) ) else Lwt.return_error (`Fatal ())) in let* n_retry_errors = Lwt_stream.nget retries_before_fatal strm >|= List.length in assert (n_retry_errors = retries_before_fatal); let* fatal_error = Lwt_stream.next strm in assert (fatal_error = Error (`Fatal (), retries_before_fatal + 1)); (* ensure the post condition of an empty stream *) Lwt_stream.is_empty strm); test "retries before success" (fun () -> let retries_before_fatal = 3 in let i = ref 0 in let strm = Retry.on_error (fun () -> if !i < retries_before_fatal then ( incr i; Lwt.return_error (`Retry ()) ) else Lwt.return_ok () ) in let* n_retry_errors = Lwt_stream.nget retries_before_fatal strm >|= List.length in assert (n_retry_errors = retries_before_fatal); let* success = Lwt_stream.next strm in assert (success = Ok ()); (* ensure the post condition of an empty stream *) Lwt_stream.is_empty strm); test "[n_times 0] runs one attempt" (fun () -> let operation () = Lwt.return_error (`Retry ()) in let+ attempt = Retry.(operation |> on_error |> n_times 0) in attempt = Error (`Retry (), 1)); test "n_times gives up on a fatal error" (fun () -> let i = ref 0 in let operation () = if !i < 3 then ( incr i; Lwt.return_error (`Retry ()) ) else Lwt.return_error (`Fatal ()) in let+ fatal_error = Retry.(operation |> on_error |> n_times 5) in fatal_error = Error (`Fatal (), 4)); test "n_times gives a retry error when exhausted" (fun () -> let retries = 5 in let operation () = Lwt.return_error (`Retry ()) in let+ result = Retry.(operation |> on_error |> n_times retries) in result = Error (`Retry (), retries + 1)); test "n_times is ok on success" (fun () -> let i = ref 0 in let operation () = if !i < 3 then ( incr i; Lwt.return_error (`Retry ()) ) else Lwt.return_ok () in let+ success = Retry.(operation |> on_error |> n_times 5) in success = Ok ()); test_direct "n_times on negative raises Invalid_argument" (fun () -> let invalid_negative_retries = -5 in let operation () = Lwt.return_error (`Retry ()) in let attempts = Retry.(operation |> on_error) in try let _ = Retry.(attempts |> n_times invalid_negative_retries) in false (* We failed to raise the invalid argument exception *) with Invalid_argument _ -> true); (* test that the sleeps actually throttle computations as desired *) test "with_sleep really does sleep" (fun () -> let duration _ = 0.01 in let operation () = Lwt.return_error (`Retry ()) in (* If [with_sleep] is removed the test fails, as expected *) let retries = Retry.(operation |> on_error |> with_sleep ~duration |> n_times 5) in (* We will expect the [racing_operation] to complete before the retries with_sleep *) let racing_operation = Lwt_unix.sleep (duration ()) >|= Result.ok in let+ actual = Lwt.choose [racing_operation; retries] in actual = Ok ()); ] let () = Test.run "retry" [suite] lwt-5.9.1/test/test.ml000066400000000000000000000230641476253734400146500ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) type test = { test_name : string; skip_if_this_is_false : unit -> bool; sequential : bool; run : unit -> bool Lwt.t; } type outcome = | Passed | Failed | Exception of exn | Skipped exception Skip exception Duplicate_Test_Names of string let test_direct test_name ?(only_if = fun () -> true) run = let run = fun () -> Lwt.return (run ()) in {test_name; skip_if_this_is_false = only_if; sequential = false; run} let test test_name ?(only_if = fun () -> true) ?(sequential = false) run = {test_name; skip_if_this_is_false = only_if; sequential; run} module Log = struct let log_file = let pid = Unix.getpid () in let ms = Unix.gettimeofday () |> modf |> fst in let filename = Printf.sprintf "test.%i.%03.0f.log" pid (ms *. 1e3) in open_out filename let () = at_exit (fun () -> close_out_noerr log_file) let start_time = ref None let elapsed () = let now = Unix.gettimeofday () in match !start_time with | None -> start_time := Some now; 0. | Some start_time -> now -. start_time let write identifier message = Printf.ksprintf (output_string log_file) "%s [%07.3f]: %s\n" identifier (mod_float (elapsed ()) 1000.) message; flush log_file let log k = k (fun identifier -> Printf.ksprintf (write identifier)) end let log = Log.log let run_test : test -> outcome Lwt.t = fun test -> if test.skip_if_this_is_false () = false then begin log @@ (fun k -> k test.test_name "skipping"); Lwt.return Skipped end else begin let start_time = Unix.gettimeofday () in log @@ (fun k -> k test.test_name "starting"); (* Lwt.async_exception_hook handling inspired by https://github.com/mirage/alcotest/issues/45 *) let async_exception_promise, async_exception_occurred = Lwt.task () in let old_async_exception_hook = !Lwt.async_exception_hook in Lwt.async_exception_hook := (fun exn -> Lwt.wakeup_later async_exception_occurred (Exception exn)); Lwt.finalize (fun () -> let test_completion_promise = Lwt.try_bind (fun () -> test.run ()) (fun test_did_pass -> if test_did_pass then Lwt.return Passed else Lwt.return Failed) (function | Skip -> Lwt.return Skipped | exn_raised_by_test -> Lwt.return (Exception exn_raised_by_test)) in Lwt.pick [test_completion_promise; async_exception_promise]) (fun () -> Lwt.async_exception_hook := old_async_exception_hook; let elapsed = Unix.gettimeofday () -. start_time in log @@ (fun k -> k test.test_name "finished in %.3f s" elapsed); Lwt.return_unit) end let outcome_to_character : outcome -> string = function | Passed -> "." | Failed -> "F" | Exception _ -> "E" | Skipped -> "S" type suite = { suite_name : string; suite_tests : test list; skip_suite_if_this_is_false : unit -> bool; } let contains_dup_tests suite tests = let names = List.map (fun t -> "suite:" ^ suite ^ " test:" ^ t.test_name) tests in let sorted_unique_names = List.sort_uniq String.compare names in let counts = List.map (fun x -> let tests = List.find_all (fun y -> y = x) names in (x, List.length tests)) sorted_unique_names in let dups = List.filter (fun (_, count) -> count > 1) counts |> List.map (fun (name, _) -> name) in if List.length dups > 0 then Some dups else None let suite name ?(only_if = fun () -> true) tests = match contains_dup_tests name tests with | Some names -> raise (Duplicate_Test_Names (String.concat ", " names)) | None -> (); {suite_name = name; suite_tests = tests; skip_suite_if_this_is_false = only_if} let run_test_suite : suite -> ((string * outcome) list) Lwt.t = fun suite -> if suite.skip_suite_if_this_is_false () = false then let outcomes = suite.suite_tests |> List.map (fun {test_name; _} -> (test_name, Skipped)) in (outcome_to_character Skipped).[0] |> String.make (List.length outcomes) |> print_string; flush stdout; Lwt.return outcomes else suite.suite_tests |> Lwt_list.map_s begin fun test -> Lwt.bind (run_test test) (fun outcome -> outcome |> outcome_to_character |> print_string; flush stdout; Lwt.return (test.test_name, outcome)) end let outcomes_all_ok : (_ * outcome) list -> bool = fun outcomes -> outcomes |> List.for_all (fun (_test_name, outcome) -> match outcome with | Passed | Skipped -> true | Failed | Exception _ -> false) let show_failures : (string * outcome) list -> unit = List.iter (fun (test_name, outcome) -> match outcome with | Passed | Skipped -> () | Failed -> Printf.eprintf "Test '%s' produced 'false'\n" test_name | Exception exn -> Printf.eprintf "Test '%s' raised '%s'\n" test_name (Printexc.to_string exn)) type ('a, 'b) aggregated_outcomes = ('a * (('b * outcome) list)) list let fold_over_outcomes : ('a -> outcome -> 'a) -> 'a -> (_, _) aggregated_outcomes -> 'a = fun f init outcomes -> List.fold_left (fun accumulator (_suite_name, test_outcomes) -> List.fold_left (fun accumulator (_test_name, test_outcome) -> f accumulator test_outcome) accumulator test_outcomes) init outcomes let count_ran : (_, _) aggregated_outcomes -> int = fun outcomes -> outcomes |> fold_over_outcomes (fun count -> function | Skipped -> count | _ -> count + 1) 0 let count_skipped : (_, _) aggregated_outcomes -> int = fun outcomes -> outcomes |> fold_over_outcomes (fun count -> function | Skipped -> count + 1 | _ -> count) 0 (* Runs a series of test suites. If one of the test suites fails, does not run subsequent suites. *) let run library_name suites = Printexc.record_backtrace true; Printexc.register_printer (function | Failure message -> Some (Printf.sprintf "Failure(%S)" message) | _ -> None); Printf.printf "Testing library '%s'...\n" library_name; let start_time = Unix.gettimeofday () in let rec loop_over_suites aggregated_outcomes suites = match suites with | [] -> let end_time = Unix.gettimeofday () in Printf.printf "\nOk. %i tests ran, %i tests skipped in %.2f seconds\n" (count_ran aggregated_outcomes) (count_skipped aggregated_outcomes) (end_time -. start_time); Lwt.return_unit | suite::rest -> Lwt.bind (run_test_suite suite) begin fun outcomes -> if not (outcomes_all_ok outcomes) then begin print_newline (); flush stdout; Printf.eprintf "Failures in test suite '%s':\n" suite.suite_name; show_failures outcomes; exit 1 end else loop_over_suites ((suite.suite_name, outcomes)::aggregated_outcomes) rest end in loop_over_suites [] suites |> Lwt_main.run let concurrent library_name suites = Printexc.register_printer (function | Failure message -> Some (Printf.sprintf "Failure(%S)" message) | _ -> None); Printf.printf "Testing library '%s'...\n" library_name; let open Lwt.Infix in let run_test (suite, test) = begin if suite.skip_suite_if_this_is_false () = false then Lwt.return Skipped else run_test test end >|= fun outcome -> print_string (outcome_to_character outcome); flush stdout; ((suite, test), outcome) in let start_time = Unix.gettimeofday () in (* List all the tests. *) suites |> List.map (fun suite -> suite.suite_tests |> List.map (fun test -> (suite, test))) |> List.flatten (* Separate the tests that must be run sequentially, and run them. *) |> List.partition (fun (_suite, test) -> test.sequential) |> fun (sequential, concurrent) -> Lwt_list.map_s run_test sequential >>= fun sequential_outcomes -> (* Run the tests that can be run concurrently. *) concurrent |> Lwt_list.map_p run_test (* Summarize the results. *) >>= fun concurrent_outcomes -> let outcomes = sequential_outcomes @ concurrent_outcomes in if outcomes_all_ok outcomes then let end_time = Unix.gettimeofday () in let aggregated_outcomes = [(), outcomes] in Printf.printf "\nOk. %i tests ran, %i tests skipped in %.2f seconds\n" (count_ran aggregated_outcomes) (count_skipped aggregated_outcomes) (end_time -. start_time); Lwt.return_unit else begin print_newline (); flush stdout; outcomes |> List.iter (function | (suite, test), Failed -> Printf.eprintf "Test '%s' in suite '%s' produced 'false'\n" test.test_name suite.suite_name | (suite, test), Exception exn -> Printf.eprintf "Test '%s' in suite '%s' raised '%s'\n" test.test_name suite.suite_name (Printexc.to_string exn) | _ -> ()); exit 1 end let concurrent library_name suites = Lwt_main.run (concurrent library_name suites) let with_async_exception_hook hook f = let old_hook = !Lwt.async_exception_hook in Lwt.async_exception_hook := hook; Lwt.finalize f (fun () -> Lwt.async_exception_hook := old_hook; Lwt.return_unit) let instrument = function | true -> Printf.ksprintf (fun _s -> true) | false -> Printf.ksprintf (fun s -> prerr_endline ("\n" ^ s); false) lwt-5.9.1/test/test.mli000066400000000000000000000033611476253734400150170ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (** Helpers for tests. *) type test (** Type of a test *) type suite (** Type of a suite of tests *) exception Skip (** In some tests, it is only clear that the test should be skipped after it has started running (for example, after an attempted system call raises a certain exception, indicating it is not supported). Such tests should raise [Test.Skip], or reject their final promise with [Test.Skip]. *) val test_direct : string -> ?only_if:(unit -> bool) -> (unit -> bool) -> test (** Defines a test. [run] must returns [true] if the test succeeded and [false] otherwise. [only_if] is used to conditionally skip the test. *) val test : string -> ?only_if:(unit -> bool) -> ?sequential:bool -> (unit -> bool Lwt.t) -> test (** Like [test_direct], but defines a test which runs a thread. *) val suite : string -> ?only_if:(unit -> bool) -> test list -> suite (** Defines a suite of tests *) val run : string -> suite list -> unit (** Run all the given tests and exit the program with an exit code of [0] if all tests succeeded and with [1] otherwise. *) val concurrent : string -> suite list -> unit (** Same as [run], but runs all the tests concurrently. *) val with_async_exception_hook : (exn -> unit) -> (unit -> 'a Lwt.t) -> 'a Lwt.t (** [Test.with_async_exception_hook hook f] sets [!Lwt.async_exception_hook] to [hook], runs [f ()], and then restores [!Lwt.async_exception_hook] to its former value. *) val instrument : bool -> ('a, unit, string, bool) format4 -> 'a (** Acts like [Printf.eprintf], but prints nothing if the boolean is [true]. *) lwt-5.9.1/test/test_unix.ml000066400000000000000000000011431476253734400157050ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) let temp_name = let rng = Random.State.make_self_init () in fun () -> let number = Random.State.int rng 10000 in Printf.sprintf "lwt-testing-%04d" number let temp_file () = Filename.temp_file ~temp_dir:"." "lwt-testing-" "" let temp_directory () = let rec attempt () = let path = temp_name () in try Unix.mkdir path 0o755; path with Unix.Unix_error (Unix.EEXIST, "mkdir", _) -> attempt () in attempt () lwt-5.9.1/test/test_unix.mli000066400000000000000000000010311476253734400160520ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) val temp_name : unit -> string (** Generates the name of a temporary file (or directory) in [_build/]. Note that a file at the path may already exist. *) val temp_file : unit -> string (** Creates a temporary file in [_build/] and evaluates to its path. *) val temp_directory : unit -> string (** Creates a temporary directory in [build/] and evaluates to its path. *) lwt-5.9.1/test/unix/000077500000000000000000000000001476253734400143155ustar00rootroot00000000000000lwt-5.9.1/test/unix/bytes_io_data000066400000000000000000000000071476253734400170430ustar00rootroot00000000000000abcdef lwt-5.9.1/test/unix/dummy.ml000066400000000000000000000016671476253734400160140ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) let test_input_str = "the quick brown fox jumps over the lazy dog" let test_input = Bytes.of_string test_input_str let test_input_len = Bytes.length test_input let read () = let buf = Bytes.create test_input_len in let rec aux n = let i = Unix.read Unix.stdin buf n (Bytes.length buf - n) in if i = 0 || n + i = test_input_len then Bytes.equal buf test_input else aux (n + i) in if aux 0 then (* make sure there's nothing more to read *) 0 = Unix.read Unix.stdin buf 0 1 else false let write fd = assert (test_input_len = Unix.write fd test_input 0 test_input_len) let () = match Sys.argv.(1) with | "read" -> exit @@ if read () then 0 else 1 | "write" -> write Unix.stdout | "errwrite" -> write Unix.stderr | _ -> invalid_arg "Sys.argv" lwt-5.9.1/test/unix/dune000066400000000000000000000017001476253734400151710ustar00rootroot00000000000000(library (name tester) (libraries lwt lwttester) (modules (:standard \ main dummy ocaml_runtime_exc_1 ocaml_runtime_exc_2 ocaml_runtime_exc_3 ocaml_runtime_exc_4 ocaml_runtime_exc_5 ocaml_runtime_exc_6))) (executable (name dummy) (modules dummy) (libraries unix)) (test (name main) (package lwt) (libraries lwttester tester) (modules main) (deps bytes_io_data %{exe:dummy.exe})) (test (name ocaml_runtime_exc_1) (libraries lwt lwt.unix) (modules ocaml_runtime_exc_1)) (test (name ocaml_runtime_exc_2) (libraries lwt lwt.unix) (modules ocaml_runtime_exc_2)) (test (name ocaml_runtime_exc_3) (libraries lwt lwt.unix) (modules ocaml_runtime_exc_3)) (test (name ocaml_runtime_exc_4) (libraries lwt lwt.unix) (modules ocaml_runtime_exc_4)) (test (name ocaml_runtime_exc_5) (libraries lwt lwt.unix) (modules ocaml_runtime_exc_5)) (test (name ocaml_runtime_exc_6) (libraries lwt lwt.unix) (modules ocaml_runtime_exc_6)) lwt-5.9.1/test/unix/main.ml000066400000000000000000000007431476253734400155770ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Tester let () = Test.concurrent "unix" [ Test_lwt_unix.suite; Test_lwt_io.suite; Test_lwt_io_non_block.suite; Test_lwt_process.suite; Test_lwt_engine.suite; Test_mcast.suite; Test_lwt_fmt.suite; Test_lwt_timeout.suite; Test_lwt_bytes.suite; Test_sleep_and_timeout.suite; ] lwt-5.9.1/test/unix/ocaml_runtime_exc_1.ml000066400000000000000000000017771476253734400206000ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* set the exception filter being tested *) let () = Lwt.Exception_filter.(set handle_all_except_runtime) (* OCaml runtime exceptions (out-of-memory, stack-overflow) are fatal in a different way than other exceptions and they leave the Lwt main loop in an inconsistent state where it cannot be restarted. Indeed, attempting to call [Lwt_main.run] again after it has crashed with a runtime exception causes a "Nested calls to Lwt_main.run are not allowed" error. For this reason, we run this test as its own executable rather than as part of a larger suite. *) open Lwt.Syntax let test () = try let () = Lwt_main.run ( let* () = Lwt.pause () in if true then raise Out_of_memory else Lwt.return_unit ) in Printf.eprintf "Test run+raise failure\n"; Stdlib.exit 1 with | Out_of_memory -> () let () = test () lwt-5.9.1/test/unix/ocaml_runtime_exc_2.ml000066400000000000000000000020101476253734400205560ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* set the exception filter being tested *) let () = Lwt.Exception_filter.(set handle_all_except_runtime) (* OCaml runtime exceptions (out-of-memory, stack-overflow) are fatal in a different way than other exceptions and they leave the Lwt main loop in an inconsistent state where it cannot be restarted. Indeed, attempting to call [Lwt_main.run] again after it has crashed with a runtime exception causes a "Nested calls to Lwt_main.run are not allowed" error. For this reason, we run this test as its own executable rather than as part of a larger suite. *) open Lwt.Syntax let test () = try let () = Lwt_main.run ( let* () = Lwt_unix.sleep 0.001 in if true then raise Out_of_memory else Lwt.return_unit ) in Printf.eprintf "Test run+raise failure\n"; Stdlib.exit 1 with | Out_of_memory -> () let () = test () lwt-5.9.1/test/unix/ocaml_runtime_exc_3.ml000066400000000000000000000020641476253734400205700ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* set the exception filter being tested *) let () = Lwt.Exception_filter.(set handle_all_except_runtime) (* OCaml runtime exceptions (out-of-memory, stack-overflow) are fatal in a different way than other exceptions and they leave the Lwt main loop in an inconsistent state where it cannot be restarted. Indeed, attempting to call [Lwt_main.run] again after it has crashed with a runtime exception causes a "Nested calls to Lwt_main.run are not allowed" error. For this reason, we run this test as its own executable rather than as part of a larger suite. *) open Lwt.Syntax let test () = try let () = Lwt_main.run ( let* () = Lwt.pause () in Lwt.choose [ (let* () = Lwt.pause () in raise Out_of_memory); Lwt_unix.sleep 2.; ] ) in Printf.eprintf "Test run+raise failure\n"; Stdlib.exit 1 with | Out_of_memory -> () let () = test () lwt-5.9.1/test/unix/ocaml_runtime_exc_4.ml000066400000000000000000000020401476253734400205630ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* set the exception filter being tested *) let () = Lwt.Exception_filter.(set handle_all_except_runtime) (* OCaml runtime exceptions (out-of-memory, stack-overflow) are fatal in a different way than other exceptions and they leave the Lwt main loop in an inconsistent state where it cannot be restarted. Indeed, attempting to call [Lwt_main.run] again after it has crashed with a runtime exception causes a "Nested calls to Lwt_main.run are not allowed" error. For this reason, we run this test as its own executable rather than as part of a larger suite. *) open Lwt.Syntax let test () = try let () = Lwt_main.run ( let* () = Lwt.pause () in Lwt.catch (fun () -> raise Out_of_memory) (fun _ -> Lwt.return_unit) ) in Printf.eprintf "Test run+raise failure\n"; Stdlib.exit 1 with | Out_of_memory -> () let () = test () lwt-5.9.1/test/unix/ocaml_runtime_exc_5.ml000066400000000000000000000021131476253734400205650ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* set the exception filter being tested *) let () = Lwt.Exception_filter.(set handle_all_except_runtime) (* OCaml runtime exceptions (out-of-memory, stack-overflow) are fatal in a different way than other exceptions and they leave the Lwt main loop in an inconsistent state where it cannot be restarted. Indeed, attempting to call [Lwt_main.run] again after it has crashed with a runtime exception causes a "Nested calls to Lwt_main.run are not allowed" error. For this reason, we run this test as its own executable rather than as part of a larger suite. *) open Lwt.Syntax let test () = try let () = Lwt_main.run ( let* () = Lwt.pause () in let _ = Lwt.async (fun () -> let* () = Lwt.pause () in raise Out_of_memory) in Lwt_unix.sleep 0.5 ) in Printf.eprintf "Test run+raise failure\n"; Stdlib.exit 1 with | Out_of_memory -> () let () = test () lwt-5.9.1/test/unix/ocaml_runtime_exc_6.ml000066400000000000000000000021471476253734400205750ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* set the exception filter being tested *) let () = Lwt.Exception_filter.(set handle_all_except_runtime) (* OCaml runtime exceptions (out-of-memory, stack-overflow) are fatal in a different way than other exceptions and they leave the Lwt main loop in an inconsistent state where it cannot be restarted. Indeed, attempting to call [Lwt_main.run] again after it has crashed with a runtime exception causes a "Nested calls to Lwt_main.run are not allowed" error. For this reason, we run this test as its own executable rather than as part of a larger suite. *) open Lwt.Syntax let test () = try let () = Lwt_main.run ( let* () = Lwt.pause () in let _ = Lwt.dont_wait (fun () -> let* () = Lwt.pause () in raise Out_of_memory) (fun _ -> ()) in Lwt_unix.sleep 0.5 ) in Printf.eprintf "Test run+raise failure\n"; Stdlib.exit 1 with | Out_of_memory -> () let () = test () lwt-5.9.1/test/unix/test_lwt_bytes.ml000066400000000000000000000711351476253734400177310ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix open Test let bytes_equal (b1:Bytes.t) (b2:Bytes.t) = b1 = b2 let tcp_server_client_exchange server_logic client_logic = let server_is_ready, notify_server_is_ready = Lwt.wait () in let server () = let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in let sockaddr = Lwt_unix.ADDR_INET (Unix.inet_addr_loopback, 0) in Lwt_unix.bind sock sockaddr >>= fun () -> let server_address = Lwt_unix.getsockname sock in let () = Lwt_unix.listen sock 5 in Lwt.wakeup_later notify_server_is_ready server_address; Lwt_unix.accept sock >>= fun (fd_client, _) -> server_logic fd_client >>= fun _n -> Lwt_unix.close fd_client >>= fun () -> Lwt_unix.close sock in let client () = server_is_ready >>= fun sockaddr -> let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in Lwt_unix.connect sock sockaddr >>= fun () -> client_logic sock >>= fun _n -> Lwt_unix.close sock in Lwt.join [client (); server ()] let udp_server_client_exchange server_logic client_logic = let server_is_ready, notify_server_is_ready = Lwt.wait () in let server () = let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in let sockaddr = Lwt_unix.ADDR_INET (Unix.inet_addr_loopback, 0) in Lwt_unix.bind sock sockaddr >>= fun () -> let server_address = Lwt_unix.getsockname sock in Lwt.wakeup_later notify_server_is_ready server_address; server_logic sock >>= fun (_n, _sockaddr) -> Lwt_unix.close sock in let client () = server_is_ready >>= fun sockaddr -> let sock = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in client_logic sock sockaddr >>= fun (_n) -> Lwt_unix.close sock in Lwt.join [client (); server ()] let gen_buf n = let buf = Lwt_bytes.create n in let () = Lwt_bytes.fill buf 0 n '\x00' in buf (* The two following helpers only focus on the behavior of * Lwt_bytes.mincore and Lwt_bytes.wait_mincore with different arguments that * represents correct or bad bounds. * * The main purposes of those functions are not tested. * *) let file_suffix = let last_file_suffix = ref 0 in fun () -> incr last_file_suffix; !last_file_suffix let test_mincore buff_len offset n_states = let test_file = Printf.sprintf "bytes_mincore_write_%i" (file_suffix ()) in Lwt_unix.openfile test_file [O_RDWR;O_TRUNC; O_CREAT] 0o666 >>= fun fd -> let buf_write = gen_buf buff_len in Lwt_bytes.write fd buf_write 0 buff_len >>= fun _n -> Lwt_unix.close fd >>= fun () -> let fd = Unix.openfile test_file [O_RDONLY] 0 in let shared = false in let size = buff_len in let buffer = Lwt_bytes.map_file ~fd ~shared ~size () in let states = Array.make n_states false in let () = Lwt_bytes.mincore buffer offset states in Lwt.return_unit let test_wait_mincore buff_len offset = let test_file = Printf.sprintf "bytes_mincore_write_%i" (file_suffix ()) in Lwt_unix.openfile test_file [O_RDWR;O_TRUNC; O_CREAT] 0o666 >>= fun fd -> let buf_write = gen_buf buff_len in Lwt_bytes.write fd buf_write 0 buff_len >>= fun _n -> Lwt_unix.close fd >>= fun () -> let fd = Unix.openfile test_file [O_RDONLY] 0 in let shared = false in let size = buff_len in let buffer = Lwt_bytes.map_file ~fd ~shared ~size () in Lwt_bytes.wait_mincore buffer offset let suite = suite "lwt_bytes" [ test "create" begin fun () -> let len = 5 in let buff = Lwt_bytes.create len in let len' = Bigarray.Array1.dim buff in Lwt.return (len = len') end; test "get/set" begin fun () -> let buff = Lwt_bytes.create 4 in let () = Lwt_bytes.set buff 0 'a' in let () = Lwt_bytes.set buff 1 'b' in let () = Lwt_bytes.set buff 2 'c' in let check = Lwt_bytes.get buff 0 = 'a' && Lwt_bytes.get buff 1 = 'b' && Lwt_bytes.get buff 2 = 'c' in Lwt.return check end; test "get out of bounds : lower limit" begin fun () -> let buff = Lwt_bytes.create 3 in match Lwt_bytes.get buff (-1) with | exception Invalid_argument _ -> Lwt.return_true | _ -> Lwt.return_false end; test "get out of bounds : upper limit" begin fun () -> let buff = Lwt_bytes.create 3 in match Lwt_bytes.get buff 3 with | exception Invalid_argument _ -> Lwt.return_true | _ -> Lwt.return_false end; test "set out of bounds : lower limit" begin fun () -> let buff = Lwt_bytes.create 3 in match Lwt_bytes.set buff (-1) 'a' with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "set out of bounds : upper limit" begin fun () -> let buff = Lwt_bytes.create 3 in match Lwt_bytes.set buff 3 'a' with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "unsafe_get/unsafe_set" begin fun () -> let buff = Lwt_bytes.create 4 in let () = Lwt_bytes.unsafe_set buff 0 'a' in let () = Lwt_bytes.unsafe_set buff 1 'b' in let () = Lwt_bytes.unsafe_set buff 2 'c' in let check = Lwt_bytes.unsafe_get buff 0 = 'a' && Lwt_bytes.unsafe_get buff 1 = 'b' && Lwt_bytes.unsafe_get buff 2 = 'c' in Lwt.return check end; test "of bytes" begin fun () -> let bytes = Bytes.of_string "abc" in let buff = Lwt_bytes.of_bytes bytes in let check = Lwt_bytes.get buff 0 = Bytes.get bytes 0 && Lwt_bytes.get buff 1 = Bytes.get bytes 1 && Lwt_bytes.get buff 2 = Bytes.get bytes 2 in Lwt.return check end; test "of string" begin fun () -> let buff = Lwt_bytes.of_string "abc" in let check = Lwt_bytes.get buff 0 = 'a' && Lwt_bytes.get buff 1 = 'b' && Lwt_bytes.get buff 2 = 'c' in Lwt.return check end; test "to bytes" begin fun () -> let bytes = Bytes.of_string "abc" in let buff = Lwt_bytes.of_bytes bytes in let bytes' = Lwt_bytes.to_bytes buff in let check = bytes_equal bytes bytes' in Lwt.return check end; test "to string" begin fun () -> let str = "abc" in let buff = Lwt_bytes.of_string str in let str' = Lwt_bytes.to_string buff in let check = str = str' in Lwt.return check end; test "blit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in let () = Lwt_bytes.blit buf1 0 buf2 3 3 in let check = "abcabc" = Lwt_bytes.to_string buf2 in Lwt.return check end; test "blit source out of bounds: lower limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit buf1 (-1) buf2 3 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit source out of bounds: upper limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit buf1 1 buf2 3 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit destination out of bounds: lower limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit buf1 0 buf2 (-1) 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit destination out of bounds: upper limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit buf1 0 buf2 4 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit length out of bounds: lower limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit buf1 0 buf2 3 (-1) with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from bytes" begin fun () -> let bytes1 = Bytes.of_string "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in let () = Lwt_bytes.blit_from_bytes bytes1 0 buf2 3 3 in let check = "abcabc" = Lwt_bytes.to_string buf2 in Lwt.return check end; test "blit from bytes source out of bounds: lower limit" begin fun () -> let bytes1 = Bytes.of_string "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_bytes bytes1 (-1) buf2 3 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from bytes source out of bounds: upper limit" begin fun () -> let bytes1 = Bytes.of_string "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_bytes bytes1 1 buf2 3 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from bytes destination out of bounds: lower limit" begin fun () -> let bytes1 = Bytes.of_string "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_bytes bytes1 0 buf2 (-1) 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from bytes destination out of bounds: upper limit" begin fun () -> let bytes1 = Bytes.of_string "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_bytes bytes1 0 buf2 4 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from bytes length out of bounds: lower limit" begin fun () -> let bytes1 = Bytes.of_string "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_bytes bytes1 0 buf2 3 (-1) with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from string" begin fun () -> let string1 = "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in let () = Lwt_bytes.blit_from_string string1 0 buf2 3 3 in let check = "abcabc" = Lwt_bytes.to_string buf2 in Lwt.return check end; test "blit from string source out of bounds: lower limit" begin fun () -> let string1 = "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_string string1 (-1) buf2 3 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from string source out of bounds: upper limit" begin fun () -> let string1 = "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_string string1 1 buf2 3 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from string destination out of bounds: lower limit" begin fun () -> let string1 = "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_string string1 0 buf2 (-1) 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from string destination out of bounds: upper limit" begin fun () -> let string1 = "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_string string1 0 buf2 4 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from string length out of bounds: lower limit" begin fun () -> let string1 = "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_string string1 0 buf2 3 (-1) with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit from string length out of bounds: upper limit" begin fun () -> let string1 = "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in match Lwt_bytes.blit_from_string string1 0 buf2 3 10 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit to bytes" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let bytes2 = Bytes.of_string str2 in let () = Lwt_bytes.blit_to_bytes buf1 0 bytes2 3 3 in let check = "abcabc" = Bytes.to_string bytes2 in Lwt.return check end; test "blit to bytes source out of bounds: lower limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let bytes2 = Bytes.of_string str2 in match Lwt_bytes.blit_to_bytes buf1 (-1) bytes2 3 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit to bytes source out of bounds: upper limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let bytes2 = Bytes.of_string str2 in match Lwt_bytes.blit_to_bytes buf1 1 bytes2 3 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit to bytes destination out of bounds: lower limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let bytes2 = Bytes.of_string str2 in match Lwt_bytes.blit_to_bytes buf1 0 bytes2 (-1) 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit to bytes destination out of bounds: upper limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let bytes2 = Bytes.of_string str2 in match Lwt_bytes.blit_to_bytes buf1 0 bytes2 4 3 with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "blit to bytes length out of bounds: lower limit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let bytes2 = Bytes.of_string str2 in match Lwt_bytes.blit_to_bytes buf1 0 bytes2 3 (-1) with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "unsafe blit" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in let () = Lwt_bytes.unsafe_blit buf1 0 buf2 3 3 in let check = "abcabc" = Lwt_bytes.to_string buf2 in Lwt.return check end; test "unsafe blit from bytes" begin fun () -> let bytes1 = Bytes.of_string "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in let () = Lwt_bytes.unsafe_blit_from_bytes bytes1 0 buf2 3 3 in let check = "abcabc" = Lwt_bytes.to_string buf2 in Lwt.return check end; test "unsafe blit from string" begin fun () -> let string1 = "abc" in let str2 = "abcdef" in let buf2 = Lwt_bytes.of_string str2 in let () = Lwt_bytes.unsafe_blit_from_string string1 0 buf2 3 3 in let check = "abcabc" = Lwt_bytes.to_string buf2 in Lwt.return check end; test "unsafe blit to bytes" begin fun () -> let str1 = "abc" in let buf1 = Lwt_bytes.of_string str1 in let str2 = "abcdef" in let bytes2 = Bytes.of_string str2 in let () = Lwt_bytes.unsafe_blit_to_bytes buf1 0 bytes2 3 3 in let check = "abcabc" = Bytes.to_string bytes2 in Lwt.return check end; test "proxy" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in let buf' = Lwt_bytes.proxy buf 3 3 in let check1 = "def" = Lwt_bytes.to_string buf' in let () = Lwt_bytes.set buf 3 'a' in let check2 = "aef" = Lwt_bytes.to_string buf' in Lwt.return (check1 && check2) end; test "proxy offset out of bounds: lower limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.proxy buf (-1) 3 with | exception Invalid_argument _ -> Lwt.return_true | _ -> Lwt.return_false end; test "proxy offset out of bounds: upper limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.proxy buf 4 3 with | exception Invalid_argument _ -> Lwt.return_true | _ -> Lwt.return_false end; test "proxy length out of bounds: lower limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.proxy buf 3 (-1) with | exception Invalid_argument _ -> Lwt.return_true | _ -> Lwt.return_false end; test "extract" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in let buf' = Lwt_bytes.extract buf 3 3 in let check = "def" = Lwt_bytes.to_string buf' in Lwt.return check end; test "extract offset out of bounds: lower limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.extract buf (-1) 3 with | exception Invalid_argument _ -> Lwt.return_true | _ -> Lwt.return_false end; test "extract offset out of bounds: upper limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.extract buf 4 3 with | exception Invalid_argument _ -> Lwt.return_true | _ -> Lwt.return_false end; test "extract length out of bounds: lower limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.extract buf 3 (-1) with | exception Invalid_argument _ -> Lwt.return_true | _ -> Lwt.return_false end; test "copy" begin fun () -> let str = "abc" in let buf = Lwt_bytes.of_string str in let buf' = Lwt_bytes.copy buf in let check = str = Lwt_bytes.to_string buf' in Lwt.return check end; test "fill" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in let () = Lwt_bytes.fill buf 3 3 'a' in let check = "abcaaa" = Lwt_bytes.to_string buf in Lwt.return check end; test "fill offset out of bounds: lower limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.fill buf (-1) 3 'a' with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "fill offset out of bounds: upper limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.fill buf 4 3 'a' with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "fill length out of bounds lower limit" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in match Lwt_bytes.fill buf 3 (-1) 'a' with | exception Invalid_argument _ -> Lwt.return_true | () -> Lwt.return_false end; test "unsafe fill" begin fun () -> let str = "abcdef" in let buf = Lwt_bytes.of_string str in let () = Lwt_bytes.unsafe_fill buf 3 3 'a' in let check = "abcaaa" = Lwt_bytes.to_string buf in Lwt.return check end; test "bytes read" begin fun () -> let test_file = "bytes_io_data" in Lwt_unix.openfile test_file [O_RDONLY] 0 >>= fun fd -> let buf = Lwt_bytes.create 6 in Lwt_bytes.read fd buf 0 6 >>= fun _n -> let check = "abcdef" = Lwt_bytes.to_string buf in Lwt_unix.close fd >>= fun () -> Lwt.return check end; test "read: buffer retention" ~sequential:true begin fun () -> let buffer = Lwt_bytes.create 3 in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking read_fd true; Lwt_unix.write_string write_fd "foo" 0 3 >>= fun _ -> let retained = Lwt_unix.retained buffer in Lwt_bytes.read read_fd buffer 0 3 >>= fun _ -> Lwt_unix.close write_fd >>= fun () -> Lwt_unix.close read_fd >|= fun () -> !retained end; test "bytes write" begin fun () -> let test_file = "bytes_io_data_write" in Lwt_unix.openfile test_file [O_RDWR;O_TRUNC; O_CREAT] 0o666 >>= fun fd -> let buf_write = Lwt_bytes.of_string "abc" in Lwt_bytes.write fd buf_write 0 3 >>= fun _n -> Lwt_unix.close fd >>= fun () -> Lwt_unix.openfile test_file [O_RDONLY] 0 >>= fun fd -> let buf_read = Lwt_bytes.create 3 in Lwt_bytes.read fd buf_read 0 3 >>= fun _n -> let check = buf_write = buf_read in Lwt_unix.close fd >>= fun () -> Lwt.return check end; test "write: buffer retention" ~sequential:true begin fun () -> let buffer = Lwt_bytes.create 3 in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking write_fd true; let retained = Lwt_unix.retained buffer in Lwt_bytes.write write_fd buffer 0 3 >>= fun _ -> Lwt_unix.close write_fd >>= fun () -> Lwt_unix.close read_fd >|= fun () -> !retained end; test "bytes recv" ~only_if:(fun () -> not Sys.win32) begin fun () -> let buf = gen_buf 6 in let server_logic socket = Lwt_unix.write_string socket "abcdefghij" 0 9 in let client_logic socket = Lwt_bytes.recv socket buf 0 6 [] in tcp_server_client_exchange server_logic client_logic >>= fun () -> let check = "abcdef" = Lwt_bytes.to_string buf in Lwt.return check end; test "bytes send" ~only_if:(fun () -> not Sys.win32) begin fun () -> let buf = gen_buf 6 in let server_logic socket = Lwt_bytes.send socket (Lwt_bytes.of_string "abcdef") 0 6 [] in let client_logic socket = Lwt_bytes.recv socket buf 0 6 [] in tcp_server_client_exchange server_logic client_logic >>= fun () -> let check = "abcdef" = Lwt_bytes.to_string buf in Lwt.return check end; test "bytes recvfrom" ~only_if:(fun () -> not Sys.win32) begin fun () -> let buf = gen_buf 6 in let server_logic socket = Lwt_bytes.recvfrom socket buf 0 6 [] in let client_logic socket sockaddr = Lwt_unix.sendto socket (Bytes.of_string "abcdefghij") 0 9 [] sockaddr in udp_server_client_exchange server_logic client_logic >>= fun () -> let check = "abcdef" = Lwt_bytes.to_string buf in Lwt.return check end; test "bytes sendto" ~only_if:(fun () -> not Sys.win32) begin fun () -> let buf = gen_buf 6 in let server_logic socket = Lwt_bytes.recvfrom socket buf 0 6 [] in let client_logic socket sockaddr = let message = Lwt_bytes.of_string "abcdefghij" in Lwt_bytes.sendto socket message 0 9 [] sockaddr in udp_server_client_exchange server_logic client_logic >>= fun () -> let check = "abcdef" = Lwt_bytes.to_string buf in Lwt.return check end; test "bytes recv_msg" ~only_if:(fun () -> not Sys.win32) begin fun () -> let buffer = gen_buf 6 in let offset = 0 in let io_vectors = [Lwt_bytes.io_vector ~buffer ~offset ~length:6] in let server_logic socket = (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors in let client_logic socket sockaddr = let message = Lwt_bytes.of_string "abcdefghij" in Lwt_bytes.sendto socket message 0 9 [] sockaddr in udp_server_client_exchange server_logic client_logic >>= fun () -> let check = "abcdef" = Lwt_bytes.to_string buffer in Lwt.return check end; test "bytes send_msg" ~only_if:(fun () -> not Sys.win32) begin fun () -> let buffer = gen_buf 6 in let offset = 0 in let server_logic socket = let io_vectors = [Lwt_bytes.io_vector ~buffer ~offset ~length:6] in (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors in let client_logic socket sockaddr = Lwt_unix.connect socket sockaddr >>= fun () -> let message = Lwt_bytes.of_string "abcdefghij" in let io_vectors = [Lwt_bytes.io_vector ~buffer:message ~offset ~length:9] in (Lwt_bytes.send_msg [@ocaml.warning "-3"]) ~socket ~io_vectors ~fds:[] in udp_server_client_exchange server_logic client_logic >>= fun () -> let check = "abcdef" = Lwt_bytes.to_string buffer in Lwt.return check end; test "send_msgto" ~only_if:(fun () -> not Sys.win32) begin fun () -> let buffer = gen_buf 6 in let offset = 0 in let server_logic socket = let io_vectors = [Lwt_bytes.io_vector ~buffer ~offset ~length:6] in (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket ~io_vectors in let client_logic socket sockaddr = let message = Lwt_bytes.of_string "abcdefghij" in let io_vectors = Lwt_unix.IO_vectors.create () in Lwt_unix.IO_vectors.append_bigarray io_vectors message offset 9; Lwt_unix.send_msgto ~socket ~io_vectors ~fds:[] ~dest:sockaddr in udp_server_client_exchange server_logic client_logic >>= fun () -> let check = "abcdef" = Lwt_bytes.to_string buffer in Lwt.return check end; test "map_file" begin fun () -> let test_file = "bytes_io_data" in let fd = Unix.openfile test_file [O_RDONLY] 0 in let shared = false in let size = 6 in let buffer = Lwt_bytes.map_file ~fd ~shared ~size () in let check = "abcdef" = Lwt_bytes.to_string buffer in let () = Unix.close fd in Lwt.return check end; test "page_size" begin fun () -> let sizes = [4096; 16384; 65536] in Lwt.return (List.mem Lwt_bytes.page_size sizes) end; test "mincore buffer length = page_size * 2, n_states = 1" ~only_if:(fun () -> not Sys.win32) begin fun () -> test_mincore (Lwt_bytes.page_size * 2) Lwt_bytes.page_size 1 >>= fun () -> Lwt.return_true end; test "mincore buffer length = page_size * 2, n_states = 2" ~only_if:(fun () -> not Sys.win32) begin fun () -> Lwt.catch (fun () -> test_mincore (Lwt_bytes.page_size * 2) Lwt_bytes.page_size 2 >>= fun () -> Lwt.return_false ) (function | Invalid_argument _message -> Lwt.return_true | exn -> Lwt.reraise exn ) end; test "mincore buffer length = page_size * 2 + 1, n_states = 2" ~only_if:(fun () -> not Sys.win32) begin fun () -> test_mincore (Lwt_bytes.page_size * 2 + 1) Lwt_bytes.page_size 2 >>= fun () -> Lwt.return_true end; test "mincore buffer length = page_size , n_states = 0" ~only_if:(fun () -> not Sys.win32) begin fun () -> test_mincore (Lwt_bytes.page_size * 2 + 1) Lwt_bytes.page_size 0 >>= fun () -> Lwt.return_true end; test "wait_mincore correct bounds" ~only_if:(fun () -> not Sys.win32) begin fun () -> test_wait_mincore (Lwt_bytes.page_size * 2 + 1) Lwt_bytes.page_size >>= fun () -> Lwt.return_true end; test "wait_mincore offset < 0" ~only_if:(fun () -> not Sys.win32) begin fun () -> Lwt.catch (fun () -> test_wait_mincore (Lwt_bytes.page_size * 2 + 1) (-1) >>= fun () -> Lwt.return_false ) (function | Invalid_argument _message -> Lwt.return_true | exn -> Lwt.reraise exn ) end; test "wait_mincore offset > buffer length" ~only_if:(fun () -> not Sys.win32) begin fun () -> Lwt.catch (fun () -> let buff_len = Lwt_bytes.page_size * 2 + 1 in test_wait_mincore buff_len (buff_len + 1) >>= fun () -> Lwt.return_false ) (function | Invalid_argument _message -> Lwt.return_true | exn -> Lwt.reraise exn ) end; ] lwt-5.9.1/test/unix/test_lwt_engine.ml000066400000000000000000000033241476253734400200430ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix let timing_tests = [ test "libev: timer delays are not too short" begin fun () -> let start = Unix.gettimeofday () in Lwt.catch (fun () -> (* Block the entire process for one second. If using libev, libev's notion of the current time is not updated during this period. *) let () = Unix.sleep 1 in (* At this point, libev thinks that the time is what it was about one second ago. Now schedule exception Lwt_unix.Timeout to be raised in 0.5 seconds. If the implementation is incorrect, the exception will be raised immediately, because the 0.5 seconds will be measured relative to libev's "current" time of one second ago. *) Lwt_unix.timeout 0.5) (function | Lwt_unix.Timeout -> Lwt.return (Unix.gettimeofday ()) | exn -> Lwt.reraise exn) >>= fun stop -> Lwt.return (stop -. start >= 1.5) end; ] let tests = timing_tests let run_tests = [ test "Lwt_main.run: nested call" ~sequential:true begin fun () -> (* The test itself is already running under Lwt_main.run, so we just have to call it once and make sure we get an exception. *) (* Make sure we are running in a callback called by Lwt_main.run, not synchronously when the testing executable is loaded. *) Lwt.pause () >>= fun () -> try Lwt_main.run (Lwt.return_unit); Lwt.return_false with Failure _ -> Lwt.return_true end; ] let tests = tests @ run_tests let suite = suite "lwt_engine" tests lwt-5.9.1/test/unix/test_lwt_fmt.ml000066400000000000000000000040201476253734400173560ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix let testchan () = let b = Buffer.create 6 in let f buf ofs len = let bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; Buffer.add_bytes b bytes; Lwt.return len in let oc = Lwt_io.make ~mode:Output f in let fmt = Lwt_fmt.of_channel oc in fmt, (fun () -> Buffer.contents b) let suite = suite "lwt_fmt" [ test "flushing" (fun () -> let fmt, f = testchan () in Lwt_fmt.fprintf fmt "%s%i%s%!" "bla" 3 "blo" >>= fun () -> Lwt.return (f () = {|bla3blo|}) ); test "with combinator" (fun () -> let fmt, f = testchan () in Lwt_fmt.fprintf fmt "%a%!" Format.pp_print_int 3 >>= fun () -> Lwt.return (f () = {|3|}) ); test "box" (fun () -> let fmt, f = testchan () in Lwt_fmt.fprintf fmt "@[%i@,%i@]%!" 1 2 >>= fun () -> Lwt.return (f () = "1\n 2") ); test "boxsplit" (fun () -> let fmt, f = testchan () in Lwt_fmt.fprintf fmt "@[%i" 1 >>= fun () -> Lwt_fmt.fprintf fmt "@,%i@]" 2 >>= fun () -> Lwt_fmt.flush fmt >>= fun () -> Lwt.return (f () = "1\n 2") ); test "box close with flush" (fun () -> let fmt, f = testchan () in Lwt_fmt.fprintf fmt "@[%i" 1 >>= fun () -> Lwt_fmt.fprintf fmt "@,%i" 2 >>= fun () -> Lwt_fmt.flush fmt >>= fun () -> Lwt.return (f () = "1\n 2") ); test "stream" (fun () -> let stream, fmt = Lwt_fmt.make_stream () in Lwt_fmt.fprintf fmt "@[%i@,%i@]%!" 1 2 >>= fun () -> Lwt.return (Lwt_stream.get_available stream = [ String ("1", 0, 1); String ("\n", 0, 1); String (" ", 0, 2); String ("2", 0, 1); Flush]) ); ] lwt-5.9.1/test/unix/test_lwt_io.ml000066400000000000000000000536741476253734400172220ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) (* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it. However, it is still used internally by Lwt. So, briefly disable warning 3 ("deprecated"), and create a local, non-deprecated alias for [Lwt_sequence] that can be referred to by the rest of the code in this module without triggering any more warnings. *) [@@@ocaml.warning "-3"] module Lwt_sequence = Lwt_sequence [@@@ocaml.warning "+3"] open Test open Lwt.Infix exception Dummy_error let local = let last_port = ref 4321 in fun () -> incr last_port; Unix.ADDR_INET (Unix.inet_addr_loopback, !last_port) (* Helpers for [establish_server] tests. *) module Establish_server = struct let with_client f = let local = local () in let handler_finished, notify_handler_finished = Lwt.wait () in Lwt_io.establish_server_with_client_address local (fun _client_address channels -> Lwt.finalize (fun () -> f channels) (fun () -> Lwt.wakeup notify_handler_finished (); Lwt.return_unit)) >>= fun server -> let client_finished = Lwt_io.with_connection local (fun (_, out_channel) -> Lwt_io.write out_channel "hello world" >>= fun () -> handler_finished) in client_finished >>= fun () -> Lwt_io.shutdown_server server (* Hacky is_closed functions that attempt to read from/write to the channels to see if they are closed. *) let is_closed_in channel = Lwt.catch (fun () -> Lwt_io.read_char channel >|= fun _ -> false) (function | Lwt_io.Channel_closed _ -> Lwt.return_true | _ -> Lwt.return_false) let is_closed_out channel = Lwt.catch (fun () -> Lwt_io.write_char channel 'a' >|= fun () -> false) (function | Lwt_io.Channel_closed _ -> Lwt.return_true | _ -> Lwt.return_false) end let suite = suite "lwt_io" [ test "auto-flush" ~sequential:true (fun () -> let sent = ref [] in let oc = Lwt_io.make ~mode:Lwt_io.output (fun buf ofs len -> let bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; sent := bytes :: !sent; Lwt.return len) in Lwt_io.write oc "foo" >>= fun () -> Lwt_io.write oc "bar" >>= fun () -> if !sent <> [] then begin prerr_endline "auto-flush: !sent not empty"; Lwt.return_false end else Lwt_unix.sleep 0.1 >>= fun () -> let test_result = !sent = [Bytes.of_string "foobar"] in if not test_result then !sent |> List.map Bytes.to_string |> List.map (Printf.sprintf "'%s'") |> String.concat "," |> Printf.eprintf "auto-flush: !sent = %s"; Lwt.return test_result); test "auto-flush in atomic" ~sequential:true (fun () -> let sent = ref [] in let oc = Lwt_io.make ~mode:Lwt_io.output (fun buf ofs len -> let bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; sent := bytes :: !sent; Lwt.return len) in Lwt_io.atomic (fun oc -> Lwt_io.write oc "foo" >>= fun () -> Lwt_io.write oc "bar" >>= fun () -> if !sent <> [] then begin prerr_endline "auto-flush atomic: !sent not empty"; Lwt.return_false end else Lwt_unix.sleep 0.1 >>= fun () -> let test_result = !sent = [Bytes.of_string "foobar"] in if not test_result then !sent |> List.map Bytes.to_string |> List.map (Printf.sprintf "'%s'") |> String.concat "," |> Printf.eprintf "auto-flush atomic: !sent = %s"; Lwt.return test_result) oc); (* Without the corresponding bugfix, which is to handle ENOTCONN from Lwt_unix.shutdown, this test raises an exception from the handler's calls to close. *) test "establish_server_1: shutdown: client closes first" ~only_if:(fun () -> not (Lwt_config._HAVE_LIBEV && Lwt_config.libev_default)) (* Note: this test is currently flaky on Linux with libev enabled, so we skip it in that case. *) (fun () -> let wait_for_client, client_finished = Lwt.wait () in let handler_wait, run_handler = Lwt.wait () in let handler = handler_wait >>= fun (in_channel, out_channel) -> wait_for_client >>= fun () -> Lwt_io.close in_channel >>= fun () -> Lwt_io.close out_channel >>= fun () -> Lwt.return_true in let local = local () in let server = (Lwt_io.Versioned.establish_server_1 [@ocaml.warning "-3"]) local (fun channels -> Lwt.wakeup run_handler channels) in Lwt_io.with_connection local (fun _ -> Lwt.return_unit) >>= fun () -> Lwt.wakeup client_finished (); Lwt_io.shutdown_server server >>= fun () -> handler); (* Counterpart to establish_server: shutdown test. Confirms that shutdown is implemented correctly in open_connection. *) test "open_connection: shutdown: server closes first" (fun () -> let wait_for_server, server_finished = Lwt.wait () in let local = local () in let server = (Lwt_io.Versioned.establish_server_1 [@ocaml.warning "-3"]) local (fun (in_channel, out_channel) -> Lwt.async (fun () -> Lwt_io.close in_channel >>= fun () -> Lwt_io.close out_channel >|= fun () -> Lwt.wakeup server_finished ())) in Lwt_io.with_connection local (fun _ -> wait_for_server >>= fun () -> Lwt.return_true) >>= fun result -> Lwt_io.shutdown_server server >|= fun () -> result); test "establish_server: implicit close" (fun () -> let open Establish_server in let in_channel' = ref Lwt_io.stdin in let out_channel' = ref Lwt_io.stdout in let in_open_in_handler = ref false in let out_open_in_handler = ref false in let run = Establish_server.with_client (fun (in_channel, out_channel) -> in_channel' := in_channel; out_channel' := out_channel; is_closed_out out_channel >>= fun yes -> out_open_in_handler := not yes; is_closed_in in_channel >|= fun yes -> in_open_in_handler := not yes) in run >>= fun () -> (* Give a little time for the close system calls on the connection sockets to complete. The Lwt_io and Lwt_unix APIs do not currently allow binding on the implicit closes of these sockets, so resorting to a delay. *) Lwt_unix.sleep 0.05 >>= fun () -> is_closed_in !in_channel' >>= fun in_closed_after_handler -> is_closed_out !out_channel' >|= fun out_closed_after_handler -> !out_open_in_handler && !in_open_in_handler && in_closed_after_handler && out_closed_after_handler); test ~sequential:true "establish_server: implicit close on exception" (fun () -> let open Establish_server in let in_channel' = ref Lwt_io.stdin in let out_channel' = ref Lwt_io.stdout in let exit_raised = ref false in let run () = Establish_server.with_client (fun (in_channel, out_channel) -> in_channel' := in_channel; out_channel' := out_channel; raise Exit) in with_async_exception_hook (function | Exit -> exit_raised := true; | _ -> ()) run >>= fun () -> (* See comment in other implicit close test. *) Lwt_unix.sleep 0.05 >>= fun () -> is_closed_in !in_channel' >>= fun in_closed_after_handler -> is_closed_out !out_channel' >|= fun out_closed_after_handler -> in_closed_after_handler && out_closed_after_handler); (* This does a simple double close of the channels (second close is implicit). If something breaks, the test will finish with an exception, or Lwt.async_exception_hook will kill the process. *) test "establish_server: explicit close" (fun () -> let open Establish_server in let closed_explicitly = ref false in let run = Establish_server.with_client (fun (in_channel, out_channel) -> Lwt_io.close in_channel >>= fun () -> Lwt_io.close out_channel >>= fun () -> is_closed_in in_channel >>= fun in_closed_in_handler -> is_closed_out out_channel >|= fun out_closed_in_handler -> closed_explicitly := in_closed_in_handler && out_closed_in_handler) in run >|= fun () -> !closed_explicitly); test "with_connection" (fun () -> let open Establish_server in let in_channel' = ref Lwt_io.stdin in let out_channel' = ref Lwt_io.stdout in let local = local () in Lwt_io.establish_server_with_client_address local (fun _client_address _channels -> Lwt.return_unit) >>= fun server -> Lwt_io.with_connection local (fun (in_channel, out_channel) -> in_channel' := in_channel; out_channel' := out_channel; Lwt.return_unit) >>= fun () -> Lwt_io.shutdown_server server >>= fun () -> is_closed_in !in_channel' >>= fun in_closed -> is_closed_out !out_channel' >|= fun out_closed -> in_closed && out_closed); (* Makes the channel fail with EBADF on close. Tries to close the channel manually, and handles the exception. When with_close_connection tries to close the socket again implicitly, that should not raise the exception again. *) test "with_close_connection: no duplicate exceptions" (fun () -> let exceptions_observed = ref 0 in let expecting_ebadf f = Lwt.catch f (function | Unix.Unix_error (Unix.EBADF, _, _) -> exceptions_observed := !exceptions_observed + 1; Lwt.return_unit | exn -> Lwt.reraise exn) [@ocaml.warning "-4"] in let fd_r, fd_w = Lwt_unix.pipe () in let in_channel = Lwt_io.of_fd ~mode:Lwt_io.input fd_r in let out_channel = Lwt_io.of_fd ~mode:Lwt_io.output fd_w in Lwt_unix.close fd_r >>= fun () -> Lwt_unix.close fd_w >>= fun () -> expecting_ebadf (fun () -> Lwt_io.with_close_connection (fun _ -> expecting_ebadf (fun () -> Lwt_io.close in_channel) >>= fun () -> expecting_ebadf (fun () -> Lwt_io.close out_channel)) (in_channel, out_channel)) >|= fun () -> !exceptions_observed = 2); test "open_temp_file" (fun () -> Lwt_io.open_temp_file () >>= fun (fname, out_chan) -> Lwt_io.write out_chan "test file content" >>= fun () -> Lwt_io.close out_chan >>= fun _ -> Unix.unlink fname; Lwt.return_true ); test "with_temp_filename" (fun () -> let prefix = "test_tempfile" in let filename = ref "." in let wrap f (filename', chan) = filename := filename'; f chan in let write_data chan = Lwt_io.write chan "test file content" in let write_data_fail _ = Lwt.fail Dummy_error in Lwt_io.with_temp_file (wrap write_data) ~prefix >>= fun _ -> let no_temps1 = not (Sys.file_exists !filename) in Lwt.catch (fun () -> Lwt_io.with_temp_file (wrap write_data_fail)) (fun exn -> if exn = Dummy_error then Lwt.return (not (Sys.file_exists !filename)) else Lwt.return_false ) >>= fun no_temps2 -> Lwt.return (no_temps1 && no_temps2) ); (* Verify that no exceptions are thrown if the function passed to with_temp_file closes the channel on its own. *) test "with_temp_filename close handle" (fun () -> let f (_, chan) = Lwt_io.write chan "test file content" >>= fun _ -> Lwt_io.close chan in Lwt_io.with_temp_file f >>= fun _ -> Lwt.return_true; ); test "create_temp_dir" begin fun () -> let prefix = "temp_dir" in let suffix = "_foo" in Lwt_io.create_temp_dir ~parent:Filename.current_dir_name ~prefix ~suffix () >>= fun path -> let name = Filename.basename path in let prefix_matches = String.sub name 0 (String.length prefix) = prefix in let actual_suffix = String.sub name (String.length name - String.length suffix) (String.length suffix) in let suffix_matches = actual_suffix = suffix in let directory_exists = Sys.is_directory path in Lwt_unix.rmdir path >>= fun () -> Lwt.return (prefix_matches && suffix_matches && directory_exists) end; test "with_temp_dir" ~sequential:true begin fun () -> Lwt_io.with_temp_dir ~parent:Filename.current_dir_name ~prefix:"temp_dir" begin fun path -> let directory_existed = Sys.is_directory path in open_out (Filename.concat path "foo") |> close_out; open_out (Filename.concat path "bar") |> close_out; let had_files = Array.length (Sys.readdir path) = 2 in Lwt.return (path, directory_existed, had_files) end >>= fun (path, directory_existed, had_files) -> let directory_removed = not (Sys.file_exists path) in Lwt.return (directory_existed && had_files && directory_removed) end; test "file_length on directory" begin fun () -> Lwt.catch (fun () -> Lwt_io.file_length "." >>= fun _ -> Lwt.return_false) (function | Unix.Unix_error (Unix.EISDIR, "file_length", ".") -> Lwt.return_true | exn -> Lwt.reraise exn) end; test "input channel of_bytes initial position" (fun () -> let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in Lwt.return (Lwt_io.position ichan = 0L) ); test "input channel of_bytes position after read" (fun () -> let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in Lwt_io.read_char ichan >|= fun _ -> Lwt_io.position ichan = 1L ); test "input channel of_bytes position after set_position" (fun () -> let ichan = Lwt_io.of_bytes ~mode:Lwt_io.input @@ Lwt_bytes.of_string "abcd" in Lwt_io.set_position ichan 2L >|= fun () -> Lwt_io.position ichan = 2L ); test "output channel of_bytes initial position" (fun () -> let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in Lwt.return (Lwt_io.position ochan = 0L) ); test "output channel of_bytes position after read" (fun () -> let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in Lwt_io.write_char ochan 'a' >|= fun _ -> Lwt_io.position ochan = 1L ); test "output channel of_bytes position after set_position" (fun () -> let ochan = Lwt_io.of_bytes ~mode:Lwt_io.output @@ Lwt_bytes.create 4 in Lwt_io.set_position ochan 2L >|= fun _ -> Lwt_io.position ochan = 2L ); test "NumberIO.LE.read_int" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int >|= (=) 0x04030201 end; test "NumberIO.BE.read_int" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int >|= (=) 0x01020304 end; test "NumberIO.LE.read_int16" begin fun () -> Lwt_bytes.of_string "\x01\x02" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int16 >|= (=) 0x0201 end; test "NumberIO.BE.read_int16" begin fun () -> Lwt_bytes.of_string "\x01\x02" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int16 >|= (=) 0x0102 end; test "NumberIO.LE.read_int16, negative" begin fun () -> Lwt_bytes.of_string "\xfe\xff" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int16 >|= (=) (-2) end; test "NumberIO.BE.read_int16, negative" begin fun () -> Lwt_bytes.of_string "\xff\xfe" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int16 >|= (=) (-2) end; test "NumberIO.LE.read_int32" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int32 >|= (=) 0x04030201l end; test "NumberIO.BE.read_int32" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int32 >|= (=) 0x01020304l end; test "NumberIO.LE.read_int64" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_int64 >|= (=) 0x0807060504030201L end; test "NumberIO.BE.read_int64" begin fun () -> Lwt_bytes.of_string "\x01\x02\x03\x04\x05\x06\x07\x08" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_int64 >|= (=) 0x0102030405060708L end; test "NumberIO.LE.read_float32" begin fun () -> Lwt_bytes.of_string "\x80\x01\x81\x47" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_float32 >|= fun n -> instrument (n = 66051.) "NumberIO.LE.read_float32: %f" n end; test "NumberIO.BE.read_float32" begin fun () -> Lwt_bytes.of_string "\x47\x81\x01\x80" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_float32 >|= fun n -> instrument (n = 66051.) "NumberIO.BE.read_float32: %f" n end; test "NumberIO.LE.read_float64" begin fun () -> Lwt_bytes.of_string "\x70\x60\x50\x40\x30\x20\xf0\x42" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.LE.read_float64 >|= Int64.bits_of_float >|= (=) 0x42F0203040506070L end; test "NumberIO.BE.read_float64" begin fun () -> Lwt_bytes.of_string "\x42\xf0\x20\x30\x40\x50\x60\x70" |> Lwt_io.(of_bytes ~mode:input) |> Lwt_io.BE.read_float64 >|= Int64.bits_of_float >|= (=) 0x42F0203040506070L end; test "NumberIO.LE.write_int" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.LE.write_int (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304 >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x04\x03\x02\x01") end; test "NumberIO.BE.write_int" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.BE.write_int (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304 >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04") end; test "NumberIO.LE.write_int16" begin fun () -> let buffer = Lwt_bytes.create 2 in Lwt_io.LE.write_int16 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102 >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x02\x01") end; test "NumberIO.BE.write_int16" begin fun () -> let buffer = Lwt_bytes.create 2 in Lwt_io.BE.write_int16 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102 >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02") end; test "NumberIO.LE.write_int32" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.LE.write_int32 (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304l >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x04\x03\x02\x01") end; test "NumberIO.BE.write_int32" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.BE.write_int32 (Lwt_io.(of_bytes ~mode:output) buffer) 0x01020304l >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04") end; test "NumberIO.LE.write_int64" begin fun () -> let buffer = Lwt_bytes.create 8 in Lwt_io.LE.write_int64 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102030405060708L >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x08\x07\x06\x05\x04\x03\x02\x01") end; test "NumberIO.BE.write_int64" begin fun () -> let buffer = Lwt_bytes.create 8 in Lwt_io.BE.write_int64 (Lwt_io.(of_bytes ~mode:output) buffer) 0x0102030405060708L >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x01\x02\x03\x04\x05\x06\x07\x08") end; test "NumberIO.LE.write_float32" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.LE.write_float32 (Lwt_io.(of_bytes ~mode:output) buffer) 66051. >|= fun () -> instrument (Lwt_bytes.to_string buffer = "\x80\x01\x81\x47") "NumberIO.LE.write_float32: %02X %02X %02X %02X" (Char.code (Lwt_bytes.get buffer 0)) (Char.code (Lwt_bytes.get buffer 1)) (Char.code (Lwt_bytes.get buffer 2)) (Char.code (Lwt_bytes.get buffer 3)) end; test "NumberIO.BE.write_float32" begin fun () -> let buffer = Lwt_bytes.create 4 in Lwt_io.BE.write_float32 (Lwt_io.(of_bytes ~mode:output) buffer) 66051. >|= fun () -> instrument (Lwt_bytes.to_string buffer = "\x47\x81\x01\x80") "NumberIO.BE.write_float32: %02X %02X %02X %02X" (Char.code (Lwt_bytes.get buffer 0)) (Char.code (Lwt_bytes.get buffer 1)) (Char.code (Lwt_bytes.get buffer 2)) (Char.code (Lwt_bytes.get buffer 3)) end; test "NumberIO.LE.write_float64" begin fun () -> let buffer = Lwt_bytes.create 8 in Lwt_io.LE.write_float64 (Lwt_io.(of_bytes ~mode:output) buffer) (Int64.float_of_bits 0x42F0203040506070L) >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x70\x60\x50\x40\x30\x20\xf0\x42") end; test "NumberIO.BE.write_float64" begin fun () -> let buffer = Lwt_bytes.create 8 in Lwt_io.BE.write_float64 (Lwt_io.(of_bytes ~mode:output) buffer) (Int64.float_of_bits 0x42F0203040506070L) >>= fun () -> Lwt.return (Lwt_bytes.to_string buffer = "\x42\xf0\x20\x30\x40\x50\x60\x70") end; test "Write from Lwt_bytes" begin fun () -> let bytes = Lwt_bytes.of_string "Hello World" in let out = Lwt_bytes.create 11 in Lwt_io.write_from_exactly_bigstring (Lwt_io.(of_bytes ~mode:output) out) bytes 0 11 >>= fun () -> Lwt.return (Lwt_bytes.to_string out = "Hello World") end; test "Read from Lwt_bytes" begin fun () -> let bytes_in = Lwt_bytes.create 11 in let bytes = Lwt_bytes.of_string "Hello World" in Lwt_io.read_into_exactly_bigstring (Lwt_io.(of_bytes ~mode:input) bytes) bytes_in 0 11 >>= fun () -> Lwt.return (Lwt_bytes.to_string bytes_in = "Hello World") end; ] lwt-5.9.1/test/unix/test_lwt_io_non_block.ml000066400000000000000000000031641476253734400212330ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix let test_file = "Lwt_io_test" let file_contents = "test file content" let suite = suite "lwt_io non blocking io" [ test ~sequential:true "file does not exist" (fun () -> Lwt_unix.file_exists test_file >|= fun r -> not r); test ~sequential:true "file does not exist (invalid path)" (fun () -> Lwt_unix.file_exists (test_file ^ "/foo") >|= fun r -> not r); test ~sequential:true "file does not exist (LargeFile)" (fun () -> Lwt_unix.LargeFile.file_exists test_file >|= fun r -> not r); test ~sequential:true "file does not exist (LargeFile, invalid path)" (fun () -> Lwt_unix.LargeFile.file_exists (test_file ^ "/foo") >|= fun r -> not r); test ~sequential:true "create file" (fun () -> Lwt_io.open_file ~mode:Lwt_io.output test_file >>= fun out_chan -> Lwt_io.write out_chan file_contents >>= fun () -> Lwt_io.close out_chan >>= fun () -> Lwt.return_true); test ~sequential:true "file exists" (fun () -> Lwt_unix.file_exists test_file); test ~sequential:true "file exists (LargeFile)" (fun () -> Lwt_unix.LargeFile.file_exists test_file); test ~sequential:true "read file" (fun () -> Lwt_io.open_file ~mode:Lwt_io.input test_file >>= fun in_chan -> Lwt_io.read in_chan >>= fun s -> Lwt_io.close in_chan >>= fun () -> Lwt.return (s = file_contents)); test ~sequential:true "remove file" (fun () -> Unix.unlink test_file; Lwt.return_true); ] lwt-5.9.1/test/unix/test_lwt_process.ml000066400000000000000000000066241476253734400202620ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix let expected_str = "the quick brown fox jumps over the lazy dog" let expected = Bytes.of_string expected_str let expected_len = Bytes.length expected let check_status ?(status=(=) 0) = function | Unix.WEXITED n when status n -> Lwt.return_true | Unix.WEXITED n -> Printf.eprintf "exited with code %d" n; Lwt.return_false | Unix.WSIGNALED x -> Printf.eprintf "failed with signal %d" x; Lwt.return_false | Unix.WSTOPPED x -> Printf.eprintf "stopped with signal %d" x; Lwt.return_false let pwrite ~stdin pout = let args = [|"dummy.exe"; "read"|] in let proc = Lwt_process.exec ~stdin ("./dummy.exe", args) in let write = Lwt.finalize (fun () -> Lwt_unix.write pout expected 0 expected_len) (fun () -> Lwt_unix.close pout) in proc >>= fun r -> write >>= fun n -> assert (n = expected_len); check_status r let pread ?stdout ?stderr pin = let buf = Bytes.create expected_len in let proc = match stdout, stderr with | Some stdout, None -> let args = [|"dummy.exe"; "write"|] in Lwt_process.exec ~stdout ("./dummy.exe", args) | None, Some stderr -> let args = [|"dummy.exe"; "errwrite"|] in Lwt_process.exec ~stderr ("./dummy.exe", args) | _ -> assert false in let read = Lwt_unix.read pin buf 0 expected_len in proc >>= fun r -> read >>= fun n -> assert (n = expected_len); assert (Bytes.equal buf expected); Lwt_unix.read pin buf 0 1 >>= fun n -> assert (n = 0); check_status r let suite = suite "lwt_process" [ (* The sleep command is not available on Win32. *) test "lazy_undefined" ~only_if:(fun () -> not Sys.win32) (fun () -> Lwt_process.with_process_in ~timeout:1. ("sleep", [| "sleep"; "2" |]) (fun p -> Lwt.catch (fun () -> Lwt_io.read p#stdout) (fun _ -> Lwt.return "")) >>= fun _ -> Lwt.return_true); test "subproc stdout can be redirected to null" (fun () -> let args = [|"dummy.exe"; "write"|] in Lwt_process.exec ~stdout:`Dev_null ("./dummy.exe", args) >>= check_status); test "subproc stderr can be redirected to null" (fun () -> let args = [|"dummy.exe"; "errwrite"|] in Lwt_process.exec ~stderr:`Dev_null ("./dummy.exe", args) >>= check_status); test "subproc cannot write on closed stdout" (fun () -> let args = [|"dummy.exe"; "write"|] in let stderr = `Dev_null (* mask subproc stderr *) in Lwt_process.exec ~stdout:`Close ~stderr ("./dummy.exe", args) >>= check_status ~status:((<>) 0)); test "subproc cannot write on closed stderr" (fun () -> let args = [|"dummy.exe"; "errwrite"|] in Lwt_process.exec ~stderr:`Close ("./dummy.exe", args) >>= check_status ~status:((<>) 0)); test "can write to subproc stdin" (fun () -> let pin, pout = Lwt_unix.pipe_out ~cloexec:true () in pwrite ~stdin:(`FD_move pin) pout); test "can read from subproc stdout" (fun () -> let pin, pout = Lwt_unix.pipe_in ~cloexec:true () in pread ~stdout:(`FD_move pout) pin); test "can read from subproc stderr" (fun () -> let pin, perr = Lwt_unix.pipe_in ~cloexec:true () in pread ~stderr:(`FD_move perr) pin); ] lwt-5.9.1/test/unix/test_lwt_timeout.ml000066400000000000000000000153731476253734400202730ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix (* Note: due to the time delays in the tests of this suite, it could really benefit from an option to run tests in parallel. *) let suite = suite "Lwt_timeout" [ test "basic" begin fun () -> let p, r = Lwt.wait () in let start_time = Unix.gettimeofday () in let timeout = Lwt_timeout.create 1 (fun () -> let delta = Unix.gettimeofday () -. start_time in Lwt.wakeup_later r delta) in Lwt_timeout.start timeout; p >|= fun delta -> instrument (delta >= 2. && delta < 3.) "Lwt_timeout: basic: %f %f" start_time delta (* The above is a bug of the current implementation: it always gives too long a timeout. *) end; test "not started" begin fun () -> let p, r = Lwt.wait () in Lwt_timeout.create 1 (fun () -> Lwt.wakeup_later r false) |> ignore; Lwt.async (fun () -> Lwt_unix.sleep 3. >|= fun () -> Lwt.wakeup_later r true); p end; test "double start" begin fun () -> let completions = ref 0 in let timeout = Lwt_timeout.create 1 (fun () -> completions := !completions + 1) in Lwt_timeout.start timeout; Lwt_timeout.start timeout; Lwt_unix.sleep 3. >|= fun () -> instrument (!completions = 1) "Lwt_timeout: double start: %i" !completions end; test "restart" begin fun () -> let p, r = Lwt.wait () in let completions = ref 0 in (* A dummy timeout, just to set up the reference. *) let timeout = ref (Lwt_timeout.create 1 ignore) in timeout := Lwt_timeout.create 1 (fun () -> completions := !completions + 1; if !completions < 2 then Lwt_timeout.start !timeout else Lwt.wakeup_later r true); Lwt_timeout.start !timeout; p end; test "stop" begin fun () -> let p, r = Lwt.wait () in let timeout = Lwt_timeout.create 1 (fun () -> Lwt.wakeup_later r false) in Lwt_timeout.start timeout; Lwt_timeout.stop timeout; Lwt.async (fun () -> Lwt_unix.sleep 3. >|= fun () -> Lwt.wakeup_later r true); p end; test "stop when not stopped" begin fun () -> Lwt_timeout.create 1 ignore |> Lwt_timeout.stop; Lwt.return_true end; test "invalid delay" begin fun () -> try ignore (Lwt_timeout.create 0 ignore); Lwt.return_false with Invalid_argument _ -> Lwt.return_true end; test "change" begin fun () -> let p, r = Lwt.wait () in let start_time = Unix.gettimeofday () in let timeout = Lwt_timeout.create 5 (fun () -> let delta = Unix.gettimeofday () -. start_time in Lwt.wakeup_later r delta) in Lwt_timeout.change timeout 1; Lwt_timeout.start timeout; p >|= fun delta -> instrument (delta >= 1.9 && delta < 3.1) "Lwt_timeout: change: %f %f" start_time delta end; test "change does not start" begin fun () -> let p, r = Lwt.wait () in let timeout = Lwt_timeout.create 1 (fun () -> Lwt.wakeup_later r false) in Lwt_timeout.change timeout 1; Lwt.async (fun () -> Lwt_unix.sleep 3. >|= fun () -> Lwt.wakeup_later r true); p end; test "change after start" begin fun () -> let p, r = Lwt.wait () in let start_time = Unix.gettimeofday () in let timeout = Lwt_timeout.create 5 (fun () -> let delta = Unix.gettimeofday () -. start_time in Lwt.wakeup_later r delta) in Lwt_timeout.start timeout; Lwt_timeout.change timeout 1; p >|= fun delta -> instrument (delta >= 1.9 && delta < 3.1) "Lwt_timeout: change after start: %f %f" start_time delta end; test "change: invalid delay" begin fun () -> let timeout = (Lwt_timeout.create 1 ignore) in try Lwt_timeout.change timeout 0; Lwt.return_false with Invalid_argument _ -> Lwt.return_true end; test ~sequential:true "exception in action" begin fun () -> let p, r = Lwt.wait () in Test.with_async_exception_hook (fun exn -> match exn with | Exit -> Lwt.wakeup_later r true | _ -> raise exn) (fun () -> Lwt_timeout.create 1 (fun () -> raise Exit) |> Lwt_timeout.start; p) end; test "set_exn_handler" begin fun () -> let p, r = Lwt.wait () in Lwt_timeout.set_exn_handler (fun exn -> match exn with | Exit -> Lwt.wakeup_later r true | _ -> raise exn); Lwt_timeout.create 1 (fun () -> raise Exit) |> Lwt_timeout.start; p >|= fun result -> Lwt_timeout.set_exn_handler (fun exn -> !Lwt.async_exception_hook exn); result end; test "two" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let start_time = Unix.gettimeofday () in Lwt_timeout.create 1 (fun () -> let delta = Unix.gettimeofday () -. start_time in Lwt.wakeup r1 delta) |> Lwt_timeout.start; Lwt_timeout.create 2 (fun () -> let delta = Unix.gettimeofday () -. start_time in Lwt.wakeup r2 delta) |> Lwt_timeout.start; p1 >>= fun delta1 -> p2 >|= fun delta2 -> instrument (delta1 >= 1.9 && delta1 < 3. && delta2 >= 2.9 && delta2 < 4.) "Lwt_timeout: two: %f %f %f" start_time delta1 delta2 end; test "simultaneous" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let start_time = Unix.gettimeofday () in Lwt_timeout.create 1 (fun () -> let delta = Unix.gettimeofday () -. start_time in Lwt.wakeup r1 delta) |> Lwt_timeout.start; Lwt_timeout.create 1 (fun () -> let delta = Unix.gettimeofday () -. start_time in Lwt.wakeup r2 delta) |> Lwt_timeout.start; p1 >>= fun delta1 -> p2 >|= fun delta2 -> instrument (delta1 >= 1. && delta1 < 2.6 && delta2 >= 1. && delta2 < 2.6) "Lwt_timeout: simultaneous: %f %f %f" start_time delta1 delta2 end; test "two, first stopped" begin fun () -> let p1, r1 = Lwt.wait () in let p2, r2 = Lwt.wait () in let start_time = Unix.gettimeofday () in let timeout1 = Lwt_timeout.create 1 (fun () -> Lwt.wakeup r1 false) in Lwt_timeout.start timeout1; Lwt_timeout.create 2 (fun () -> let delta = Unix.gettimeofday () -. start_time in Lwt.wakeup r2 delta) |> Lwt_timeout.start; Lwt_timeout.stop timeout1; Lwt.async (fun () -> Lwt_unix.sleep 3. >|= fun () -> Lwt.wakeup r1 true); p1 >>= fun timeout1_not_fired -> p2 >|= fun delta2 -> instrument (timeout1_not_fired && delta2 >= 1.5 && delta2 < 3.5) "Lwt_timeout: two, first stopped: %b %f %f" timeout1_not_fired start_time delta2 end; ] lwt-5.9.1/test/unix/test_lwt_unix.ml000066400000000000000000001220421476253734400175600ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix (* An instance of the tester for the wait/waitpid tests. *) let () = match Sys.argv with | [|_; "--child"|] -> exit 42 | _ -> () let wait_tests = [ test "wait" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.wait () >|= function | exited_pid, Lwt_unix.WEXITED 42 when exited_pid = child_pid -> true | _ -> false end; test "waitpid" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.waitpid [] child_pid >|= function | exited_pid, Lwt_unix.WEXITED 42 when exited_pid = child_pid -> true | _ -> false end; test "waitpid: any child" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.waitpid [] 0 >|= function | exited_pid, Lwt_unix.WEXITED 42 when exited_pid = child_pid -> true | _ -> false end; test "wait4" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.wait4 [] child_pid >|= function | exited_pid, Lwt_unix.WEXITED 42, _ when exited_pid = child_pid -> true | _ -> false end; test "wait4: any child" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> match Lwt_unix.fork () with | 0 -> Unix.execv Sys.argv.(0) [|""; "--child"|] | child_pid -> Lwt_unix.wait4 [] 0 >|= function | exited_pid, Lwt_unix.WEXITED 42, _ when exited_pid = child_pid -> true | _ -> false end; ] (* The CLOEXEC tests use execv(2) to execute this code, by passing --cloexec to the copy of the tester in the child process. This is a module side effect that interprets that --cloexec argument. *) let () = let is_fd_open fd = let fd = (Obj.magic (int_of_string fd) : Unix.file_descr) in let buf = Bytes.create 1 in try ignore (Unix.read fd buf 0 1); true with Unix.Unix_error (Unix.EBADF, _, _) -> false in match Sys.argv with | [|_; "--cloexec"; fd; "--open"|] -> if is_fd_open fd then exit 0 else exit 1 | [|_; "--cloexec"; fd; "--closed"|] -> if is_fd_open fd then exit 1 else exit 0 | _ -> () let test_cloexec ~closed flags = Lwt_unix.openfile "/dev/zero" (Unix.O_RDONLY :: flags) 0o644 >>= fun fd -> match Lwt_unix.fork () with | 0 -> let fd = string_of_int (Obj.magic (Lwt_unix.unix_file_descr fd)) in let expected_status = if closed then "--closed" else "--open" in (* There's no portable way to obtain the tester executable name (which may even no longer exist at this point), but argv[0] fortunately has the right value when the tests are run in the Lwt dev environment. *) Unix.execv Sys.argv.(0) [|""; "--cloexec"; fd; expected_status|] | n -> Lwt_unix.close fd >>= fun () -> Lwt_unix.waitpid [] n >>= function | _, Unix.WEXITED 0 -> Lwt.return_true | _, (Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _) -> Lwt.return_false let openfile_tests = [ test "openfile: O_CLOEXEC" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:true [Unix.O_CLOEXEC]); test "openfile: O_CLOEXEC not given" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:false []); test "openfile: O_KEEPEXEC" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:false [Unix.O_KEEPEXEC]); test "openfile: O_CLOEXEC, O_KEEPEXEC" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:true [Unix.O_CLOEXEC; Unix.O_KEEPEXEC]); test "openfile: O_KEEPEXEC, O_CLOEXEC" ~only_if:(fun () -> not Sys.win32) (fun () -> test_cloexec ~closed:true [Unix.O_KEEPEXEC; Unix.O_CLOEXEC]); ] let utimes_tests = [ test "utimes: basic" (fun () -> let temporary_file = Test_unix.temp_file () in Lwt_unix.utimes temporary_file 1. 2. >>= fun () -> let stat = Unix.stat temporary_file in let c1 = stat.Unix.st_atime = 1. in let c2 = stat.Unix.st_mtime = 2. in Lwt.return (instrument (c1 && c2) "utimes: basic: %f %f" stat.Unix.st_atime stat.Unix.st_mtime)); test "utimes: current time" (fun () -> (* Unix.stat reports times about an hour away from those set by Unix.utimes on Windows on MinGW. Have not searched for the root cause yet. *) let acceptable_delta = if Sys.win32 then 7200. else 2. in let now = Unix.gettimeofday () in let temporary_file = Test_unix.temp_file () in Lwt_unix.utimes temporary_file 1. 2. >>= fun () -> Lwt_unix.utimes temporary_file 0. 0. >>= fun () -> let stat = Unix.stat temporary_file in let c1 = abs_float (stat.Unix.st_atime -. now) < acceptable_delta in let c2 = abs_float (stat.Unix.st_mtime -. now) < acceptable_delta in Lwt.return (instrument (c1 && c2) "utimes: current time: %f %f %f" now stat.Unix.st_atime stat.Unix.st_mtime)); test "utimes: missing file" (fun () -> Lwt.catch (fun () -> Lwt_unix.utimes "non-existent-file" 0. 0.) (function | Unix.Unix_error (Unix.ENOENT, "utimes", _) -> Lwt.return_unit | Unix.Unix_error (Unix.EUNKNOWNERR _, "utimes", _) -> Lwt.return_unit | e -> Lwt.reraise e) [@ocaml.warning "-4"] >>= fun () -> Lwt.return_true); ] let readdir_tests = let populate n = let path = Test_unix.temp_directory () in let filenames = let rec loop n acc = if n <= 0 then acc else loop (n - 1) ((string_of_int n)::acc) in loop n [] in List.iter (fun filename -> let fd = Unix.(openfile (Filename.concat path filename) [O_WRONLY; O_CREAT] 0o644) in Unix.close fd) filenames; path, ["."; ".."] @ filenames in let equal, subset = let module StringSet = Set.Make (String) in (fun filenames filenames' -> StringSet.equal (StringSet.of_list filenames) (StringSet.of_list filenames')), (fun filenames filenames' -> StringSet.subset (StringSet.of_list filenames) (StringSet.of_list filenames')) in let read_all directory = let rec loop acc = Lwt.catch (fun () -> Lwt_unix.readdir directory >>= fun filename -> Lwt.return (Some filename)) (function | End_of_file -> Lwt.return_none | exn -> Lwt.reraise exn) >>= function | None -> Lwt.return acc | Some filename -> loop (filename::acc) in loop [] in let read_n directory n = let rec loop n acc = if n <= 0 then Lwt.return acc else Lwt_unix.readdir directory >>= fun filename -> loop (n - 1) (filename::acc) in loop n [] in [ test "readdir: basic" (fun () -> let path, filenames = populate 5 in Lwt_unix.opendir path >>= fun directory -> read_all directory >>= fun filenames' -> Lwt_unix.closedir directory >>= fun () -> Lwt.return (List.length filenames' = 7 && equal filenames filenames')); test "readdir: rewinddir" (fun () -> let path, filenames = populate 5 in Lwt_unix.opendir path >>= fun directory -> read_n directory 3 >>= fun filenames' -> Lwt_unix.rewinddir directory >>= fun () -> read_all directory >>= fun filenames'' -> Lwt_unix.closedir directory >>= fun () -> Lwt.return (List.length filenames' = 3 && subset filenames' filenames && List.length filenames'' = 7 && equal filenames'' filenames)); test "readdir: readdir_n" (fun () -> let path, filenames = populate 5 in Lwt_unix.opendir path >>= fun directory -> Lwt_unix.readdir_n directory 3 >>= fun filenames' -> Lwt_unix.readdir_n directory 10 >>= fun filenames'' -> Lwt_unix.closedir directory >>= fun () -> let all = (Array.to_list filenames') @ (Array.to_list filenames'') in Lwt.return (Array.length filenames' = 3 && Array.length filenames'' = 4 && equal all filenames)); test "readdir: files_of_directory" (fun () -> let path, filenames = populate 5 in let stream = Lwt_unix.files_of_directory path in Lwt_stream.to_list stream >>= fun filenames' -> Lwt.return (equal filenames' filenames)); (* Should make sure Win32 behaves in the same way as well. *) test "readdir: already closed" ~only_if:(fun () -> not Sys.win32) (fun () -> let path, _ = populate 0 in Lwt_unix.opendir path >>= fun directory -> Lwt_unix.closedir directory >>= fun () -> let expect_ebadf tag t = let tag = "Lwt_unix." ^ tag in Lwt.catch (fun () -> t () >>= fun () -> Lwt.return_false) (function | Unix.Unix_error (Unix.EBADF, tag', _) when tag' = tag -> Lwt.return_true | exn -> Lwt.reraise exn) [@ocaml.warning "-4"] in Lwt_list.for_all_s (fun (tag, t) -> expect_ebadf tag t) ["readdir", (fun () -> Lwt_unix.readdir directory >|= ignore); "readdir_n", (fun () -> Lwt_unix.readdir_n directory 1 >|= ignore); "rewinddir", (fun () -> Lwt_unix.rewinddir directory); "closedir", (fun () -> Lwt_unix.closedir directory)]); ] let io_vectors_byte_count_tests = let open Lwt_unix.IO_vectors in [ test "io_vector_byte_count: basic" (fun () -> let iov = create () in append_bytes iov (Bytes.create 10) 0 10; append_bigarray iov (Lwt_bytes.create 10) 0 10; Lwt.return (byte_count iov = 20)); test "io_vector_byte_count: offsets, partials" (fun () -> let iov = create () in append_bytes iov (Bytes.create 10) 5 1; append_bigarray iov (Lwt_bytes.create 10) 1 1; Lwt.return (byte_count iov = 2)); test "io_vector_byte_count: drops" (fun () -> let iov = create () in append_bytes iov (Bytes.create 10) 5 1; append_bigarray iov (Lwt_bytes.create 10) 1 1; drop iov 1; Lwt.return (byte_count iov = 1)); ] let readv_tests = (* All buffers are initially filled with '_'. *) let make_io_vectors vecs = let open Lwt_unix.IO_vectors in let io_vectors = create () in let underlying = List.map (function | `Bytes (prefix, slice_length, suffix) -> let buffer = Bytes.make (prefix + slice_length + suffix) '_' in append_bytes io_vectors buffer prefix slice_length; `Bytes buffer | `Bigarray (prefix, slice_length, suffix) -> let total_length = prefix + slice_length + suffix in let buffer = Lwt_bytes.create total_length in Lwt_bytes.fill buffer 0 total_length '_'; append_bigarray io_vectors buffer prefix slice_length; `Bigarray buffer) vecs in io_vectors, underlying in let writer write_fd data = fun () -> let data = Bytes.unsafe_of_string data in Lwt_unix.write write_fd data 0 (Bytes.length data) >>= fun bytes_written -> Lwt_unix.close write_fd >>= fun () -> (* Instrumentation for debugging an unreliable test. *) if bytes_written <> Bytes.length data then Printf.eprintf "\nwritev: expected to write %i bytes; wrote %i\n" (Bytes.length data) bytes_written; Lwt.return (bytes_written = Bytes.length data) in let reader ?(close = true) read_fd io_vectors underlying expected_count expected_data = fun () -> Gc.full_major (); let t = Lwt_unix.readv read_fd io_vectors in Gc.full_major (); t >>= fun bytes_read -> (if close then Lwt_unix.close read_fd else Lwt.return_unit) >>= fun () -> let actual = List.fold_left (fun acc -> function | `Bytes buffer -> acc ^ (Bytes.unsafe_to_string buffer) | `Bigarray buffer -> acc ^ (Lwt_bytes.to_string buffer)) "" underlying in (* Instrumentation for an unreliable test. *) if bytes_read <> expected_count then Printf.eprintf "\nreadv: expected to read %i bytes; read %i\n" expected_count bytes_read; if actual <> expected_data then Printf.eprintf "\nreadv: expected to read %s; read %s\n" expected_data actual; Lwt.return (actual = expected_data && bytes_read = expected_count) in [ test "readv: basic non-blocking" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors, underlying = make_io_vectors [`Bytes (1, 3, 1); `Bigarray (1, 4, 1)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd "foobar"; reader read_fd io_vectors underlying 6 "_foo__bar__"]); test "readv: basic blocking" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors, underlying = make_io_vectors [`Bytes (1, 3, 1); `Bigarray (1, 4, 1)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking read_fd true; Lwt_list.for_all_s (fun t -> t ()) [writer write_fd "foobar"; reader read_fd io_vectors underlying 6 "_foo__bar__"]); test "readv: buffer retention" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> let io_vectors, _ = make_io_vectors [ `Bigarray (3, 0, 3) ] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking read_fd true; Lwt_unix.write_string write_fd "foo" 0 3 >>= fun _ -> let retained = Lwt_unix.retained io_vectors in Lwt_unix.readv read_fd io_vectors >>= fun _ -> Lwt_unix.close write_fd >>= fun () -> Lwt_unix.close read_fd >|= fun () -> !retained end; test "readv: drop" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors, underlying = make_io_vectors [`Bytes (0, 1, 0); `Bytes (1, 4, 1)] in Lwt_unix.IO_vectors.drop io_vectors 2; let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd "foobar"; reader read_fd io_vectors underlying 3 "___foo_"]); test "readv: iovecs exceeding limit" ~only_if:(fun () -> not Sys.win32 && Lwt_unix.IO_vectors.system_limit <> None) (fun () -> let limit = match Lwt_unix.IO_vectors.system_limit with | Some limit -> limit | None -> assert false in let underlying = Array.init (limit + 1) (fun _ -> `Bytes (Bytes.make 1 '_')) |> Array.to_list in let io_vectors = Lwt_unix.IO_vectors.create () in List.iter (fun (`Bytes buffer) -> Lwt_unix.IO_vectors.append_bytes io_vectors buffer 0 1) underlying; let expected = String.make limit 'a' in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd (expected ^ "a"); reader read_fd io_vectors underlying limit (expected ^ "_")]); test "readv: windows" ~only_if:(fun () -> Sys.win32) begin fun () -> let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in let io_vectors, underlying = make_io_vectors [ `Bytes (1, 3, 1); `Bigarray (1, 4, 1) ] in Lwt_list.for_all_s (fun t -> t ()) [ writer write_fd "foobar"; reader ~close:false read_fd io_vectors underlying 3 "_foo_______"; (fun () -> Lwt_unix.IO_vectors.drop io_vectors 3; Lwt.return_true); reader read_fd io_vectors underlying 3 "_foo__bar__"; ] end; ] let writev_tests = let make_io_vectors vecs = let open Lwt_unix.IO_vectors in let io_vectors = create () in List.iter (function | `Bytes (s, offset, length) -> append_bytes io_vectors (Bytes.unsafe_of_string s) offset length | `Bigarray (s, offset, length) -> append_bigarray io_vectors (Lwt_bytes.of_string s) offset length) vecs; io_vectors in let writer ?(close = true) ?blocking write_fd io_vectors data_length = fun () -> Lwt_unix.blocking write_fd >>= fun is_blocking -> Gc.full_major (); let t = Lwt_unix.writev write_fd io_vectors in Gc.full_major (); t >>= fun bytes_written -> (if close then Lwt_unix.close write_fd else Lwt.return_unit) >>= fun () -> let blocking_matches = match blocking, is_blocking with | Some v, v' when v <> v' -> Printf.eprintf "\nblocking: v = %b, v' = %b\n" v v'; false | _ -> true in if bytes_written <> data_length then Printf.eprintf "\nwritev: expected to write %i bytes; wrote %i\n" data_length bytes_written; Lwt.return (bytes_written = data_length && blocking_matches) in let reader read_fd ?(not_readable = false) expected_data = fun () -> if not_readable then let readable = Lwt_unix.readable read_fd in Lwt_unix.close read_fd >>= fun () -> if readable then Printf.eprintf "\nreadable: %b\n" readable; Lwt.return (not readable) else let open! Lwt_io in let channel = of_fd ~mode:input read_fd in read channel >>= fun read_data -> close channel >>= fun () -> if read_data <> expected_data then Printf.eprintf "\nreadv: expected to read %s; read %s (length %i)\n" expected_data read_data (String.length read_data); Lwt.return (read_data = expected_data) in [ test "writev: basic non-blocking" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 3); `Bytes ("bar", 0, 3); `Bigarray ("baz", 0, 3)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer ~blocking:false write_fd io_vectors 9; reader read_fd "foobarbaz"]); test "writev: basic blocking" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 3); `Bytes ("bar", 0, 3); `Bigarray ("baz", 0, 3)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking write_fd true; Lwt_list.for_all_s (fun t -> t ()) [writer ~blocking:true write_fd io_vectors 9; reader read_fd "foobarbaz"]); test "writev: buffer retention" ~sequential:true ~only_if:(fun () -> not Sys.win32) begin fun () -> let io_vectors = make_io_vectors [ `Bigarray ("foo", 0, 3) ] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_unix.set_blocking write_fd true; let retained = Lwt_unix.retained io_vectors in Lwt_unix.writev write_fd io_vectors >>= fun _ -> Lwt_unix.close write_fd >>= fun () -> Lwt_unix.close read_fd >|= fun () -> !retained end; test "writev: slices" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 1, 2); `Bigarray ("bar", 1, 2)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors 4; reader read_fd "ooar"]); test "writev: drop, is_empty" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 3); `Bytes ("bar", 0, 3); `Bigarray ("baz", 0, 3)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in let initially_empty = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt_unix.IO_vectors.drop io_vectors 4; let empty_after_partial_drop = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors 5; reader read_fd "arbaz"] >>= fun io_correct -> Lwt_unix.IO_vectors.drop io_vectors 5; let empty_after_exact_drop = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt_unix.IO_vectors.drop io_vectors 100; let empty_after_excess_drop = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt.return (not initially_empty && not empty_after_partial_drop && io_correct && empty_after_exact_drop && empty_after_excess_drop)); test "writev: degenerate vectors" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 0); `Bigarray ("bar", 0, 0)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in let initially_empty = Lwt_unix.IO_vectors.is_empty io_vectors in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors 0; reader read_fd ""] >>= fun io_correct -> Lwt.return (initially_empty && io_correct)); test "writev: bad iovec" ~only_if:(fun () -> not Sys.win32) (fun () -> let negative_offset = make_io_vectors [`Bytes ("foo", -1, 3)] in let negative_length = make_io_vectors [`Bytes ("foo", 0, -1)] in let out_of_bounds = make_io_vectors [`Bytes ("foo", 1, 3)] in let negative_offset' = make_io_vectors [`Bigarray ("foo", -1, 3)] in let negative_length' = make_io_vectors [`Bigarray ("foo", 0, -1)] in let out_of_bounds' = make_io_vectors [`Bigarray ("foo", 1, 3)] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in let writer io_vectors = fun () -> Lwt.catch (fun () -> Lwt_unix.writev write_fd io_vectors >>= fun _ -> Lwt.return_false) (function | Invalid_argument _ -> Lwt.return_true | e -> Lwt.reraise e) in let close write_fd = fun () -> Lwt_unix.close write_fd >>= fun () -> Lwt.return_true in Lwt_list.for_all_s (fun t -> t ()) [writer negative_offset; writer negative_length; writer out_of_bounds; writer negative_offset'; writer negative_length'; writer out_of_bounds'; reader read_fd ~not_readable:true ""; close write_fd]); test "writev: iovecs exceeding limit" ~only_if:(fun () -> not Sys.win32 && Lwt_unix.IO_vectors.system_limit <> None) (fun () -> let limit = match Lwt_unix.IO_vectors.system_limit with | Some limit -> limit | None -> assert false in let io_vectors = let open Lwt_unix.IO_vectors in let io_vectors = create () in let rec loop count = if count < 1 then io_vectors else (append_bytes io_vectors (Bytes.unsafe_of_string "a") 0 1; loop (count - 1)) in loop (limit + 1) in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors limit; reader read_fd (String.make limit 'a')]); test "writev: negative drop" ~only_if:(fun () -> not Sys.win32) (fun () -> let io_vectors = make_io_vectors [`Bytes ("foo", 0, 3)] in Lwt_unix.IO_vectors.drop io_vectors (-1); let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [writer write_fd io_vectors 3; reader read_fd "foo"] >>= fun io_correct -> Lwt.return (io_correct && not (Lwt_unix.IO_vectors.is_empty io_vectors))); test "writev: windows" ~only_if:(fun () -> Sys.win32) begin fun () -> let io_vectors = make_io_vectors [ `Bytes ("foo", 0, 3); `Bigarray ("bar", 0, 3); ] in let read_fd, write_fd = Lwt_unix.pipe ~cloexec:true () in Lwt_list.for_all_s (fun t -> t ()) [ writer ~close:false write_fd io_vectors 3; (fun () -> Lwt_unix.IO_vectors.drop io_vectors 3; Lwt.return_true); writer write_fd io_vectors 3; reader read_fd "foobar"; ] end; ] let send_recv_msg_tests = [ test "send_msg, recv_msg" ~only_if:(fun () -> not Sys.win32) begin fun () -> let socket_1, socket_2 = Lwt_unix.(socketpair PF_UNIX SOCK_STREAM 0) in let pipe_read, pipe_write = Lwt_unix.pipe ~cloexec:true () in let source_buffer = Bytes.of_string "_foo_bar_" in let source_iovecs = Lwt_unix.IO_vectors.create () in Lwt_unix.IO_vectors.append_bytes source_iovecs source_buffer 1 3; Lwt_unix.IO_vectors.append_bytes source_iovecs source_buffer 5 3; Lwt_unix.send_msg ~socket:socket_1 ~io_vectors:source_iovecs ~fds:[Lwt_unix.unix_file_descr pipe_write] >>= fun n -> if n <> 6 then Lwt.return_false else let destination_buffer = Bytes.of_string "_________" in let destination_iovecs = Lwt_unix.IO_vectors.create () in Lwt_unix.IO_vectors.append_bytes destination_iovecs destination_buffer 5 3; Lwt_unix.IO_vectors.append_bytes destination_iovecs destination_buffer 1 3; Lwt_unix.recv_msg ~socket:socket_2 ~io_vectors:destination_iovecs >>= fun (n, fds) -> let succeeded = match n, fds, Bytes.to_string destination_buffer with | 6, [fd], "_bar_foo_" -> Some fd | _ -> None in match succeeded with | None -> Lwt.return_false | Some fd -> let n = Unix.write fd (Bytes.of_string "baz") 0 3 in if n <> 3 then Lwt.return_false else let buffer = Bytes.create 3 in Lwt_unix.read pipe_read buffer 0 3 >>= fun n -> match n, Bytes.to_string buffer with | 3, "baz" -> Lwt_unix.close socket_1 >>= fun () -> Lwt_unix.close socket_2 >>= fun () -> Lwt_unix.close pipe_read >>= fun () -> Lwt_unix.close pipe_write >>= fun () -> Unix.close fd; Lwt.return_true | _ -> Lwt.return_false end; test "send_msg, recv_msg (Lwt_bytes, old)" ~only_if:(fun () -> not Sys.win32) begin fun () -> let socket_1, socket_2 = Lwt_unix.(socketpair PF_UNIX SOCK_STREAM 0) in let pipe_read, pipe_write = Lwt_unix.pipe ~cloexec:true () in let source_buffer = Lwt_bytes.of_string "_foo_bar_" in let source_iovecs = Lwt_bytes.[ { iov_buffer = source_buffer; iov_offset = 1; iov_length = 3; }; { iov_buffer = source_buffer; iov_offset = 5; iov_length = 3; }; ] in (Lwt_bytes.send_msg [@ocaml.warning "-3"]) ~socket:socket_1 ~io_vectors:source_iovecs ~fds:[Lwt_unix.unix_file_descr pipe_write] >>= fun n -> if n <> 6 then Lwt.return_false else let destination_buffer = Lwt_bytes.of_string "_________" in let destination_iovecs = Lwt_bytes.[ { iov_buffer = destination_buffer; iov_offset = 5; iov_length = 3; }; { iov_buffer = destination_buffer; iov_offset = 1; iov_length = 3; }; ] in (Lwt_bytes.recv_msg [@ocaml.warning "-3"]) ~socket:socket_2 ~io_vectors:destination_iovecs >>= fun (n, fds) -> let succeeded = match n, fds, Lwt_bytes.to_string destination_buffer with | 6, [fd], "_bar_foo_" -> Some fd | _ -> None in match succeeded with | None -> Lwt.return_false | Some fd -> let n = Unix.write fd (Bytes.of_string "baz") 0 3 in if n <> 3 then Lwt.return_false else let buffer = Bytes.create 3 in Lwt_unix.read pipe_read buffer 0 3 >>= fun n -> match n, Bytes.to_string buffer with | 3, "baz" -> Lwt_unix.close socket_1 >>= fun () -> Lwt_unix.close socket_2 >>= fun () -> Lwt_unix.close pipe_read >>= fun () -> Lwt_unix.close pipe_write >>= fun () -> Unix.close fd; Lwt.return_true | _ -> Lwt.return_false end; ] let bind_tests_address = Unix.(ADDR_INET (inet_addr_loopback, 56100)) let bind_tests = let directory_exists dir = try Sys.is_directory dir with Sys_error _ -> false in [ test "bind: basic" (fun () -> let socket = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt.finalize (fun () -> Lwt_unix.bind socket bind_tests_address >>= fun () -> Lwt.return (Unix.getsockname (Lwt_unix.unix_file_descr socket))) (fun () -> Lwt_unix.close socket) >>= fun address' -> Lwt.return (address' = bind_tests_address)); test "bind: Unix domain" ~only_if:(fun () -> not Sys.win32 && not (directory_exists "/hurd")) (fun () -> let socket = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in let rec bind_loop attempts = let path = Test_unix.temp_name () in let address = Unix.(ADDR_UNIX path) in Lwt.catch (fun () -> Lwt_unix.bind socket address >>= fun () -> Lwt.return path) (function | Unix.Unix_error (Unix.EADDRINUSE, "bind", _) | Unix.Unix_error (Unix.EISDIR, "bind", _) as exn -> if attempts <= 1 then Lwt.reraise exn else bind_loop (attempts - 1) | Unix.Unix_error (Unix.EPERM, "bind", _) -> (* On EPERM, assume that we are under WSL, but in the Windows filesystem. If this ever results in a false positive, this test should add a check for WSL by checking for the existence of /proc/version, reading it, and checking its contents for the string "WSL". *) raise Skip | e -> Lwt.reraise e) [@ocaml.warning "-4"] in Lwt.finalize (fun () -> bind_loop 5 >>= fun chosen_path -> let actual_path = Unix.getsockname (Lwt_unix.unix_file_descr socket) in Lwt.return (chosen_path, actual_path)) (fun () -> Lwt_unix.close socket) >>= fun (chosen_path, actual_path) -> let actual_path = match actual_path with | Unix.ADDR_UNIX path -> path | Unix.ADDR_INET _ -> assert false in (try Unix.unlink chosen_path with _ -> ()); (try Unix.unlink actual_path with _ -> ()); (* Compare with a prefix of the actual path, due to https://github.com/ocaml/ocaml/pull/987 *) try Lwt.return (chosen_path = String.sub actual_path 0 (String.length chosen_path)) with Invalid_argument _ -> Lwt.return_false); test "bind: closed" (fun () -> let socket = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt_unix.close socket >>= fun () -> Lwt.catch (fun () -> Lwt_unix.bind socket bind_tests_address >>= fun () -> Lwt.return_false) (function | Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_true | e -> Lwt.reraise e) [@ocaml.warning "-4"]); test "bind: aborted" (fun () -> let socket = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in Lwt_unix.abort socket Exit; Lwt.finalize (fun () -> Lwt.catch (fun () -> Lwt_unix.bind socket bind_tests_address >>= fun () -> Lwt.return_false) (function | Exit -> Lwt.return_true | e -> Lwt.reraise e)) (fun () -> Lwt_unix.close socket)); ] let dir_tests = [ test "getcwd" (fun () -> Lwt_unix.getcwd () >>= fun (_:string) -> Lwt.return_true ); test "getcwd and chdir" (fun () -> Lwt_unix.getcwd () >>= fun here -> Lwt_unix.chdir here >>= fun () -> Lwt_unix.getcwd () >>= fun there -> Lwt.return (here = there) ); test "getcwd and Unix.getcwd" (fun () -> let unix_here = Unix.getcwd () in Lwt_unix.getcwd () >>= fun here -> Lwt.return (here = unix_here) ); ] let lwt_preemptive_tests = [ test "run_in_main" begin fun () -> let f () = Lwt_preemptive.run_in_main (fun () -> Lwt_unix.sleep 0.01 >>= fun () -> Lwt.return 42) in Lwt_preemptive.detach f () >>= fun x -> Lwt.return (x = 42) end; test "run_in_main_dont_wait" begin fun () -> let p, r = Lwt.wait () in let f () = Lwt_preemptive.run_in_main_dont_wait (fun () -> Lwt.pause () >>= fun () -> Lwt.pause () >>= fun () -> Lwt.wakeup r 42; Lwt.return ()) (fun _ -> assert false) in Lwt_preemptive.detach f () >>= fun () -> p >>= fun x -> Lwt.return (x = 42) end; test "run_in_main_dont_wait_fail" begin fun () -> let p, r = Lwt.wait () in let f () = Lwt_preemptive.run_in_main_dont_wait (fun () -> Lwt.pause () >>= fun () -> Lwt.pause () >>= fun () -> raise Exit) (function Exit -> Lwt.wakeup r 45 | _ -> assert false) in Lwt_preemptive.detach f () >>= fun () -> p >>= fun x -> Lwt.return (x = 45) end; test "run_in_main_with_dont_wait" begin fun () -> let p, r = Lwt.wait () in let f () = Lwt_preemptive.run_in_main (fun () -> Lwt.dont_wait (fun () -> Lwt.pause () >>= fun () -> Lwt.pause () >>= fun () -> Lwt.wakeup r 42; Lwt.return ()) (function _ -> Stdlib.exit 2); Lwt.return ()) in Lwt_preemptive.detach f () >>= fun () -> p >>= fun x -> Lwt.return (x = 42) end; ] let getlogin_works = if Sys.win32 then false else match Unix.getlogin () with | _ -> true | exception Unix.Unix_error _ -> false let lwt_user_tests = [ test "getlogin and Unix.getlogin" ~only_if:(fun () -> getlogin_works) begin fun () -> let unix_user = Unix.getlogin () in Lwt_unix.getlogin () >>= fun user -> Lwt.return (user = unix_user) end; test "getpwnam and Unix.getpwnam" ~only_if:(fun () -> getlogin_works) begin fun () -> let unix_user = Unix.getlogin () in let unix_password = Unix.getpwnam unix_user in Lwt_unix.getpwnam unix_user >>= fun password -> Lwt.return (password = unix_password) end; test "getpwuid and Unix.getpwuid" ~only_if:(fun () -> getlogin_works) begin fun () -> let pwnam = Unix.getpwnam (Unix.getlogin ()) in let unix_pwuid = Unix.getpwuid pwnam.pw_uid in Lwt_unix.getpwuid pwnam.pw_uid >>= fun pwuid -> Lwt.return (pwuid = unix_pwuid) end; test "getgrgid and Unix.getgrgid" ~only_if:(fun () -> not Sys.win32) begin fun () -> let group_id = Unix.getgid () in let unix_group = Unix.getgrgid group_id in Lwt_unix.getgrgid group_id >>= fun group -> Lwt.return (group = unix_group) end; test "getgrnam and Unix.getgrnam" ~only_if:(fun () -> not Sys.win32) begin fun () -> let group_id = Unix.getgid () in let unix_group = Unix.getgrgid group_id in let group_name = unix_group.gr_name in Lwt_unix.getgrnam group_name >>= fun group -> Lwt.return (group = unix_group) end ] let file_suffix = let last_file_suffix = ref 0 in fun () -> incr last_file_suffix; !last_file_suffix let test_filename name = Printf.sprintf "%s_%i" name (file_suffix ()) let pread_tests ~blocking = let test_file = test_filename "test_pread_pwrite" in let file_contents = "01234567890123456789" in let blocking_string = if blocking then " blocking" else " nonblocking" in [ test ~sequential:true ("basic pread" ^ blocking_string) (fun () -> Lwt_unix.openfile test_file [O_RDWR; O_TRUNC; O_CREAT] 0o666 >>= fun fd -> if not blocking then Lwt_unix.set_blocking ~set_flags:false fd false; Lwt_unix.write_string fd file_contents 0 (String.length file_contents) >>= fun n -> assert(n = String.length file_contents); (* This should always be true in practice, show it if this is the reason for failing *) let buf = Bytes.make 3 '\x00' in Lwt_unix.pread fd buf ~file_offset:3 0 3 >>= fun n -> assert(n = 3); let read1 = Bytes.to_string buf in Lwt_unix.pread fd buf ~file_offset:15 0 3 >>= fun n -> assert(n = 3); let read2 = Bytes.to_string buf in Lwt_unix.close fd >>= fun () -> Lwt.return (read1 = "345" && read2 = "567")); test ~sequential:true ("basic pwrite" ^ blocking_string) (fun () -> Lwt_unix.openfile test_file [O_RDWR] 0o666 >>= fun fd -> if not blocking then Lwt_unix.set_blocking ~set_flags:false fd false; let t1 = Lwt_unix.pwrite_string fd "abcd" ~file_offset:5 0 4 in let t2 = Lwt_unix.pwrite_string fd "efg" ~file_offset:15 0 3 in t2 >>= fun l2 -> t1 >>= fun l1 -> assert(l1 = 4); assert(l2 = 3); Lwt_unix.lseek fd 0 Lwt_unix.SEEK_SET >>= fun _pos -> let buf = Bytes.make (String.length file_contents) '\x00' in Lwt_unix.read fd buf 0 (String.length file_contents) >>= fun n -> assert(n = (String.length file_contents)); Lwt_unix.close fd >>= fun () -> let read = Bytes.to_string buf in Lwt.return (read = "01234abcd901234efg89")); test ~sequential:true ("remove file" ^ blocking_string) (fun () -> Unix.unlink test_file; Lwt.return_true); ] let dup_tests ~blocking = let test_file = test_filename "test_dup" in let file_contents = "01234567890123456789" in let len = String.length file_contents in let buf = Bytes.make len '\x00' in let blocking_string = if blocking then " blocking" else " nonblocking" in [ test ~sequential:true ("dup on socket" ^ blocking_string) (fun () -> let s1, s2 = if Sys.win32 then Lwt_unix.socketpair Unix.PF_INET6 Unix.SOCK_STREAM 0 else Lwt_unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in if not blocking then Lwt_unix.set_blocking ~set_flags:false s1 false; let s1' = Lwt_unix.dup s1 in Lwt_unix.blocking s1 >>= fun s1_is_blocking -> Lwt_unix.blocking s1' >>= fun s1'_is_blocking -> assert(s1_is_blocking = s1'_is_blocking); Lwt_unix.write_string s1 file_contents 0 len >>= fun n -> assert(n = len); Lwt_unix.read s2 buf 0 len >>= fun n -> assert(n = len); let read = Bytes.to_string buf in assert(read = file_contents); Lwt_unix.write_string s1' file_contents 0 len >>= fun n -> assert(n = len); Lwt_unix.read s2 buf 0 len >>= fun n -> assert(n = len); let read = Bytes.to_string buf in assert(read = file_contents); Lwt_list.iter_p Lwt_unix.close [s1; s1'; s2] >>= fun () -> Lwt.return_true); test ~sequential:true ("dup on file" ^ blocking_string) (fun () -> Lwt_unix.openfile test_file [O_RDWR; O_TRUNC; O_CREAT] 0o666 >>= fun fd -> if not blocking then Lwt_unix.set_blocking ~set_flags:false fd false; let fd' = Lwt_unix.dup fd in Lwt_unix.blocking fd >>= fun fd_is_blocking -> Lwt_unix.blocking fd' >>= fun fd'_is_blocking -> assert(fd_is_blocking = fd'_is_blocking); Lwt_unix.write_string fd file_contents 0 len >>= fun n -> assert(n = len); Lwt_unix.lseek fd 0 Lwt_unix.SEEK_SET >>= fun _pos -> let buf = Bytes.make (String.length file_contents) '\x00' in Lwt_unix.read fd buf 0 (String.length file_contents) >>= fun n -> assert(n = (String.length file_contents)); let read = Bytes.to_string buf in assert (read = file_contents); Lwt_unix.write_string fd' file_contents 0 len >>= fun n -> assert(n = len); Lwt_unix.lseek fd' 0 Lwt_unix.SEEK_SET >>= fun _pos -> let buf = Bytes.make (String.length file_contents) '\x00' in Lwt_unix.read fd' buf 0 (String.length file_contents) >>= fun n -> assert(n = (String.length file_contents)); let read = Bytes.to_string buf in assert (read = file_contents); Lwt.return_true); ] let suite = suite "lwt_unix" (wait_tests @ openfile_tests @ utimes_tests @ readdir_tests @ io_vectors_byte_count_tests @ readv_tests @ writev_tests @ send_recv_msg_tests @ bind_tests @ dir_tests @ lwt_preemptive_tests @ lwt_user_tests @ pread_tests ~blocking:true @ pread_tests ~blocking:false @ dup_tests ~blocking:true @ dup_tests ~blocking:false ) lwt-5.9.1/test/unix/test_mcast.ml000066400000000000000000000052151476253734400170200ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Lwt.Infix open Test let debug = false let hello = Bytes.unsafe_of_string "Hello, World!" let mcast_addr = let last_group = ref 0 in fun () -> incr last_group; Printf.sprintf "225.0.0.%i" !last_group let mcast_port = let last_port = ref 4421 in fun () -> incr last_port; !last_port let child mcast_addr join fd = if join then Lwt_unix.mcast_add_membership fd (Unix.inet_addr_of_string mcast_addr); let buf = Bytes.create 50 in Lwt_unix.with_timeout 1. (fun () -> Lwt_unix.read fd buf 0 (Bytes.length buf)) >>= fun n -> if debug then Printf.printf "\nReceived multicast message %S\n%!" (Bytes.unsafe_to_string (Bytes.sub buf 0 n)); if Bytes.sub buf 0 n <> hello then raise (Failure "unexpected multicast message") else Lwt.return_unit let parent mcast_addr mcast_port set_loop fd = Lwt_unix.mcast_set_loop fd set_loop; let addr = Lwt_unix.ADDR_INET (Unix.inet_addr_of_string mcast_addr, mcast_port) in Lwt_unix.sendto fd hello 0 (Bytes.length hello) [] addr >>= fun _ -> if debug then Printf.printf "\nSending multicast message %S to %s:%d\n%!" (Bytes.unsafe_to_string hello) mcast_addr mcast_port; Lwt.return_unit let test_mcast name join set_loop = test name ~only_if:(fun () -> not Sys.win32) begin fun () -> let mcast_addr = mcast_addr () in let mcast_port = mcast_port () in let should_timeout = not join || not set_loop in let fd1 = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in let fd2 = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in let t () = Lwt.catch (fun () -> Lwt_unix.(bind fd1 (ADDR_INET (Unix.inet_addr_any, mcast_port))) >>= fun () -> let t1 = child mcast_addr join fd1 in let t2 = parent mcast_addr mcast_port set_loop fd2 in Lwt.join [t1; t2] >>= fun () -> Lwt.return_true ) (function | Lwt_unix.Timeout -> Lwt.return should_timeout | Unix.Unix_error (Unix.EINVAL, "send", _) | Unix.Unix_error (Unix.ENODEV, "setsockopt", _) | Unix.Unix_error (Unix.ENETUNREACH, "send", _) -> raise Skip | e -> Lwt.reraise e ) in Lwt.finalize t (fun () -> Lwt.join [Lwt_unix.close fd1; Lwt_unix.close fd2]) end let suite = suite "unix_mcast" [ test_mcast "mcast-join-loop" true true; test_mcast "mcast-nojoin-loop" false true; test_mcast "mcast-join-noloop" true false; test_mcast "mcast-nojoin-noloop" false false; ] lwt-5.9.1/test/unix/test_sleep_and_timeout.ml000066400000000000000000000064441476253734400214160ustar00rootroot00000000000000(* This file is part of Lwt, released under the MIT license. See LICENSE.md for details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) open Test open Lwt.Infix (* None of the APIs make promises about how much larger the elapsed time will * be, but they all promise that it won't be less than the expected time. *) let cmp_elapsed_time test_name start_time expected_time = let elapsed_time = Unix.gettimeofday () -. start_time in let diff = elapsed_time -. expected_time in let result = diff >= 0. && diff <= 0.2 in instrument result "Lwt_unix sleep and timeout: %s: %f %f %f %b" test_name elapsed_time expected_time diff (Lwt_sys.have `libev) let suite = suite "Lwt_unix sleep and timeout" [ test "sleep" begin fun () -> let start_time = Unix.gettimeofday () in let duration = 1.0 in Lwt_unix.sleep duration >>= fun () -> let check = cmp_elapsed_time "sleep" start_time duration in Lwt.return check end; test "timeout" begin fun () -> let start_time = Unix.gettimeofday () in let duration = 1.0 in Lwt.catch (fun () -> Lwt_unix.timeout duration >>= fun () -> Lwt.return_false ) (function | Lwt_unix.Timeout -> let check = cmp_elapsed_time "timeout" start_time duration in Lwt.return check | exn -> Lwt.reraise exn ) end; test "with_timeout : no timeout" begin fun () -> let duration = 1.0 in Lwt_unix.with_timeout duration Lwt.pause >>= fun () -> Lwt.return_true end; test "with_timeout : timeout" begin fun () -> let start_time = Unix.gettimeofday () in let duration = 1.0 in let f () = Lwt_unix.sleep 2.0 in Lwt.catch (fun () -> Lwt_unix.with_timeout duration f >>= fun () -> Printf.eprintf "\nno timeout\n"; Lwt.return_false ) (function | Lwt_unix.Timeout -> let check = cmp_elapsed_time "with_timeout : timeout" start_time duration in Lwt.return check | exn -> Lwt.reraise exn ) end; test "pause" begin fun () -> let bind_callback_ran = ref false in Lwt.async (fun () -> Lwt.return_unit >|= fun () -> bind_callback_ran := true); let bind_is_immediate = !bind_callback_ran in let pause_callback_ran = ref false in Lwt.async (fun () -> Lwt.pause () >|= fun () -> pause_callback_ran := true); let pause_is_immediate = !pause_callback_ran in Lwt.return (bind_is_immediate && not pause_is_immediate) end; test "auto_pause" begin fun () -> let f = Lwt_unix.auto_pause 1.0 in let run_auto_pause () = let callback_ran = ref false in Lwt.async (fun () -> f () >|= fun () -> callback_ran := true); !callback_ran; in let check1 = run_auto_pause () in let check2 = run_auto_pause () in Lwt_unix.sleep 1.0 >|= fun () -> let check3 = run_auto_pause () in let check4 = run_auto_pause () in let check5 = run_auto_pause () in let check = check1 && check2 && not check3 && check4 && check5 in instrument check "Lwt_unix sleep and timeout: auto_pause: %b %b %b %b %b" check1 check2 check3 check4 check5 end; ]