From 787c746632043dc2a6a49c34463156578791e3db Mon Sep 17 00:00:00 2001
From: ygrek <ygrek@autistici.org>
Date: Fri, 28 Mar 2014 01:12:59 +0800
Subject: [PATCH] examples/test_lwt: showcase Lwt.cancel support

---
 examples/Makefile.in | 10 ++++++----
 examples/test_lwt.ml | 34 ++++++++++++++++++++++------------
 2 files changed, 28 insertions(+), 16 deletions(-)

diff --git a/examples/Makefile.in b/examples/Makefile.in
index da2db6a..f0c4beb 100644
--- a/examples/Makefile.in
+++ b/examples/Makefile.in
@@ -30,17 +30,19 @@ endif
 
 all:	$(TARGETS)
 
+FINDLIB_LWT_FLAGS=-linkpkg -syntax camlp4o -package lwt.unix,lwt.syntax
+
 test_lwt: ../curl.cma ../curl_lwt.cmo test_lwt.ml
-	$(FINDLIB) c -custom -linkpkg -package lwt.unix $(LFLAGS) $^ -o $@
+	$(FINDLIB) c -custom $(FINDLIB_LWT_FLAGS) $(LFLAGS) $^ -o $@
 
 test_lwt.opt: ../curl.cmxa ../curl_lwt.cmx test_lwt.ml
-	$(FINDLIB) opt -linkpkg -package lwt.unix $(LFLAGS) $^ -o $@
+	$(FINDLIB) opt $(FINDLIB_LWT_FLAGS) $(LFLAGS) $^ -o $@
 
 test_lwt_unit: ../curl.cma ../curl_lwt.cmo test_lwt_unit.ml
-	$(FINDLIB) c -custom -linkpkg -package lwt.unix $(LFLAGS) $^ -o $@
+	$(FINDLIB) c -custom $(FINDLIB_LWT_FLAGS) $(LFLAGS) $^ -o $@
 
 test_lwt_unit.opt: ../curl.cmxa ../curl_lwt.cmx test_lwt_unit.ml
-	$(FINDLIB) opt -linkpkg -package lwt.unix $(LFLAGS) $^ -o $@
+	$(FINDLIB) opt $(FINDLIB_LWT_FLAGS) $(LFLAGS) $^ -o $@
 
 %: %.cmo ../curl.cma
 		$(OCBYTE) -custom $(LFLAGS) $(OCURLLIB) $< -o $@
diff --git a/examples/test_lwt.ml b/examples/test_lwt.ml
index 0db7185..acfb563 100644
--- a/examples/test_lwt.ml
+++ b/examples/test_lwt.ml
@@ -5,6 +5,8 @@ open Printf
 let (@@) f x = f x
 let (|>) x f = f x
 
+let printfn fmt = ksprintf print_endline fmt
+
 let curl_setup_simple h =
   let open Curl in
   set_useragent h "Curl_lwt";
@@ -18,7 +20,7 @@ let curl_setup_simple h =
 let log_curl h code =
   let open Curl in
   let url = get_effectiveurl h in
-  print_endline @@ sprintf "%3d %.2f %g URL: %s (%s)%s"
+  printfn "%3d %.2f %g URL: %s (%s)%s"
     (get_httpcode h)
     (get_totaltime h)
     (get_sizedownload h)
@@ -35,14 +37,19 @@ let get url =
   let h = Curl.init () in
   Curl.set_url h url;
   curl_setup_simple h;
-(*   lwt (code,body) = download h in *)
-  Lwt.bind (download h) @@ fun (code,_body) ->
-  log_curl h code;
-  (* do something with body *)
-  Curl.cleanup h;
-  Lwt.return ()
-
-let run () =
+  try_lwt (* e.g. Canceled *)
+    lwt (code,_body) = download h in
+    log_curl h code;
+    Lwt.return ()
+    (* do something with body *)
+  with exn ->
+    printfn "EXN %s URL: %s" (Printexc.to_string exn) url;
+    Lwt.fail exn
+  finally
+    Curl.cleanup h;
+    Lwt.return ()
+
+let urls =
   [
     "www.google.com";
     "ya.ru";
@@ -51,8 +58,11 @@ let run () =
     "www.mozart-oz.org";
     "forge.ocamlcore.org";
   ]
-  |> List.map get
-  |> Lwt.join
 
 let () =
-  Lwt_main.run @@ run ()
+  printfn "Launch %d transfers" (List.length urls);
+  let tasks = List.map get urls in
+  Lwt_main.run @@ Lwt.pick [
+    Lwt_unix.sleep 0.75 >> Lwt.choose tasks >> Lwt.return (print_endline "Cancel remaining transfers");
+    Lwt.join tasks
+  ]
-- 
2.11.4.GIT