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_encoding h CURL_ENCODING_ANY
  19
  20 let log_curl h code =
  21   let open Curl in
  22   let url = get_effectiveurl h in
  23   printfn "%3d %.2f %g URL: %s (%s)%s"
  24     (get_httpcode h)
  25     (get_totaltime h)
  26     (get_sizedownload h)
  27     (if get_httpcode h / 100 = 3 then sprintf "%s -> %s" url (get_redirecturl h) else url)
  28     (get_contenttype h)
  29     (match code with CURLE_OK -> "" | _ -> sprintf " %s (%d)" (strerror code) (errno code))
  30
  31 let download h =
  32   let b = Buffer.create 16 in
  33   Curl.set_writefunction h (fun s -> Buffer.add_string b s; String.length s);
  34   Lwt.bind (Curl_lwt.perform h) (fun code -> Lwt.return (code, Buffer.contents b))
  35
  36 let get url =
  37   let h = Curl.init () in
  38   Curl.set_url h url;
  39   curl_setup_simple h;
  40   begin try%lwt (* e.g. Canceled *)
  41     let%lwt (code,_body) = download h in
  42     log_curl h code;
  43     Lwt.return ()
  44     (* do something with body *)
  45   with exn ->
  46     printfn "EXN %s URL: %s" (Printexc.to_string exn) url;
  47     Lwt.fail exn
  48   end[%lwt.finally Curl.cleanup h; Lwt.return ()]
  49
  50 let urls =
  51   [
  52     "www.google.com";
  53     "ya.ru";
  54     "www.forth.org.ru";
  55     "caml.inria.fr";
  56     "www.mozart-oz.org";
  57     "forge.ocamlcore.org";
  58   ]
  59
  60 let () =
  61   printfn "Launch %d transfers" (List.length urls);
  62   let tasks = List.map get urls in
  63   Lwt_main.run @@ Lwt.pick [
  64     Lwt_unix.sleep 0.75 >> Lwt.choose tasks >> Lwt.return (print_endline "Cancel remaining transfers");
  65     Lwt.join tasks
  66   ]