├── .gitignore ├── .merlin.in ├── .ocp-indent ├── .utopinit ├── CONTRIBUTORS.md ├── COPYING.txt ├── Makefile ├── README.md ├── _tags ├── myocamlbuild.ml ├── src └── rwoLwt.ml └── utop.sh /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | 3 | *.native 4 | *.byte 5 | -------------------------------------------------------------------------------- /.merlin.in: -------------------------------------------------------------------------------- 1 | S src 2 | B _build/src 3 | 4 | PKG cohttp.lwt 5 | S %{prefix}%/build/cohttp.*/_build/lib 6 | S %{prefix}%/build/cohttp.*/_build/lwt 7 | S %{prefix}%/build/cohttp.*/_build/lwt-core 8 | 9 | PKG lwt.ppx lwt.preemptive 10 | S %{prefix}%/build/lwt.*/_build/src/* 11 | 12 | S %{prefix}%/build/uri.*/_build/lib 13 | 14 | PKG yojson 15 | S %{prefix}%/build/yojson.* 16 | 17 | # Check principality of type inference 18 | FLG -principal 19 | 20 | # Make strings immutable. 21 | FLG -safe-string 22 | 23 | # Shorten paths in types. 24 | FLG -short-paths 25 | 26 | # Reject invalid formats accepted by legacy implementations. 27 | FLG -strict-formats 28 | 29 | # Left-hand part of a sequence must have type unit. 30 | FLG -strict-sequence 31 | 32 | # Add support for system threads library 33 | FLG -thread 34 | 35 | # 4 Fragile pattern matching: matching that will remain complete even if 36 | # additional constructors are added to one of the variant types matched. 37 | # 42 Disambiguated constructor or label name (compatibility warning). 38 | FLG -w +A-4-42 39 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | normal 2 | strict_with=auto 3 | -------------------------------------------------------------------------------- /.utopinit: -------------------------------------------------------------------------------- 1 | #principal true;; 2 | (* 41 Ambiguous constructor or label name. *) 3 | #warnings "+41";; 4 | 5 | (* OPAM *) 6 | let () = 7 | try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 8 | with Not_found -> ();; 9 | 10 | (* Findlib *) 11 | #use "topfind";; 12 | (* #topfind_verbose true;; *) 13 | #thread;; 14 | 15 | #require "cohttp.lwt";; 16 | 17 | #require "lwt.ppx";; 18 | #require "lwt.preemptive";; 19 | 20 | #require "yojson";; 21 | 22 | #utop_prompt_dummy;; 23 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | The following people - listed in alphabetical order - contributed to [Concurrent Programming with Lwt](https://github.com/dkim/rwo-lwt): 2 | 3 | * [Anton Bachin](https://github.com/aantron) 4 | * [Deokhwan Kim](https://github.com/dkim) 5 | -------------------------------------------------------------------------------- /COPYING.txt: -------------------------------------------------------------------------------- 1 | CC0 1.0 Universal 2 | 3 | Statement of Purpose 4 | 5 | The laws of most jurisdictions throughout the world automatically confer 6 | exclusive Copyright and Related Rights (defined below) upon the creator 7 | and subsequent owner(s) (each and all, an "owner") of an original work of 8 | authorship and/or a database (each, a "Work"). 9 | 10 | Certain owners wish to permanently relinquish those rights to a Work for 11 | the purpose of contributing to a commons of creative, cultural and 12 | scientific works ("Commons") that the public can reliably and without fear 13 | of later claims of infringement build upon, modify, incorporate in other 14 | works, reuse and redistribute as freely as possible in any form whatsoever 15 | and for any purposes, including without limitation commercial purposes. 16 | These owners may contribute to the Commons to promote the ideal of a free 17 | culture and the further production of creative, cultural and scientific 18 | works, or to gain reputation or greater distribution for their Work in 19 | part through the use and efforts of others. 20 | 21 | For these and/or other purposes and motivations, and without any 22 | expectation of additional consideration or compensation, the person 23 | associating CC0 with a Work (the "Affirmer"), to the extent that he or she 24 | is an owner of Copyright and Related Rights in the Work, voluntarily 25 | elects to apply CC0 to the Work and publicly distribute the Work under its 26 | terms, with knowledge of his or her Copyright and Related Rights in the 27 | Work and the meaning and intended legal effect of CC0 on those rights. 28 | 29 | 1. Copyright and Related Rights. A Work made available under CC0 may be 30 | protected by copyright and related or neighboring rights ("Copyright and 31 | Related Rights"). Copyright and Related Rights include, but are not 32 | limited to, the following: 33 | 34 | i. the right to reproduce, adapt, distribute, perform, display, 35 | communicate, and translate a Work; 36 | ii. moral rights retained by the original author(s) and/or performer(s); 37 | iii. publicity and privacy rights pertaining to a person's image or 38 | likeness depicted in a Work; 39 | iv. rights protecting against unfair competition in regards to a Work, 40 | subject to the limitations in paragraph 4(a), below; 41 | v. rights protecting the extraction, dissemination, use and reuse of data 42 | in a Work; 43 | vi. database rights (such as those arising under Directive 96/9/EC of the 44 | European Parliament and of the Council of 11 March 1996 on the legal 45 | protection of databases, and under any national implementation 46 | thereof, including any amended or successor version of such 47 | directive); and 48 | vii. other similar, equivalent or corresponding rights throughout the 49 | world based on applicable law or treaty, and any national 50 | implementations thereof. 51 | 52 | 2. Waiver. To the greatest extent permitted by, but not in contravention 53 | of, applicable law, Affirmer hereby overtly, fully, permanently, 54 | irrevocably and unconditionally waives, abandons, and surrenders all of 55 | Affirmer's Copyright and Related Rights and associated claims and causes 56 | of action, whether now known or unknown (including existing as well as 57 | future claims and causes of action), in the Work (i) in all territories 58 | worldwide, (ii) for the maximum duration provided by applicable law or 59 | treaty (including future time extensions), (iii) in any current or future 60 | medium and for any number of copies, and (iv) for any purpose whatsoever, 61 | including without limitation commercial, advertising or promotional 62 | purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each 63 | member of the public at large and to the detriment of Affirmer's heirs and 64 | successors, fully intending that such Waiver shall not be subject to 65 | revocation, rescission, cancellation, termination, or any other legal or 66 | equitable action to disrupt the quiet enjoyment of the Work by the public 67 | as contemplated by Affirmer's express Statement of Purpose. 68 | 69 | 3. Public License Fallback. Should any part of the Waiver for any reason 70 | be judged legally invalid or ineffective under applicable law, then the 71 | Waiver shall be preserved to the maximum extent permitted taking into 72 | account Affirmer's express Statement of Purpose. In addition, to the 73 | extent the Waiver is so judged Affirmer hereby grants to each affected 74 | person a royalty-free, non transferable, non sublicensable, non exclusive, 75 | irrevocable and unconditional license to exercise Affirmer's Copyright and 76 | Related Rights in the Work (i) in all territories worldwide, (ii) for the 77 | maximum duration provided by applicable law or treaty (including future 78 | time extensions), (iii) in any current or future medium and for any number 79 | of copies, and (iv) for any purpose whatsoever, including without 80 | limitation commercial, advertising or promotional purposes (the 81 | "License"). The License shall be deemed effective as of the date CC0 was 82 | applied by Affirmer to the Work. Should any part of the License for any 83 | reason be judged legally invalid or ineffective under applicable law, such 84 | partial invalidity or ineffectiveness shall not invalidate the remainder 85 | of the License, and in such case Affirmer hereby affirms that he or she 86 | will not (i) exercise any of his or her remaining Copyright and Related 87 | Rights in the Work or (ii) assert any associated claims and causes of 88 | action with respect to the Work, in either case contrary to Affirmer's 89 | express Statement of Purpose. 90 | 91 | 4. Limitations and Disclaimers. 92 | 93 | a. No trademark or patent rights held by Affirmer are waived, abandoned, 94 | surrendered, licensed or otherwise affected by this document. 95 | b. Affirmer offers the Work as-is and makes no representations or 96 | warranties of any kind concerning the Work, express, implied, 97 | statutory or otherwise, including without limitation warranties of 98 | title, merchantability, fitness for a particular purpose, non 99 | infringement, or the absence of latent or other defects, accuracy, or 100 | the present or absence of errors, whether or not discoverable, all to 101 | the greatest extent permissible under applicable law. 102 | c. Affirmer disclaims responsibility for clearing rights of other persons 103 | that may apply to the Work or any use thereof, including without 104 | limitation any person's Copyright and Related Rights in the Work. 105 | Further, Affirmer disclaims responsibility for obtaining any necessary 106 | consents, permissions or other rights required for any use of the 107 | Work. 108 | d. Affirmer understands and acknowledges that Creative Commons is not a 109 | party to this document and has no duty or obligation with respect to 110 | this CC0 or use of the Work. 111 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | VERBOSE ?= 0 2 | 3 | .PHONY: rwoLwt 4 | rwoLwt: 5 | ocamlbuild -verbose $(VERBOSE) src/rwoLwt.native 6 | 7 | .PHONY: merlin 8 | merlin: 9 | opam config subst .merlin 10 | 11 | .PHONY: clean 12 | clean: 13 | ocamlbuild -clean 14 | 15 | .PHONY: distclean 16 | distclean: clean 17 | rm -f .merlin 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Concurrent Programming with Lwt 2 | 3 | Deokhwan Kim - Version 1.1.0, 2017-06-03 4 | 5 | Below are [Lwt](https://github.com/ocsigen/lwt) translations of [the code examples](https://github.com/realworldocaml/examples) in [Real World OCaml - Chapter 18. Concurrent Programming with Async](https://realworldocaml.org/v1/en/html/concurrent-programming-with-async.html). The section titles follow those in the book for easy cross-reference. Here is the version information of the software components that I have used: 6 | 7 | ```bash 8 | $ ocamlc -version 9 | 4.04.1 10 | $ opam show --field=version lwt 11 | 3.0.0 12 | $ opam show --field=version cohttp 13 | 0.22.0 14 | $ utop -version 15 | The universal toplevel for OCaml, version 1.19.3, compiled for OCaml version 4.04.1 16 | ``` 17 | 18 | The latest version of this document is available at https://github.com/dkim/rwo-lwt/. 19 | 20 | 21 | ## Async Basics 22 | 23 | #### OCaml utop (part 3) 24 | 25 | ```ocaml 26 | # #require "lwt.unix";; 27 | # #require "lwt.ppx";; 28 | # let file_contents filename = 29 | Lwt_io.with_file ~mode:Lwt_io.input filename 30 | (fun channel -> Lwt_io.read channel);; 31 | val file_contents : string -> string Lwt.t = 32 | ``` 33 | 34 | #### OCaml utop (part 4) 35 | 36 | ```ocaml 37 | # let contents = file_contents "test.txt";; 38 | val contents : string Lwt.t = 39 | # Lwt.state contents;; (* if test.txt exists *) 40 | - : string Lwt.state = Lwt.Return "This is only a test.\n" 41 | # Lwt.state contents;; (* if test.txt does not exist *) 42 | - : string Lwt.state = 43 | Lwt.Fail (Unix.Unix_error (Unix.ENOENT, "open", "test.txt")) 44 | ``` 45 | 46 | #### OCaml utop (part 5) 47 | 48 | ```ocaml 49 | # contents;; 50 | - : string = "This is only a test.\n" 51 | ``` 52 | 53 | #### OCaml utop (part 7) 54 | 55 | ```ocaml 56 | # Lwt.bind;; 57 | - : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t = 58 | ``` 59 | 60 | I will use [`let%lwt x = e1 in e2`](https://ocsigen.org/lwt/3.0.0/api/Ppx_lwt) in preference to `Lwt.bind e1 (fun x -> e2)` and `e1 >>= (fun x -> e2)`. The Lwt manual states that the former will produce better backtraces than the latter \[[1](#backtrace)\]: 61 | 62 | > Backtrace support 63 | > 64 | > In debug mode, the `lwt` and `let%lwt` constructs will properly propagate backtraces. 65 | > 66 | > \- https://ocsigen.org/lwt/3.0.0/manual/ 67 | 68 | > `val bind : 'a t -> ('a -> 'b t) -> 'b t` 69 | > 70 | > Note that `bind` will not propagate backtraces correctly. 71 | > 72 | > \- https://ocsigen.org/lwt/3.0.0/api/Lwt 73 | 74 | #### OCaml utop (part 8) 75 | 76 | ```ocaml 77 | # let save filename ~contents = 78 | Lwt_io.with_file ~mode:Lwt_io.output filename 79 | (fun channel -> Lwt_io.write channel contents);; 80 | val save : string -> contents:string -> unit Lwt.t = 81 | # let uppercase_file filename = 82 | let%lwt text = file_contents filename in 83 | save filename ~contents:(String.uppercase_ascii text);; 84 | val uppercase_file : string -> unit Lwt.t = 85 | # uppercase_file "test.txt";; 86 | - : unit = () 87 | # file_contents "test.txt";; 88 | - : string = "THIS IS ONLY A TEST.\n" 89 | ``` 90 | 91 | #### OCaml utop (part 10) 92 | 93 | ```ocaml 94 | # let count_lines filename = 95 | let%lwt text = file_contents filename in 96 | String.split_on_char '\n' text |> List.length;; 97 | Error: This expression has type int but an expression was expected of type 'a Lwt.t 98 | ``` 99 | 100 | #### OCaml utop (part 11) 101 | 102 | ```ocaml 103 | # Lwt.return;; 104 | - : 'a -> 'a Lwt.t = 105 | # let three = Lwt.return 3;; 106 | val three : int Lwt.t = 107 | # three;; 108 | - : int = 3 109 | ``` 110 | 111 | #### OCaml utop (part 12) 112 | 113 | ```ocaml 114 | # let count_lines filename = 115 | let%lwt text = file_contents filename in 116 | String.split_on_char '\n' text |> List.length |> Lwt.return;; 117 | val count_lines : string -> int Lwt.t = 118 | ``` 119 | 120 | #### OCaml utop (part 13) 121 | 122 | ```ocaml 123 | # Lwt.map;; 124 | - : ('a -> 'b) -> 'a Lwt.t -> 'b Lwt.t = 125 | ``` 126 | 127 | As with `Lwt.bind`, I will use the combination of the `let%lwt` construct and the `Lwt.return` function rather than `Lwt.map`.\[[1](#backtrace)\] 128 | 129 | 130 | ### Ivars and Upon 131 | 132 | #### OCalm utop (part 15) 133 | 134 | ```ocaml 135 | # let waiter, wakener = Lwt.wait ();; 136 | val waiter : '_a Lwt.t = 137 | val wakener : '_a Lwt.u = 138 | # Lwt.state waiter;; 139 | - : '_a Lwt.state = Lwt.Sleep 140 | # Lwt.wakeup wakener "Hello";; 141 | - : unit = () 142 | # Lwt.state waiter;; 143 | - : string Lwt.state = Lwt.Return "Hello" 144 | ``` 145 | 146 | #### OCaml utop (part 16) 147 | 148 | ```ocaml 149 | # module type Delayer_intf = sig 150 | type t 151 | val create : float -> t 152 | val schedule : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 153 | end;; 154 | module type Delayer_intf = 155 | sig 156 | type t 157 | val create : float -> t 158 | val schedule : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 159 | end 160 | ``` 161 | 162 | #### OCaml utop (part 17) 163 | 164 | ```ocaml 165 | # Lwt.on_success;; 166 | - : 'a Lwt.t -> ('a -> unit) -> unit = 167 | # Lwt.on_failure;; 168 | - : 'a Lwt.t -> (exn -> unit) -> unit = 169 | # Lwt.on_termination;; 170 | - : 'a Lwt.t -> (unit -> unit) -> unit = 171 | # Lwt.on_any;; 172 | - : 'a Lwt.t -> ('a -> unit) -> (exn -> unit) -> unit = 173 | ``` 174 | 175 | #### OCaml utop (part 18) 176 | 177 | ```ocaml 178 | # module Delayer : Delayer_intf = struct 179 | type t = {delay: float; jobs: (unit -> unit) Queue.t} 180 | 181 | let create delay = {delay; jobs = Queue.create ()} 182 | 183 | let schedule t thunk = 184 | let waiter, wakener = Lwt.wait () in 185 | Queue.add 186 | (fun () -> 187 | Lwt.on_any (thunk ()) (Lwt.wakeup wakener) (Lwt.wakeup_exn wakener)) 188 | t.jobs; 189 | Lwt.on_termination (Lwt_unix.sleep t.delay) (Queue.take t.jobs); 190 | waiter 191 | end;; 192 | module Delayer : Delayer_intf 193 | ``` 194 | 195 | 196 | ## Examples: An Echo Server 197 | 198 | #### OCaml 199 | 200 | ```ocaml 201 | let rec copy_blocks buffer r w = 202 | match%lwt Lwt_io.read_into r buffer 0 (Bytes.length buffer) with 203 | | 0 -> Lwt.return_unit 204 | | bytes_read -> 205 | let%lwt () = Lwt_io.write_from_exactly w buffer 0 bytes_read in 206 | copy_blocks buffer r w 207 | ``` 208 | 209 | `let%lwt () = e1 in e2` can be shortened to [`e1 >> e2`](https://ocsigen.org/lwt/3.0.0/api/Ppx_lwt#2_Sequence), but `>>` will get [deprecated](https://github.com/ocsigen/lwt/issues/387) in the near future. 210 | 211 | #### OCaml (part 1) 212 | 213 | ```ocaml 214 | let run () = 215 | ((let%lwt server = 216 | Lwt_io.establish_server (Lwt_unix.ADDR_INET (Unix.inet_addr_any, 8765)) 217 | (fun (r, w) -> 218 | let buffer = Bytes.create (16 * 1024) in 219 | copy_blocks buffer r w) 220 | in 221 | Lwt.return server) : Lwt_io.server Lwt.t) |> ignore 222 | ``` 223 | 224 | #### OCaml (part 2) 225 | 226 | ```ocaml 227 | let never_terminate = fst (Lwt.wait ()) 228 | 229 | let () = 230 | Sys.set_signal Sys.sigpipe Sys.Signal_ignore; 231 | (try Lwt_engine.set (new Lwt_engine.libev ()) 232 | with Lwt_sys.Not_available _ -> ()); 233 | run (); 234 | Lwt_main.run never_terminate 235 | ``` 236 | 237 | 238 | ### Improving the Echo Server 239 | 240 | #### OCaml 241 | 242 | ```ocaml 243 | let run uppercase port = 244 | let%lwt server = 245 | Lwt_io.establish_server (Lwt_unix.ADDR_INET (Unix.inet_addr_any, port)) 246 | (fun (r, w) -> 247 | Lwt_io.read_chars r 248 | |> (if uppercase then Lwt_stream.map Char.uppercase_ascii 249 | else fun x -> x) 250 | |> Lwt_io.write_chars w) 251 | in 252 | (server : Lwt_io.server) |> ignore; 253 | never_terminate 254 | 255 | let () = 256 | let uppercase = ref false 257 | and port = ref 8765 in 258 | let options = 259 | Arg.align [ 260 | ("-uppercase", 261 | Arg.Set uppercase, 262 | " Convert to uppercase before echoing back"); 263 | ("-port", 264 | Arg.Set_int port, 265 | "num Port to listen on (default 8765)"); 266 | ] 267 | in 268 | let usage = "Usage: " ^ Sys.executable_name ^ " [-uppercase] [-port num]" in 269 | Arg.parse 270 | options 271 | (fun arg -> raise (Arg.Bad (Printf.sprintf "invalid argument -- '%s'" arg))) 272 | usage; 273 | 274 | Sys.set_signal Sys.sigpipe Sys.Signal_ignore; 275 | (try Lwt_engine.set (new Lwt_engine.libev ()) 276 | with Lwt_sys.Not_available _ -> ()); 277 | Lwt_main.run (run !uppercase !port) 278 | ``` 279 | 280 | [The Lwt manual](https://ocsigen.org/lwt/3.0.0/api/Lwt_stream) states that the `Lwt_stream` module may get deprecated or redesigned, and suggests considering alternatives, such as Simon Cruanes's [lwt-pipe](https://github.com/c-cube/lwt-pipe). Below is an equivalent version of the code above that uses lwt-pipe. 281 | 282 | ```bash 283 | $ opam pin add -k git lwt-pipe https://github.com/c-cube/lwt-pipe.git 284 | $ opam install lwt-pipe 285 | ``` 286 | 287 | ```ocaml 288 | let run uppercase port = 289 | let%lwt server = 290 | Lwt_io.establish_server (Lwt_unix.ADDR_INET (Unix.inet_addr_any, port)) 291 | (fun (r, w) -> 292 | let reader = Lwt_pipe.IO.read r in 293 | let writer = 294 | Lwt_pipe.IO.write w 295 | |> (if uppercase then Lwt_pipe.Writer.map ~f:String.uppercase_ascii 296 | else fun x -> x) 297 | in 298 | Lwt_pipe.connect ~ownership:`OutOwnsIn reader writer; 299 | Lwt_pipe.wait writer) 300 | in 301 | (server : Lwt_io.server) |> ignore; 302 | never_terminate 303 | ``` 304 | 305 | 306 | ## Example: Searching Definitions with DuckDuckGo 307 | 308 | ```bash 309 | $ opam install tls cohttp # Or opam install lwt_ssl cohttp 310 | ``` 311 | 312 | 313 | ### URI Handling 314 | 315 | #### OCaml 316 | 317 | ```ocaml 318 | let query_uri = 319 | let base_uri = Uri.of_string "https://api.duckduckgo.com/?format=json" in 320 | (fun query -> Uri.add_query_param base_uri ("q", [query])) 321 | ``` 322 | 323 | 324 | ### Parsing JSON Strings 325 | 326 | #### OCaml (part 1) 327 | 328 | ```ocaml 329 | let get_definition_from_json json = 330 | match Yojson.Safe.from_string json with 331 | | `Assoc kv_list -> 332 | let find key = 333 | match List.assoc key kv_list with 334 | | exception Not_found -> None 335 | | `String "" -> None 336 | | s -> Some (Yojson.Safe.to_string s) 337 | in 338 | begin match find "Abstract" with 339 | | Some _ as x -> x 340 | | None -> find "Definition" 341 | end 342 | | _ -> None 343 | ``` 344 | 345 | 346 | ### Executing an HTTP Client Query 347 | 348 | #### OCaml (part 2) 349 | 350 | ```ocaml 351 | let get_definition word = 352 | let%lwt _resp, body = Cohttp_lwt_unix.Client.get (query_uri word) in 353 | let%lwt body' = Cohttp_lwt_body.to_string body in 354 | Lwt.return (word, get_definition_from_json body') 355 | ``` 356 | 357 | #### OCaml utop (part 28) 358 | 359 | ```ocaml 360 | # #require "cohttp.lwt";; 361 | # Cohttp_lwt_unix.Client.get;; 362 | - : ?ctx:Cohttp_lwt_unix.Client.ctx -> ?headers:Cohttp.Header.t -> Uri.t -> (Cohttp_lwt.Response.t * Cohttp_lwt_body.t) Lwt.t = 363 | ``` 364 | 365 | #### OCaml (part 3) 366 | 367 | ```ocaml 368 | let print_result (word, definition) = 369 | Lwt_io.printf "%s\n%s\n\n%s\n\n" 370 | word 371 | (String.init (String.length word) (fun _ -> '-')) 372 | (match definition with 373 | | None -> "No definition found" 374 | | Some def -> 375 | Format.pp_set_margin Format.str_formatter 70; 376 | Format.pp_print_text Format.str_formatter def; 377 | Format.flush_str_formatter ()) 378 | ``` 379 | 380 | #### OCaml (part 4) 381 | 382 | ```ocaml 383 | let search_and_print words = 384 | let%lwt results = Lwt_list.map_p get_definition words in 385 | Lwt_list.iter_s print_result results 386 | ``` 387 | 388 | #### OCaml utop (part 29) 389 | 390 | ```ocaml 391 | # Lwt_list.map_p;; 392 | - : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t = 393 | ``` 394 | 395 | #### OCaml (part 1) 396 | 397 | ```ocaml 398 | let search_and_print words = 399 | Lwt_list.iter_p 400 | (fun word -> 401 | let%lwt result = get_definition word in 402 | print_result result) 403 | words 404 | ``` 405 | 406 | #### OCaml utop (part 30) 407 | 408 | ```ocaml 409 | # Lwt_list.iter_p;; 410 | - : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t = 411 | ``` 412 | 413 | #### OCaml (part 5) 414 | 415 | ```ocaml 416 | let () = 417 | let words = ref [] in 418 | let usage = "Usage: " ^ Sys.executable_name ^ " [word ...]" in 419 | Arg.parse [] (fun w -> words := w :: !words) usage; 420 | words := List.rev !words; 421 | 422 | (try Lwt_engine.set (new Lwt_engine.libev ()) 423 | with Lwt_sys.Not_available _ -> ()); 424 | Lwt_main.run (search_and_print !words) 425 | ``` 426 | 427 | 428 | ## Exception Handling 429 | 430 | #### OCaml utop (part 31) 431 | 432 | ```ocaml 433 | # let maybe_raise = 434 | let should_fail = ref false in 435 | fun () -> 436 | let will_fail = !should_fail in 437 | should_fail := not will_fail; 438 | let%lwt () = Lwt_unix.sleep 0.5 in 439 | if will_fail then [%lwt raise Exit] else Lwt.return_unit;; 440 | val maybe_raise : unit -> unit Lwt.t = 441 | # maybe_raise ();; 442 | - : unit = () 443 | # maybe_raise ();; 444 | Exception: Pervasives.Exit. 445 | Raised at file "src/core/lwt.ml", line 805, characters 22-23 446 | Called from file "src/unix/lwt_main.ml", line 34, characters 8-18 447 | Called from file "toplevel/toploop.ml", line 180, characters 17-56 448 | ``` 449 | 450 | Note that I wrote `[%lwt raise Exit]` rather than `Lwt.fail Exit`. The Lwt manual states that the former will produce better backtraces than the latter \[[1](#backtrace)\]: 451 | 452 | > It allows to encode the old `raise_lwt ` as `[%lwt raise ]`, ... 453 | > 454 | > \- https://ocsigen.org/lwt/3.0.0/api/Ppx_lwt 455 | 456 | > `raise_lwt exn` 457 | > 458 | > which is the same as Lwt.fail exn but with backtrace support. 459 | > 460 | > \- https://ocsigen.org/lwt/3.0.0/manual/ 461 | 462 | #### OCaml utop (part 32) 463 | 464 | ```ocaml 465 | # let handle_error () = 466 | try 467 | let%lwt () = maybe_raise () in 468 | Lwt.return "success" 469 | with _ -> Lwt.return "failure";; 470 | val handle_error : unit -> string Lwt.t = 471 | # handle_error ();; 472 | - : string = "success" 473 | # handle_error ();; 474 | Exception: Pervasives.Exit. 475 | Raised at file "src/core/lwt.ml", line 805, characters 22-23 476 | Called from file "src/unix/lwt_main.ml", line 34, characters 8-18 477 | Called from file "toplevel/toploop.ml", line 180, characters 17-56 478 | ``` 479 | 480 | #### OCaml utop (part 33) 481 | 482 | ```ocaml 483 | # let handle_error () = 484 | try%lwt 485 | let%lwt () = maybe_raise () in 486 | Lwt.return "success" 487 | with _ -> Lwt.return "failure";; 488 | val handle_error : unit -> string Lwt.t = 489 | # handle_error ();; 490 | - : string = "success" 491 | # handle_error ();; 492 | - : string = "failure" 493 | ``` 494 | 495 | Although the manual does not state it explicitly, `try%lwt ... with ...` appears to be intended to provide a better backtrace than `Lwt.catch`.\[[1](#backtrace)\] For instance, the `handle_error` function is expanded to: 496 | 497 | ```ocaml 498 | let handle_error () = 499 | Lwt.backtrace_catch (fun exn -> try raise exn with | exn -> exn) 500 | (fun () -> 501 | Lwt.backtrace_bind (fun exn -> try raise exn with | exn -> exn) 502 | (maybe_raise ()) 503 | (fun () -> Lwt.return "success")) 504 | (function | _ -> Lwt.return "failure") 505 | ``` 506 | 507 | 508 | ### Monitors 509 | 510 | Lwt does not have a concept corresponding to a monitor. 511 | 512 | 513 | ### Example: Handling Exceptions with DuckDuckGo 514 | 515 | #### OCaml (part 1) 516 | 517 | ```ocaml 518 | let query_uri ~server query = 519 | let base_uri = 520 | Uri.of_string (String.concat "" ["https://"; server; "/?format=json"]) 521 | in 522 | Uri.add_query_param base_uri ("q", [query]) 523 | ``` 524 | 525 | #### OCaml (part 1) 526 | 527 | ```ocaml 528 | let get_definition ~server word = 529 | try%lwt 530 | let%lwt _resp, body = Cohttp_lwt_unix.Client.get (query_uri ~server word) in 531 | let%lwt body' = Cohttp_lwt_body.to_string body in 532 | Lwt.return (word, Ok (get_definition_from_json body')) 533 | with _ -> Lwt.return (word, Error "Unexpected failure") 534 | ``` 535 | 536 | #### OCaml (part 2) 537 | 538 | ```ocaml 539 | let print_result (word, definition) = 540 | Lwt_io.printf "%s\n%s\n\n%s\n\n" 541 | word 542 | (String.init (String.length word) (fun _ -> '-')) 543 | (match definition with 544 | | Error s -> "DuckDuckGo query failed: " ^ s 545 | | Ok None -> "No definition found" 546 | | Ok (Some def) -> 547 | Format.pp_set_margin Format.str_formatter 70; 548 | Format.pp_print_text Format.str_formatter def; 549 | Format.flush_str_formatter ()) 550 | ``` 551 | 552 | ```ocaml 553 | let search_and_print ~servers words = 554 | let servers = Array.of_list servers in 555 | let%lwt results = 556 | Lwt_list.mapi_p 557 | (fun i word -> 558 | let server = servers.(i mod Array.length servers) in 559 | get_definition ~server word) 560 | words 561 | in 562 | Lwt_list.iter_s print_result results 563 | 564 | let () = 565 | let servers = ref ["api.duckduckgo.com"] 566 | and words = ref [] in 567 | let options = 568 | Arg.align [ 569 | ("-servers", 570 | Arg.String (fun s -> servers := String.split_on_char ',' s), 571 | "s1,...,sn Specify servers to connect to"); 572 | ] 573 | in 574 | let usage = "Usage: " ^ Sys.executable_name ^ " [-servers s1,...,sn] [word ...]" in 575 | Arg.parse options (fun w -> words := w :: !words) usage; 576 | words := List.rev !words; 577 | 578 | (try Lwt_engine.set (new Lwt_engine.libev ()) 579 | with Lwt_sys.Not_available _ -> ()); 580 | Lwt_main.run (search_and_print ~servers:!servers !words) 581 | ``` 582 | 583 | 584 | ## Timeouts, Cancellation, and Choices 585 | 586 | #### OCaml utop (part 39) 587 | 588 | ```ocaml 589 | # let both x y = 590 | let%lwt x' = x 591 | and y' = y in 592 | Lwt.return (x', y');; 593 | val both : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t = 594 | # let string_and_float = 595 | both 596 | (let%lwt () = Lwt_unix.sleep 0.5 in 597 | Lwt.return "A") 598 | (let%lwt () = Lwt_unix.sleep 0.25 in 599 | Lwt.return 32.33);; 600 | val string_and_float : (string * float) Lwt.t = 601 | # string_and_float;; 602 | - : string * float = ("A", 32.33) 603 | ``` 604 | 605 | #### OCaml utop (part 40) 606 | 607 | ```ocaml 608 | # Lwt.choose [ 609 | (let%lwt () = Lwt_unix.sleep 0.5 in 610 | Lwt.return "half a second"); 611 | (let%lwt () = Lwt_unix.sleep 10. in 612 | Lwt.return "ten seconds"); 613 | ];; 614 | - : string = "half a second" 615 | ``` 616 | 617 | #### OCaml utop (part 41) 618 | 619 | ```ocaml 620 | # Lwt.pick;; 621 | - : 'a Lwt.t list -> 'a Lwt.t = 622 | ``` 623 | 624 | #### OCaml (parts 1 and 2) 625 | 626 | ```ocaml 627 | let get_definition ~server word = 628 | try%lwt 629 | let%lwt _resp, body = Cohttp_lwt_unix.Client.get (query_uri ~server word) in 630 | let%lwt body' = Cohttp_lwt_body.to_string body in 631 | Lwt.return (word, Ok (get_definition_from_json body')) 632 | with exn -> Lwt.return (word, Error exn) 633 | 634 | let get_definition_with_timeout ~server timeout word = 635 | Lwt.pick [ 636 | (let%lwt () = Lwt_unix.sleep timeout in 637 | Lwt.return (word, Error "Timed out")); 638 | (let%lwt word, result = get_definition ~server word in 639 | let result' = 640 | match result with 641 | | Ok _ as x -> x 642 | | Error _ -> Error "Unexpected failure" 643 | in 644 | Lwt.return (word, result')); 645 | ] 646 | 647 | let search_and_print ~servers timeout words = 648 | let servers = Array.of_list servers in 649 | let%lwt results = 650 | Lwt_list.mapi_p 651 | (fun i word -> 652 | let server = servers.(i mod Array.length servers) in 653 | get_definition_with_timeout ~server timeout word) 654 | words 655 | in 656 | Lwt_list.iter_s print_result results 657 | 658 | let () = 659 | let servers = ref ["api.duckduckgo.com"] 660 | and timeout = ref 5.0 661 | and words = ref [] in 662 | let options = 663 | Arg.align [ 664 | ("-servers", 665 | Arg.String (fun s -> servers := String.split_on_char ',' s), 666 | "s1,...,sn Specify servers to connect to"); 667 | ("-timeout", 668 | Arg.Set_float timeout, 669 | "secs Abandon queries that take longer than this time"); 670 | ] 671 | in 672 | let usage = "Usage: " ^ Sys.executable_name ^ " [-servers s1,...,sn] [-timeout secs] [word ...]" in 673 | Arg.parse options (fun w -> words := w :: !words) usage; 674 | words := List.rev !words; 675 | 676 | (try Lwt_engine.set (new Lwt_engine.libev ()) 677 | with Lwt_sys.Not_available _ -> ()); 678 | Lwt_main.run (search_and_print ~servers:!servers !timeout !words) 679 | ``` 680 | 681 | `Cohttp_lwt_unix.Client.get` does not take the labeled `~interrupt` argument unlike `Cohttp_async.Client.get`. However, the thread that `Cohttp_lwt_unix.Client.get` returns is [cancelable](https://ocsigen.org/lwt/3.0.0/api/Lwt#2_Cancelablethreads) and can be naturally used with `Lwt.pick`. 682 | 683 | 684 | ## Working with System Threads 685 | 686 | #### OCaml utop (part 42) 687 | 688 | ```ocaml 689 | # let rec range ?(acc = []) start stop = 690 | if start >= stop then List.rev acc 691 | else range ~acc:(start :: acc) (start + 1) stop;; 692 | val range : ?acc:int list -> int -> int -> int list = 693 | # let def = Lwt_preemptive.detach (fun () -> range 1 10) ();; 694 | val def : int list Lwt.t = 695 | # def;; 696 | - : int list = [1; 2; 3; 4; 5; 6; 7; 8; 9] 697 | ``` 698 | 699 | #### OCaml utop (part 43) 700 | 701 | ```ocaml 702 | # let rec every ?(stop = never_terminate) span (f : unit -> unit Lwt.t) : unit Lwt.t = 703 | if Lwt.is_sleeping stop then 704 | let%lwt () = f () in 705 | let%lwt () = Lwt.pick [Lwt_unix.sleep span; Lwt.protected stop] in 706 | every ~stop span f 707 | else Lwt.return_unit;; 708 | val every : ?stop:unit Lwt.t -> float -> (unit -> unit Lwt.t) -> unit Lwt.t = 709 | # let log_delays thunk = 710 | let start = Unix.gettimeofday () in 711 | let print_time () = 712 | let diff = Unix.gettimeofday () -. start in 713 | Lwt_io.printf "%f, " diff 714 | in 715 | let d = thunk () in 716 | let%lwt () = every 0.1 ~stop:d print_time in 717 | let%lwt () = d in 718 | let%lwt () = print_time () in 719 | Lwt_io.print "\n";; 720 | val log_delays : (unit -> unit Lwt.t) -> unit Lwt.t = 721 | ``` 722 | 723 | #### OCaml utop 724 | 725 | ```ocaml 726 | # log_delays (fun () -> Lwt_unix.sleep 0.5);; 727 | 0.000006, 0.101822, 0.201969, 0.306260, 0.411472, 0.505199, 728 | ``` 729 | 730 | #### OCalm utop 731 | 732 | ```ocaml 733 | # let busy_loop () = 734 | let x = ref None in 735 | for i = 1 to 500_000_000 do x := Some i done;; 736 | val busy_loop : unit -> unit = 737 | # log_delays (fun () -> Lwt.return (busy_loop ()));; 738 | 6.890156, 739 | - : unit = () 740 | ``` 741 | 742 | #### OCaml utop 743 | 744 | ```ocaml 745 | # log_delays (fun () -> Lwt_preemptive.detach busy_loop ());; 746 | 0.000033, 0.158420, 0.264950, 0.370093, 0.475191, 0.585002, 0.685192, 0.786619, 747 | 0.894304, 0.997954, 1.103635, 1.213693, 1.316856, 1.426929, 1.583395, 1.686367, 748 | 1.786517, 1.894609, 1.998529, 2.103606, 2.208725, 2.363542, 2.571035, 2.680959, 749 | 2.945979, 3.056136, 3.161278, 3.430440, 3.531169, 3.742274, 3.847282, 3.951309, 750 | 4.114742, 4.215642, 4.315771, 4.421812, 4.530823, 4.741970, 4.848297, 5.008062, 751 | 5.114670, 5.430785, 5.535985, 5.644637, 5.802193, 6.015593, 6.226784, 6.330944, 752 | 6.546150, 6.703104, 6.806751, 6.912780, 6.992610, 753 | - : unit = () 754 | ``` 755 | 756 | #### OCaml utop 757 | 758 | ```ocaml 759 | # let noallc_busy_loop () = 760 | for _i = 0 to 500_000_000 do () done;; 761 | val noallc_busy_loop : unit -> unit = 762 | # log_delays (fun () -> Lwt_preemptive.detach noallc_busy_loop ());; 763 | 0.000010, 0.137578, 0.240112, 0.345218, 0.450686, 0.555763, 0.660168, 0.766587, 764 | 0.872521, 0.977615, 1.078819, 1.184021, 1.289587, 1.394786, 1.552426, 1.657563, 765 | 1.764036, 1.922921, 2.078783, 2.287458, 2.501932, 2.663988, 2.768908, 2.978174, 766 | 3.188819, 3.297128, 3.460475, 3.568800, 3.670217, 3.803641, 3.803730, 767 | - : unit = () 768 | ``` 769 | 770 | 771 | --- 772 | 773 | 1. It has been [reported](https://github.com/ocsigen/lwt/issues/171) that the backtrace mechanism appears not to work well with the recent versions of OCaml. For the present, the choice between the Ppx constructs and the regular functions (or operators) may be more a matter of style. 774 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # Compile or link multithreaded programs, in combination with the system 2 | # "threads" library. 3 | true: thread 4 | 5 | true: package(cohttp.lwt) 6 | true: package(lwt.ppx), package(lwt.preemptive) 7 | true: package(yojson) 8 | 9 | # Save typedtree in .cmt. 10 | <**/*.ml>: bin_annot 11 | # # Save debugging information. 12 | true: debug 13 | # Check principality of type inference 14 | true: principal 15 | # Make strings immutable. 16 | true: safe_string 17 | # Reject invalid formats accepted by legacy implementations. 18 | true: strict_formats 19 | # Left-hand part of a sequence must have type unit. 20 | true: strict_sequence 21 | # 4 Fragile pattern matching: matching that will remain complete even if 22 | # additional constructors are added to one of the variant types matched. 23 | # 42 Disambiguated constructor or label name (compatibility warning). 24 | true: warn(+A-4-42) 25 | 26 | # Enable colors in compiler messages (especially warnings and errors). 27 | true: color(always) 28 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin 2 | 3 | let () = dispatch (function 4 | | Before_options -> Options.use_ocamlfind := true 5 | | _ -> ()) 6 | -------------------------------------------------------------------------------- /src/rwoLwt.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Concurrent Programming with Lwt 3 | * 4 | * Written in 2017 by Deokhwan Kim 5 | * 6 | * To the extent possible under law, the author(s) have dedicated all copyright 7 | * and related and neighboring rights to this software to the public domain 8 | * worldwide. This software is distributed without any warranty. 9 | * 10 | * You should have received a copy of the CC0 Public Domain Dedication along 11 | * with this software. If not, see 12 | * . 13 | *) 14 | 15 | 16 | (* Async Basics *) 17 | 18 | let file_contents (filename : Lwt_io.file_name) : string Lwt.t = 19 | Lwt_io.with_file ~mode:Lwt_io.input filename 20 | (fun channel -> Lwt_io.read channel) 21 | 22 | let save (filename : Lwt_io.file_name) ~(contents : string) : unit Lwt.t = 23 | Lwt_io.with_file ~mode:Lwt_io.output filename 24 | (fun channel -> Lwt_io.write channel contents) 25 | 26 | let uppercase_file (filename : Lwt_io.file_name) : unit Lwt.t = 27 | let%lwt text = file_contents filename in 28 | save filename ~contents:(String.uppercase_ascii text) 29 | 30 | let count_lines (filename : Lwt_io.file_name) : int Lwt.t = 31 | let%lwt text = file_contents filename in 32 | String.split_on_char '\n' text |> List.length |> Lwt.return 33 | 34 | 35 | (* Ivars and Upon *) 36 | 37 | module type Delayer_intf = sig 38 | type t 39 | val create : float -> t 40 | val schedule : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 41 | end 42 | 43 | module Delayer : Delayer_intf = struct 44 | type t = {delay: float; jobs: (unit -> unit) Queue.t} 45 | 46 | let create (delay : float) : t = {delay; jobs = Queue.create ()} 47 | 48 | let schedule (t : t) (thunk : unit -> 'a Lwt.t) : 'a Lwt.t = 49 | let waiter, wakener = Lwt.wait () in 50 | Queue.add 51 | (fun () -> 52 | Lwt.on_any (thunk ()) (Lwt.wakeup wakener) (Lwt.wakeup_exn wakener)) 53 | t.jobs; 54 | Lwt.on_termination (Lwt_unix.sleep t.delay) (Queue.take t.jobs); 55 | waiter 56 | end 57 | 58 | 59 | (* Example: An Echo Server *) 60 | 61 | let rec copy_blocks (buffer : bytes) (r : Lwt_io.input_channel) (w : Lwt_io.output_channel) : unit Lwt.t = 62 | match%lwt Lwt_io.read_into r buffer 0 (Bytes.length buffer) with 63 | | 0 -> Lwt.return_unit 64 | | bytes_read -> 65 | let%lwt () = Lwt_io.write_from_exactly w buffer 0 bytes_read in 66 | copy_blocks buffer r w 67 | 68 | (* 69 | let run () : unit = 70 | ((let%lwt server = 71 | Lwt_io.establish_server (Lwt_unix.ADDR_INET (Unix.inet_addr_any, 8765)) 72 | (fun (r, w) -> 73 | let buffer = Bytes.create (16 * 1024) in 74 | copy_blocks buffer r w) 75 | in 76 | Lwt.return server) : Lwt_io.server Lwt.t) |> ignore 77 | *) 78 | 79 | let never_terminate : 'a . 'a Lwt.t = fst (Lwt.wait ()) 80 | 81 | (* 82 | let () = 83 | Sys.set_signal Sys.sigpipe Sys.Signal_ignore; 84 | (try Lwt_engine.set (new Lwt_engine.libev ()) 85 | with Lwt_sys.Not_available _ -> ()); 86 | run (); 87 | Lwt_main.run never_terminate 88 | *) 89 | 90 | 91 | (* Improving the Echo Server *) 92 | 93 | let run (uppercase : bool) (port : int) : unit Lwt.t = 94 | let%lwt server = 95 | Lwt_io.establish_server (Lwt_unix.ADDR_INET (Unix.inet_addr_any, port)) 96 | (fun (r, w) -> 97 | Lwt_io.read_chars r 98 | |> (if uppercase then Lwt_stream.map Char.uppercase_ascii 99 | else fun x -> x) 100 | |> Lwt_io.write_chars w) 101 | in 102 | (server : Lwt_io.server) |> ignore; 103 | never_terminate 104 | 105 | (* 106 | let run (uppercase : bool) (port : int) : unit Lwt.t = 107 | let%lwt server = 108 | Lwt_io.establish_server (Lwt_unix.ADDR_INET (Unix.inet_addr_any, port)) 109 | (fun (r, w) -> 110 | let reader = Lwt_pipe.IO.read r in 111 | let writer = 112 | Lwt_pipe.IO.write w 113 | |> (if uppercase then Lwt_pipe.Writer.map ~f:String.uppercase_ascii 114 | else fun x -> x) 115 | in 116 | Lwt_pipe.connect ~ownership:`OutOwnsIn reader writer; 117 | Lwt_pipe.wait writer) 118 | in 119 | (server : Lwt_io.server) |> ignore; 120 | never_terminate 121 | *) 122 | 123 | (* 124 | let () = 125 | let uppercase = ref false 126 | and port = ref 8765 in 127 | let options = 128 | Arg.align [ 129 | ("-uppercase", 130 | Arg.Set uppercase, 131 | " Convert to uppercase before echoing back"); 132 | ("-port", 133 | Arg.Set_int port, 134 | "num Port to listen on (default 8765)"); 135 | ] 136 | in 137 | let usage = "Usage: " ^ Sys.executable_name ^ " [-uppercase] [-port num]" in 138 | Arg.parse 139 | options 140 | (fun arg -> raise (Arg.Bad (Printf.sprintf "invalid argument -- '%s'" arg))) 141 | usage; 142 | 143 | Sys.set_signal Sys.sigpipe Sys.Signal_ignore; 144 | (try Lwt_engine.set (new Lwt_engine.libev ()) 145 | with Lwt_sys.Not_available _ -> ()); 146 | Lwt_main.run (run !uppercase !port) 147 | *) 148 | 149 | 150 | (* Example: Searching Definitions with DuckDuckGo *) 151 | 152 | (* URI Handling *) 153 | 154 | (* 155 | let query_uri : string -> Uri.t = 156 | let base_uri = Uri.of_string "https://api.duckduckgo.com/?format=json" in 157 | (fun query -> Uri.add_query_param base_uri ("q", [query])) 158 | *) 159 | 160 | 161 | (* Parsing JSON Strings *) 162 | 163 | let get_definition_from_json (json : string) : string option = 164 | match Yojson.Safe.from_string json with 165 | | `Assoc kv_list -> 166 | let find key = 167 | match List.assoc key kv_list with 168 | | exception Not_found -> None 169 | | `String "" -> None 170 | | s -> Some (Yojson.Safe.to_string s) 171 | in 172 | begin match find "Abstract" with 173 | | Some _ as x -> x 174 | | None -> find "Definition" 175 | end 176 | | _ -> None 177 | 178 | 179 | (* Executing an HTTP Client Query *) 180 | 181 | (* 182 | let get_definition (word : string) : (string * string option) Lwt.t = 183 | let%lwt _resp, body = Cohttp_lwt_unix.Client.get (query_uri word) in 184 | let%lwt body' = Cohttp_lwt_body.to_string body in 185 | Lwt.return (word, get_definition_from_json body') 186 | 187 | let print_result ((word, definition) : string * string option) : unit Lwt.t = 188 | Lwt_io.printf "%s\n%s\n\n%s\n\n" 189 | word 190 | (String.init (String.length word) (fun _ -> '-')) 191 | (match definition with 192 | | None -> "No definition found" 193 | | Some def -> 194 | Format.pp_set_margin Format.str_formatter 70; 195 | Format.pp_print_text Format.str_formatter def; 196 | Format.flush_str_formatter ()) 197 | 198 | let search_and_print (words : string list) : unit Lwt.t = 199 | let%lwt results = Lwt_list.map_p get_definition words in 200 | Lwt_list.iter_s print_result results 201 | 202 | (* 203 | let search_and_print (words : string list) : unit Lwt.t = 204 | Lwt_list.iter_p 205 | (fun word -> 206 | let%lwt result = get_definition word in 207 | print_result result) 208 | words 209 | *) 210 | 211 | let () = 212 | let words = ref [] in 213 | let usage = "Usage: " ^ Sys.executable_name ^ " [word ...]" in 214 | Arg.parse [] (fun w -> words := w :: !words) usage; 215 | words := List.rev !words; 216 | 217 | (try Lwt_engine.set (new Lwt_engine.libev ()) 218 | with Lwt_sys.Not_available _ -> ()); 219 | Lwt_main.run (search_and_print !words) 220 | *) 221 | 222 | 223 | (* Example: Handling Exceptions with DuckDuckGo *) 224 | 225 | let query_uri ~(server : string) (query : string) : Uri.t = 226 | let base_uri = 227 | Uri.of_string (String.concat "" ["https://"; server; "/?format=json"]) 228 | in 229 | Uri.add_query_param base_uri ("q", [query]) 230 | 231 | (* 232 | let get_definition ~(server : string) (word : string) : (string * (string option, string) result) Lwt.t = 233 | try%lwt 234 | let%lwt _resp, body = Cohttp_lwt_unix.Client.get (query_uri ~server word) in 235 | let%lwt body' = Cohttp_lwt_body.to_string body in 236 | Lwt.return (word, Ok (get_definition_from_json body')) 237 | with _ -> Lwt.return (word, Error "Unexpected failure") 238 | *) 239 | 240 | let print_result ((word, definition) : string * (string option, string) result) : unit Lwt.t = 241 | Lwt_io.printf "%s\n%s\n\n%s\n\n" 242 | word 243 | (String.init (String.length word) (fun _ -> '-')) 244 | (match definition with 245 | | Error s -> "DuckDuckGo query failed: " ^ s 246 | | Ok None -> "No definition found" 247 | | Ok (Some def) -> 248 | Format.pp_set_margin Format.str_formatter 70; 249 | Format.pp_print_text Format.str_formatter def; 250 | Format.flush_str_formatter ()) 251 | 252 | (* 253 | let search_and_print ~(servers : string list) (words : string list) : unit Lwt.t = 254 | let servers = Array.of_list servers in 255 | let%lwt results = 256 | Lwt_list.mapi_p 257 | (fun i word -> 258 | let server = servers.(i mod Array.length servers) in 259 | get_definition ~server word) 260 | words 261 | in 262 | Lwt_list.iter_s print_result results 263 | 264 | let () = 265 | let servers = ref ["api.duckduckgo.com"] 266 | and words = ref [] in 267 | let options = 268 | Arg.align [ 269 | ("-servers", 270 | Arg.String (fun s -> servers := String.split_on_char ',' s), 271 | "s1,...,sn Specify servers to connect to"); 272 | ] 273 | in 274 | let usage = "Usage: " ^ Sys.executable_name ^ " [-servers s1,...,sn] [word ...]" in 275 | Arg.parse options (fun w -> words := w :: !words) usage; 276 | words := List.rev !words; 277 | 278 | (try Lwt_engine.set (new Lwt_engine.libev ()) 279 | with Lwt_sys.Not_available _ -> ()); 280 | Lwt_main.run (search_and_print ~servers:!servers !words) 281 | *) 282 | 283 | 284 | (* Timeouts, Cancellation, and Choices *) 285 | 286 | let get_definition ~(server : string) (word : string) : (string * (string option, exn) result) Lwt.t = 287 | try%lwt 288 | let%lwt _resp, body = Cohttp_lwt_unix.Client.get (query_uri ~server word) in 289 | let%lwt body' = Cohttp_lwt_body.to_string body in 290 | Lwt.return (word, Ok (get_definition_from_json body')) 291 | with exn -> Lwt.return (word, Error exn) 292 | 293 | let get_definition_with_timeout ~(server : string) (timeout : float) (word : string) : (string * (string option, string) result) Lwt.t = 294 | Lwt.pick [ 295 | (let%lwt () = Lwt_unix.sleep timeout in 296 | Lwt.return (word, Error "Timed out")); 297 | (let%lwt word, result = get_definition ~server word in 298 | let result' = 299 | match result with 300 | | Ok _ as x -> x 301 | | Error _ -> Error "Unexpected failure" 302 | in 303 | Lwt.return (word, result')); 304 | ] 305 | 306 | let search_and_print ~(servers : string list) (timeout : float) (words : string list) : unit Lwt.t = 307 | let servers = Array.of_list servers in 308 | let%lwt results = 309 | Lwt_list.mapi_p 310 | (fun i word -> 311 | let server = servers.(i mod Array.length servers) in 312 | get_definition_with_timeout ~server timeout word) 313 | words 314 | in 315 | Lwt_list.iter_s print_result results 316 | 317 | (* 318 | let () = 319 | let servers = ref ["api.duckduckgo.com"] 320 | and timeout = ref 5.0 321 | and words = ref [] in 322 | let options = 323 | Arg.align [ 324 | ("-servers", 325 | Arg.String (fun s -> servers := String.split_on_char ',' s), 326 | "s1,...,sn Specify servers to connect to"); 327 | ("-timeout", 328 | Arg.Set_float timeout, 329 | "secs Abandon queries that take longer than this time"); 330 | ] 331 | in 332 | let usage = "Usage: " ^ Sys.executable_name ^ " [-servers s1,...,sn] [-timeout secs] [word ...]" in 333 | Arg.parse options (fun w -> words := w :: !words) usage; 334 | words := List.rev !words; 335 | 336 | (try Lwt_engine.set (new Lwt_engine.libev ()) 337 | with Lwt_sys.Not_available _ -> ()); 338 | Lwt_main.run (search_and_print ~servers:!servers !timeout !words) 339 | *) 340 | 341 | 342 | (* Working with System Threads *) 343 | 344 | let rec every ?(stop : unit Lwt.t = never_terminate) (span : float) (f : unit -> unit Lwt.t) : unit Lwt.t = 345 | if Lwt.is_sleeping stop then 346 | let%lwt () = f () in 347 | let%lwt () = Lwt.pick [Lwt_unix.sleep span; Lwt.protected stop] in 348 | every ~stop span f 349 | else Lwt.return_unit 350 | 351 | let log_delays (thunk : unit -> unit Lwt.t) : unit Lwt.t = 352 | let start = Unix.gettimeofday () in 353 | let print_time () = 354 | let diff = Unix.gettimeofday () -. start in 355 | Lwt_io.printf "%f, " diff 356 | in 357 | let d = thunk () in 358 | let%lwt () = every 0.1 ~stop:d print_time in 359 | let%lwt () = d in 360 | let%lwt () = print_time () in 361 | Lwt_io.print "\n" 362 | 363 | let noalloc_busy_loop () : unit = 364 | for _i = 0 to 10_000_000_000 do () done 365 | 366 | let () = 367 | Lwt_main.run 368 | @@ log_delays (fun () -> Lwt_preemptive.detach noalloc_busy_loop ()) 369 | -------------------------------------------------------------------------------- /utop.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | exec utop -init "$(dirname $0)/.utopinit" "$@" 3 | --------------------------------------------------------------------------------