Merge pull request #222 from MisterDA/open_in_bin

Use open_in_bin instead of open_in for Windows compatibility

capnp-rpc/capTP.ml

@@ -753,6 +753,7 @@ module Make (EP : Message_types.ENDPOINT) = struct
       exported_caps = Hashtbl.create 30;
       disconnected = None;
     }
+  [@@ocaml.warning "-16"]       (* Too late to change the API now. *)
 
   let with_qid qid t =
     Logs.Tag.add Debug.qid_tag (QuestionId.uint32 qid) t.tags

examples/test_api.capnp

@@ -35,3 +35,7 @@ interface File {
 interface Store {
   createFile @0 () -> (file :File);
 }
+
+struct Simple {
+  text @0 :Text;
+}

test-lwt/test_lwt.ml

@@ -628,6 +628,22 @@ let test_store switch =
   Alcotest.(check string) "Read file" "Hello" data;
   Lwt.return_unit
 
+let test_file_store _switch =
+  Lwt_io.with_temp_dir ~prefix:"capnp-tests-" @@ fun tmpdir ->
+  let module S = Capnp_rpc_unix.File_store in
+  let s = S.create tmpdir in
+  Alcotest.(check (option reject)) "Missing file" None @@ S.load s ~digest:"missing";
+  let module Builder = Examples.Api.Builder.Simple in
+  let module Reader = Examples.Api.Reader.Simple in
+  let data =
+    let b = Builder.init_root () in
+    Builder.text_set b "Test";
+    Builder.to_reader b
+  in
+  S.save s ~digest:"!/.." data;
+  Alcotest.(check (option string)) "Restored" (Some "Test") @@ Option.map Reader.text_get (S.load s ~digest:"!/..");
+  Lwt.return_unit
+
 let run name fn = Alcotest_lwt.test_case_sync name `Quick fn
 
 let rpc_tests = [
@@ -655,6 +671,7 @@ let rpc_tests = [
   run_lwt "Parallel fails"      test_parallel_fails;
   run_lwt "Crossed calls"       test_crossed_calls;
   run_lwt "Store"               test_store;
+  run_lwt "File store"          test_file_store;
 ]
 
 let () =

unix/capnp_rpc_unix.ml

@@ -30,7 +30,7 @@ let parse_uri s =
 module Cap_file = struct
   let load_uri path =
     try
-      let ch = open_in path in
+      let ch = open_in_bin path in
       let len = in_channel_length ch in
       let data = really_input_string ch len in
       close_in ch;

unix/file_store.ml

@@ -20,12 +20,13 @@ let segments_of_reader = function
 let save t ~digest data =
   let path = path_of_digest t digest in
   let tmp_path = path ^ ".new" in
-  let ch = open_out tmp_path in
-  let segments = segments_of_reader data in
-  segments |> List.iter (fun {Message.segment; bytes_consumed} ->
-      output ch segment 0 bytes_consumed
+  let ch = open_out_bin tmp_path in
+  Fun.protect ~finally:(fun () -> close_out ch) (fun () ->
+    let segments = segments_of_reader data in
+    segments |> List.iter (fun {Message.segment; bytes_consumed} ->
+        output ch segment 0 bytes_consumed
+      );
     );
-  close_out ch;
   Unix.rename tmp_path path
 
 let remove t ~digest =
@@ -35,11 +36,15 @@ let remove t ~digest =
 let load t ~digest =
   let path = path_of_digest t digest in
   if Sys.file_exists path then (
-    let ch = open_in path in
-    let len = in_channel_length ch in
-    let segment = Bytes.create len in
-    really_input ch segment 0 len;
-    close_in ch;
+    let ch = open_in_bin path in
+    let segment =
+      Fun.protect ~finally:(fun () -> close_in ch) (fun () ->
+          let len = in_channel_length ch in
+          let segment = Bytes.create len in
+          really_input ch segment 0 len;
+          segment
+        )
+    in
     let msg = Message.of_storage [segment] in
     let reader = ReaderOps.get_root_struct (Message.readonly msg) in
     Some reader

unix/vat_config.ml

@@ -45,15 +45,14 @@ let secret_key_file =
 
 let read_whole_file path =
   let ic = open_in_bin path in
+  Fun.protect ~finally:(fun () -> close_in ic) @@ fun () ->
   let len = in_channel_length ic in
-  let data = really_input_string ic len in
-  close_in ic;
-  data
+  really_input_string ic len
 
 let write_whole_file path data =
   let oc = open_out_gen [Open_wronly; Open_creat; Open_excl; Open_binary] 0o600 path in
-  output_string oc data;
-  close_out oc
+  Fun.protect ~finally:(fun () -> close_out oc) @@ fun () ->
+  output_string oc data
 
 let init_secret_key_file key_file =
   if Sys.file_exists key_file then (