don't wrap file io

Author: yasunariw

lib/api_local.ml

@@ -10,14 +10,11 @@ let slack_cache_dir = Filename.concat cwd "slack-api-cache"
 
 (** return the file with a function f applied unless the file is empty;
  empty file:this is needed to simulate 404 returns from github *)
-let with_cache_file url f =
-  match get_local_file url with
-  | Error e ->
-    let err_msg = sprintf "error while getting local file: %s\ncached for url: %s" e url in
-    Printf.printf "%s\n" err_msg;
-    Lwt.return_error err_msg
-  | Ok "" -> Lwt.return_error "empty file"
-  | Ok file -> Lwt.return_ok (f file)
+let with_cache_file cache_filepath f =
+  match Std.input_file cache_filepath with
+  | "" -> Lwt.return_error "empty file"
+  | file -> Lwt.return_ok (f file)
+  | exception exn -> Exn.fail ~exn "failed to get local cache file : %s" cache_filepath
 
 let rec clean_forward_slashes str =
   let cont, ns = ExtLib.String.replace ~str ~sub:"/" ~by:"_" in

lib/common.ml

@@ -37,7 +37,14 @@ end
 
 open Devkit
 
-let fmt_error fmt = Printf.ksprintf (fun s -> Error s) fmt
+let fmt_error ?exn fmt =
+  Printf.ksprintf
+    (fun s ->
+      match exn with
+      | Some exn -> Error (s ^ " :  exn " ^ Exn.str exn)
+      | None -> Error s
+    )
+    fmt
 
 let first_line s =
   match String.split_on_char '\n' s with
@@ -55,11 +62,5 @@ let http_request ?headers ?body meth path =
   | `Ok s -> Lwt.return @@ Ok s
   | `Error e -> Lwt.return @@ Error e
 
-let get_local_file path = try Ok (Std.input_file path) with exn -> fmt_error "%s" (Exn.to_string exn)
-
-let write_to_local_file ~data path =
-  try Ok (Devkit.Files.save_as path (fun oc -> Printf.fprintf oc "%s" data))
-  with exn -> fmt_error "%s" (Exn.to_string exn)
-
 let sign_string_sha256 ~key ~basestring =
   Cstruct.of_string basestring |> Nocrypto.Hash.SHA256.hmac ~key:(Cstruct.of_string key) |> Hex.of_cstruct |> Hex.show

lib/context.ml

@@ -75,33 +75,28 @@ let is_pipeline_allowed ctx repo_url ~pipeline =
 
 let refresh_secrets ctx =
   let path = ctx.secrets_filepath in
-  match get_local_file path with
-  | Error e -> fmt_error "error while getting local file: %s\nfailed to get secrets from file %s" e path
-  | Ok file ->
-    let secrets = Config_j.secrets_of_string file in
-    begin
-      match secrets.slack_access_token, secrets.slack_hooks with
-      | None, [] -> fmt_error "either slack_access_token or slack_hooks must be defined in file '%s'" path
-      | _ ->
-      match secrets.repos with
-      | [] -> fmt_error "at least one repository url must be specified in the 'repos' list in file %S" path
-      | _ :: _ ->
-        ctx.secrets <- Some secrets;
-        Ok ctx
-    end
+  match Config_j.secrets_of_string (Std.input_file path) with
+  | exception exn -> fmt_error ~exn "failed to read secrets from file %s" path
+  | secrets ->
+  match secrets.slack_access_token, secrets.slack_hooks with
+  | None, [] -> fmt_error "either slack_access_token or slack_hooks must be defined in file %s" path
+  | _ ->
+  match secrets.repos with
+  | [] -> fmt_error "at least one repository url must be specified in the 'repos' list in file %s" path
+  | _ :: _ ->
+    ctx.secrets <- Some secrets;
+    Ok ctx
 
 let refresh_state ctx =
   match ctx.state_filepath with
   | None -> Ok ctx
   | Some path ->
     if Sys.file_exists path then begin
       log#info "loading saved state from file %s" path;
