From 7689977b758a1855bfd710553cbc702973263ce6 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Apr 2015 21:11:33 -0400 Subject: [PATCH 1/4] Remove lwt syntax extension from lwt/** --- lwt/cohttp_lwt.ml | 27 ++++++++++---------- lwt/cohttp_lwt_body.ml | 16 ++++++------ lwt/cohttp_lwt_unix.ml | 28 ++++++++++----------- lwt/cohttp_lwt_unix_io.ml | 50 +++++++++++++++++++++----------------- lwt/cohttp_lwt_unix_net.ml | 13 +++------- 5 files changed, 67 insertions(+), 67 deletions(-) diff --git a/lwt/cohttp_lwt.ml b/lwt/cohttp_lwt.ml index 7ecb24f655..f45a4b7445 100644 --- a/lwt/cohttp_lwt.ml +++ b/lwt/cohttp_lwt.ml @@ -167,7 +167,7 @@ module Make_client let call ?(ctx=default_ctx) ?headers ?(body=`Empty) ?chunked meth uri = let headers = match headers with None -> Header.init () | Some h -> h in - lwt (conn,ic,oc) = Net.connect_uri ~ctx uri in + Net.connect_uri ~ctx uri >>= fun (conn, ic, oc) -> let closefn () = Net.close ic oc in let chunked = match chunked with None -> is_meth_chunked meth | Some v -> v in let sent = match chunked with @@ -178,7 +178,7 @@ module Make_client | false -> (* If chunked is not allowed, then obtain the body length and insert header *) - lwt (body_length, buf) = Cohttp_lwt_body.length body in + Cohttp_lwt_body.length body >>= fun (body_length, buf) -> let req = Request.make_for_client ~headers ~chunked ~body_length meth uri in @@ -208,14 +208,14 @@ module Make_client post ?ctx ~chunked:false ~headers ~body uri let callv ?(ctx=default_ctx) uri reqs = - lwt (conn, ic, oc) = Net.connect_uri ~ctx uri in + Net.connect_uri ~ctx uri >>= fun (conn, ic, oc) -> (* Serialise the requests out to the wire *) - lwt meths = Lwt_stream.fold_s (fun (req,body) meths -> + Lwt_stream.fold_s (fun (req,body) meths -> Request.write (fun writer -> Cohttp_lwt_body.write_body (Request.write_body writer) body ) req oc >>= fun () -> return ((Request.meth req)::meths) - ) reqs [] in + ) reqs [] >>= fun meths -> (* Read the responses. For each response, ensure that the previous response has consumed the body before continuing to the next response because HTTP/1.1-pipelining cannot be interleaved. *) @@ -224,7 +224,7 @@ module Make_client let last_body = ref None in let resps = Lwt_stream.from (fun () -> let closefn () = Lwt_mutex.unlock read_m in - match_lwt Lwt_stream.get meth_stream with + Lwt_stream.get meth_stream >>= function | None -> return_none | Some meth -> begin match !last_body with None -> return_unit | Some body -> @@ -400,21 +400,22 @@ module Make_server(IO:IO) (* Map the requests onto a response stream to serialise out *) let res_stream = Lwt_stream.map_s (fun (req, body) -> - try_lwt - spec.callback (io_id,conn_id) req body - with exn -> - respond_error ~body:(Printexc.to_string exn) () - finally Cohttp_lwt_body.drain_body body + Lwt.finalize + (fun () -> + Lwt.catch + (fun () -> spec.callback (io_id, conn_id) req body) + (fun exn -> respond_error ~body:(Printexc.to_string exn) ())) + (fun () -> Cohttp_lwt_body.drain_body body) ) req_stream in (* Clean up resources when the response stream terminates and call * the user callback *) Lwt_stream.on_terminate res_stream conn_closed; (* Transmit the responses *) - for_lwt (res,body) in res_stream do + res_stream |> Lwt_stream.iter_s (fun (res,body) -> let flush = Response.flush res in Response.write ~flush (fun writer -> Cohttp_lwt_body.write_body (Response.write_body writer) body ) res oc - done + ) in daemon_callback end diff --git a/lwt/cohttp_lwt_body.ml b/lwt/cohttp_lwt_body.ml index 41af744b6d..2a7e9da979 100644 --- a/lwt/cohttp_lwt_body.ml +++ b/lwt/cohttp_lwt_body.ml @@ -31,16 +31,14 @@ let create_stream fn arg = let fin = ref false in Lwt_stream.from (fun () -> match !fin with - |true -> return_none - |false -> begin - match_lwt fn arg with - |Transfer.Done -> - return_none - |Transfer.Final_chunk c -> + | true -> return_none + | false -> begin + fn arg >>= function + | Transfer.Done -> return_none + | Transfer.Final_chunk c -> fin := true; return (Some c); - |Transfer.Chunk c -> - return (Some c) + | Transfer.Chunk c -> return (Some c) end ) @@ -92,7 +90,7 @@ let length (body:t) : (int64 * t) Lwt.t = match body with |#Body.t as body -> return (Body.length body, body) |`Stream s -> - lwt buf = to_string body in + to_string body >>= fun buf -> let len = Int64.of_int (String.length buf) in return (len, `String buf) diff --git a/lwt/cohttp_lwt_unix.ml b/lwt/cohttp_lwt_unix.ml index a9aff7bf9e..b4ab9f106c 100644 --- a/lwt/cohttp_lwt_unix.ml +++ b/lwt/cohttp_lwt_unix.ml @@ -53,24 +53,24 @@ module Server = struct exception Isnt_a_file let respond_file ?headers ~fname () = - try_lwt + Lwt.catch (fun () -> (* Check this isnt a directory first *) (fname |> Lwt_unix.stat >>= fun s -> if Unix.(s.st_kind <> S_REG) then fail Isnt_a_file else return_unit) >>= fun () -> let buffer_size = 16384 in - lwt ic = Lwt_io.open_file ~buffer_size ~mode:Lwt_io.input fname in - lwt len = Lwt_io.length ic in + Lwt_io.open_file ~buffer_size ~mode:Lwt_io.input fname >>= fun ic -> + Lwt_io.length ic >>= fun len -> let encoding = Cohttp.Transfer.Fixed len in let stream = Lwt_stream.from (fun () -> - try_lwt + Lwt.catch (fun () -> Lwt_io.read ~count:buffer_size ic >|= function | "" -> None - | buf -> Some buf - with exn -> - Lwt_log.ign_debug ~exn ("Error resolving file " ^ fname); - return_none + | buf -> Some buf) + (fun exn -> + Lwt_log.ign_debug ~exn ("Error resolving file " ^ fname); + return_none) ) in Lwt_stream.on_terminate stream (fun () -> ignore_result (Lwt_io.close ic)); @@ -79,12 +79,12 @@ module Server = struct let headers = Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type in let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in return (res, body) - with - | Unix.Unix_error(Unix.ENOENT,_,_) | Isnt_a_file -> - respond_not_found () - | exn -> - let body = Printexc.to_string exn in - respond_error ~status:`Internal_server_error ~body () + ) (function + | Unix.Unix_error(Unix.ENOENT,_,_) | Isnt_a_file -> + respond_not_found () + | exn -> + let body = Printexc.to_string exn in + respond_error ~status:`Internal_server_error ~body ()) let create ?timeout ?stop ?(ctx=Cohttp_lwt_unix_net.default_ctx) ?(mode=`TCP (`Port 8080)) spec = Conduit_lwt_unix.serve ?timeout ?stop ~ctx:ctx.Cohttp_lwt_unix_net.ctx ~mode diff --git a/lwt/cohttp_lwt_unix_io.ml b/lwt/cohttp_lwt_unix_io.ml index 711ec40624..45b70a45e0 100644 --- a/lwt/cohttp_lwt_unix_io.ml +++ b/lwt/cohttp_lwt_unix_io.ml @@ -30,36 +30,42 @@ let iter fn x = Lwt_list.iter_s fn x let read_line ic = if !CD.debug_active then - (match_lwt Lwt_io.read_line_opt ic with - | None -> CD.debug_print "<<< EOF\n"; Lwt.return_none - | Some l as x -> CD.debug_print "<<< %s\n" l; Lwt.return x) + Lwt_io.read_line_opt ic >>= function + | None -> CD.debug_print "<<< EOF\n"; Lwt.return_none + | Some l as x -> CD.debug_print "<<< %s\n" l; Lwt.return x else Lwt_io.read_line_opt ic let read ic count = - let count = min count Sys.max_string_length in - if !CD.debug_active then - (lwt buf = - try_lwt Lwt_io.read ~count ic - with End_of_file -> return "" in - CD.debug_print "<<<[%d] %s" count buf; - return buf) - else - (try_lwt Lwt_io.read ~count ic - with End_of_file -> return "") + let try_read () = + Lwt.catch (fun () -> Lwt_io.read ~count ic) + (function + | End_of_file -> return "" + | x -> Lwt.fail x) in + let count = min count Sys.max_string_length in + if !CD.debug_active then + try_read () + >>= fun buf -> + CD.debug_print "<<<[%d] %s" count buf; + return buf + else + try_read () let read_exactly ic buf off len = + let try_read () = + Lwt.try_bind (fun () -> Lwt_io.read_into_exactly ic buf off len) + (fun () -> return true) + (function + | End_of_file -> return false + | x -> Lwt.fail x) in if !CD.debug_active then - (lwt rd = - try_lwt Lwt_io.read_into_exactly ic buf off len >>= fun () -> return true - with End_of_file -> return false in - (match rd with - |true -> CD.debug_print "<<< %S" (String.sub buf off len) - |false -> CD.debug_print "<<< \n"); - return rd) + try_read () >>= fun rd -> + (match rd with + | true -> CD.debug_print "<<< %S" (String.sub buf off len) + | false -> CD.debug_print "<<< \n"); + return rd else - (try_lwt Lwt_io.read_into_exactly ic buf off len >>= fun () -> return true - with End_of_file -> return false) + try_read () let read_exactly ic len = let buf = Bytes.create len in diff --git a/lwt/cohttp_lwt_unix_net.ml b/lwt/cohttp_lwt_unix_net.ml index 546d3e3fc8..299c931b26 100644 --- a/lwt/cohttp_lwt_unix_net.ml +++ b/lwt/cohttp_lwt_unix_net.ml @@ -43,15 +43,10 @@ let connect_uri ~ctx uri = >>= fun client -> Conduit_lwt_unix.connect ~ctx:ctx.ctx client -let close_in ic = - ignore_result (try_lwt Lwt_io.close ic with _ -> return_unit) +let close c = Lwt.catch (fun () -> Lwt_io.close c) (fun _ -> return_unit) -let close_out oc = - ignore_result (try_lwt Lwt_io.close oc with _ -> return_unit) +let close_in ic = ignore_result (close ic) -let close' ic oc = - try_lwt Lwt_io.close oc with _ -> return_unit >>= fun () -> - try_lwt Lwt_io.close ic with _ -> return_unit +let close_out oc = ignore_result (close oc) -let close ic oc = - ignore_result (close' ic oc) +let close ic oc = ignore_result (close ic >>= fun () -> close oc) From c5771cc05ab3986a5252fb0c14e322a23642cd1b Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Apr 2015 21:11:57 -0400 Subject: [PATCH 2/4] Move lwt.syntax extension to xhr client --- _oasis | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/_oasis b/_oasis index 84aa3bd0ef..0a6e55b7f2 100644 --- a/_oasis +++ b/_oasis @@ -65,7 +65,7 @@ Library cohttp_lwt Path: lwt Findlibname: lwt-core FindlibParent: cohttp - BuildDepends: lwt, uri, cohttp, lwt.syntax + BuildDepends: lwt, uri, cohttp XMETARequires: lwt, uri, cohttp Modules: Cohttp_lwt_body, Cohttp_lwt, String_io_lwt @@ -85,7 +85,7 @@ Library cohttp_lwt_xhr Path: js Findlibname: js FindlibParent: cohttp - BuildDepends: cohttp.lwt-core, js_of_ocaml, js_of_ocaml.syntax + BuildDepends: cohttp.lwt-core, js_of_ocaml, js_of_ocaml.syntax, lwt.syntax XMETARequires: cohttp.lwt-core, js_of_ocaml Modules: Cohttp_lwt_xhr From 2c587ab5fc50a8ebfb68fdf9f97120bb21c9b868 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 26 Apr 2015 11:34:35 -0400 Subject: [PATCH 3/4] Use Lwt.return_{true|false} --- lwt/cohttp_lwt_unix_io.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lwt/cohttp_lwt_unix_io.ml b/lwt/cohttp_lwt_unix_io.ml index 45b70a45e0..58696dc7c9 100644 --- a/lwt/cohttp_lwt_unix_io.ml +++ b/lwt/cohttp_lwt_unix_io.ml @@ -54,9 +54,9 @@ let read ic count = let read_exactly ic buf off len = let try_read () = Lwt.try_bind (fun () -> Lwt_io.read_into_exactly ic buf off len) - (fun () -> return true) + (fun () -> Lwt.return_true) (function - | End_of_file -> return false + | End_of_file -> Lwt.return_false | x -> Lwt.fail x) in if !CD.debug_active then try_read () >>= fun rd -> From 9369dcfbceac133033d6569391400fa999fa5c42 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 26 Apr 2015 11:34:44 -0400 Subject: [PATCH 4/4] regenerate oasis --- _tags | 18 ++---------------- setup.ml | 10 +++++----- 2 files changed, 7 insertions(+), 21 deletions(-) diff --git a/_tags b/_tags index f326ded3fd..31f352b63c 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 0ad4df17498f27d1dda960ea7d20a378) +# DO NOT EDIT (digest: 5fa3841c8dc3c29fb17f88da786b068b) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -92,7 +92,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_oUnit @@ -113,7 +112,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_oUnit @@ -198,7 +196,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_oUnit @@ -221,7 +218,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -242,7 +238,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -263,7 +258,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -284,7 +278,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -305,7 +298,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -326,7 +318,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -468,7 +459,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -490,7 +480,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -512,7 +501,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -532,7 +520,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_re.emacs @@ -606,6 +593,7 @@ true: annot, bin_annot "lib_test/test_xhr.byte": use_cohttp_lwt_xhr : pkg_js_of_ocaml : pkg_js_of_ocaml.syntax +: pkg_lwt.syntax : use_cohttp_lwt_xhr "lib_test/test_xhr.byte": custom # Executable async-receive-post @@ -649,7 +637,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_oUnit @@ -670,7 +657,6 @@ true: annot, bin_annot : pkg_fieldslib : pkg_fieldslib.syntax : pkg_lwt -: pkg_lwt.syntax : pkg_lwt.unix : pkg_magic-mime : pkg_oUnit diff --git a/setup.ml b/setup.ml index 6be320f628..f6e49079ad 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.5 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 7840ff0fea77d9f849727cb97b6cdb3e) *) +(* DO NOT EDIT (digest: 3d9f836b216dd90fb02c6d846a389c65) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -7228,8 +7228,7 @@ let setup_t = [ FindlibPackage ("lwt", None); FindlibPackage ("uri", None); - InternalLibrary "cohttp"; - FindlibPackage ("lwt.syntax", None) + InternalLibrary "cohttp" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7330,7 +7329,8 @@ let setup_t = [ InternalLibrary "cohttp_lwt"; FindlibPackage ("js_of_ocaml", None); - FindlibPackage ("js_of_ocaml.syntax", None) + FindlibPackage ("js_of_ocaml.syntax", None); + FindlibPackage ("lwt.syntax", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -8686,7 +8686,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\148ëj{\137:Ó`>\\\007\023k±\006ó"; + oasis_digest = Some "\137Þ7å\017ôöwb\029ãXì\023å®"; oasis_exec = None; oasis_setup_args = []; setup_update = false