examples/test_lwt.ml

   1 (** curl lwt example *)
   2
   3 open Printf
   4
   5 let (@@) f x = f x
   6 let (|>) x f = f x
   7
   8 let printfn fmt = ksprintf print_endline fmt
   9
  10 let curl_setup_simple h =
  11   let open Curl in
  12   set_useragent h "Curl_lwt";
  13   set_nosignal h true;
  14   set_connecttimeout h 5;
  15   set_timeout h 10;
  16   set_followlocation h false;
  17   set_maxredirs h 1;
  18   set_ipresolve h IPRESOLVE_V4;
  19   set_encoding h CURL_ENCODING_ANY
  20
  21 let log_curl h code =
  22   let open Curl in
  23   let url = get_effectiveurl h in
  24   printfn "%3d %.2f %5.0fB URL: %s (%s)%s"
  25     (get_httpcode h)
  26     (get_totaltime h)
  27     (get_sizedownload h)
  28     (if get_httpcode h / 100 = 3 then sprintf "%s -> %s" url (get_redirecturl h) else url)
  29     (get_contenttype h)
  30     (match code with CURLE_OK -> "" | _ -> sprintf " %s (%d)" (strerror code) (errno code))
  31
  32 let download h =
  33   let b = Buffer.create 16 in
  34   Curl.set_writefunction h (fun s -> Buffer.add_string b s; String.length s);
  35   Lwt.bind (Curl_lwt.perform h) (fun code -> Lwt.return (code, Buffer.contents b))
  36
  37 let get url =
  38   let h = Curl.init () in
  39   Curl.set_url h url;
  40   curl_setup_simple h;
  41   begin try%lwt (* e.g. Canceled *)
  42     let%lwt (code,_body) = download h in
  43     log_curl h code;
  44     Lwt.return ()
  45     (* do something with body *)
  46   with exn ->
  47     printfn "EXN %s URL: %s" (Printexc.to_string exn) url;
  48     Lwt.fail exn
  49   end[%lwt.finally Curl.cleanup h; Lwt.return ()]
  50
  51 let urls =
  52   [
  53     "http://www.forth.org.ru";
  54     "http://caml.inria.fr";
  55     "https://www.rust-lang.org";
  56     "https://ocaml.org";
  57     "http://elm-lang.org";
  58     "http://www.red-lang.org";
  59   ]
  60
  61 let wait_one tasks =
  62   let%lwt () = Lwt_unix.sleep 0.5 in
  63   let%lwt () = Lwt.choose tasks in
  64   print_endline "Cancel remaining transfers";
  65   Lwt.return ()
  66
  67 let () =
  68   printfn "Launch %d transfers" (List.length urls);
  69   let tasks = List.map get urls in
  70   Lwt_main.run @@ Lwt.pick [
  71     wait_one tasks;
  72     Lwt.join tasks
  73   ]