-      match get_local_file path with
-      | Error e -> fmt_error "error while getting local file: %s\nfailed to get state from file %s" e path
-      | Ok file ->
-        (* todo: extract state related parts to state.ml *)
-        let state = { State.state = State_j.state_of_string file } in
-        Ok { ctx with state }
+      (* todo: extract state related parts to state.ml *)
+      match State_j.state_of_string (Std.input_file path) with
+      | exception exn -> fmt_error ~exn "failed to read state from file %s" path
+      | state -> Ok { ctx with state = { State.state } }
     end
     else Ok ctx
 

lib/state.ml

@@ -36,6 +36,7 @@ let get_bot_user_id { state; _ } = state.State_t.bot_user_id
 
 let save { state; _ } path =
   let data = State_j.string_of_state state |> Yojson.Basic.from_string |> Yojson.Basic.pretty_to_string in
-  match write_to_local_file ~data path with
-  | Ok () -> Ok ()
-  | Error e -> fmt_error "error while writing to local file %s: %s\nfailed to save state" path e
+  try
+    Files.save_as path (fun oc -> output_string oc data);
+    Ok ()
+  with exn -> fmt_error ~exn "failed to save state to file %s" path

src/monorobot.ml

@@ -36,9 +36,9 @@ let check_gh_action file json config secrets state =
   | None ->
     log#error "aborting because payload %s is not named properly, named should be KIND.NAME_OF_PAYLOAD.json" file
   | Some kind ->
-  match Common.get_local_file file with
-  | Error e -> log#error "%s" e
-  | Ok body ->
+  match Std.input_file file with
+  | exception exn -> log#error ~exn "failed to read file %s" file
+  | body ->
     let headers = [ "x-github-event", kind ] in
     let ctx = Context.make ~config_filename:config ~secrets_filepath:secrets ?state_filepath:state () in
     ( match Context.refresh_secrets ctx with

test/test.ml

@@ -41,39 +41,37 @@ let process_gh_payload ~(secrets : Config_t.secrets) ~config (kind, path, state_
     let ctx = Context.make () in
     ctx.secrets <- Some secrets;
     let (_ : State_t.repo_state) = State.find_or_add_repo ctx.state repo.url in
-    match state_path with
-    | None ->
-      Context.set_repo_config ctx repo.url config;
-      Lwt.return ctx
-    | Some state_path ->
-    match Common.get_local_file state_path with
-    | Error e ->
-      log#error "failed to read %s: %s" state_path e;
-      Lwt.return ctx
-    | Ok file ->
-      let repo_state = State_j.repo_state_of_string file in
-      State.set_repo_state ctx.state repo.url repo_state;
-      Context.set_repo_config ctx repo.url config;
-      Lwt.return ctx
+    let () =
+      match state_path with
+      | None -> Context.set_repo_config ctx repo.url config
+      | Some state_path ->
+      match State_j.repo_state_of_string (Std.input_file state_path) with
+      | repo_state ->
+        State.set_repo_state ctx.state repo.url repo_state;
+        Context.set_repo_config ctx repo.url config
+      | exception exn -> log#error ~exn "failed to load state from file %s" state_path
+    in
+    ctx
   in
   Printf.printf "===== file %s =====\n" path;
   let headers = [ "x-github-event", kind ] in
-  match Common.get_local_file path with
-  | Error e -> Lwt.return @@ log#error "failed to read %s: %s" path e
-  | Ok event ->
-    let%lwt ctx = make_test_context event in
-    let%lwt _ctx = Action_local.process_github_notification ctx headers event in
+  match Std.input_file path with
+  | event ->
+    let ctx = make_test_context event in
+    Action_local.process_github_notification ctx headers event
+  | exception exn ->
+    log#error ~exn "failed to read file %s" path;
     Lwt.return_unit
 
 let process_slack_event ~(secrets : Config_t.secrets) path =
   let ctx = Context.make () in
   ctx.secrets <- Some secrets;
   State.set_bot_user_id ctx.state "bot_user";
   Printf.printf "===== file %s =====\n" path;
-  match Common.get_local_file path with
-  | Error e -> Lwt.return @@ log#error "failed to read %s: %s" path e
-  | Ok body ->
-  match Slack_j.event_notification_of_string body with
+  match Slack_j.event_notification_of_string (Std.input_file path) with
+  | exception exn ->
+    log#error ~exn "failed to read event notification from file %s" path;
+    Lwt.return_unit
   | Url_verification _ -> Lwt.return ()
   | Event_callback notification ->
   match notification.event with