From ff770cebf1b85cb44e2ae709bcfa1e9f7eecad57 Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 9 Sep 2024 15:20:13 +0200 Subject: [PATCH] irmin-cli: fix uncaught exception --- CHANGES.md | 2 + src/irmin-cli/cli.ml | 504 +++++++++++++++++++++---------------------- 2 files changed, 253 insertions(+), 253 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index d899c3185eb..3a08bbb66c7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -11,6 +11,8 @@ - **irmin** - Fix CI, update dependencies (#2321, @smorimoto) - Update documentation (#2323, #2324, #2325, @christinerose) +- **irmin-cli** + - Fix uncaught exception (#2326, @art-w) ### Removed diff --git a/src/irmin-cli/cli.ml b/src/irmin-cli/cli.ml index ceadcf70896..10091bb1495 100644 --- a/src/irmin-cli/cli.ml +++ b/src/irmin-cli/cli.ml @@ -108,7 +108,7 @@ let print_exc exc = | e -> Fmt.epr "ERROR: %a\n%!" Fmt.exn e); exit 1 -let run t = Lwt_main.run (Lwt.catch (fun () -> t) print_exc) +let run fn = Lwt_main.run (Lwt.catch fn print_exc) let mk (fn : 'a) : 'a Term.t = Term.(const (fun () -> fn) $ setup_log) (* INIT *) @@ -118,7 +118,7 @@ let init = doc = "Initialize a store."; man = []; term = - (let init (S (_, _store, _)) = run Lwt.return_unit in + (let init (S (_, _store, _)) = run @@ fun () -> Lwt.return_unit in Term.(mk init $ store ())); } @@ -143,15 +143,15 @@ let get = term = (let get (S (impl, store, _)) path = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - S.find t (key S.Path.t path) >>= function - | None -> - print ""; - exit 1 - | Some v -> - print "%a" (Irmin.Type.pp S.Contents.t) v; - Lwt.return_unit) + run @@ fun () -> + let* t = store in + S.find t (key S.Path.t path) >>= function + | None -> + print ""; + exit 1 + | Some v -> + print "%a" (Irmin.Type.pp S.Contents.t) v; + Lwt.return_unit in Term.(mk get $ store () $ path)); } @@ -170,17 +170,17 @@ let list = | Empty -> S.Path.empty | Path str -> key S.Path.t str in - run - (let* t = store in - let* paths = S.list t path in - let pp_step = Irmin.Type.pp S.Path.step_t in - let pp ppf (s, k) = - match S.Tree.destruct k with - | `Contents _ -> Fmt.pf ppf "FILE %a" pp_step s - | `Node _ -> Fmt.pf ppf "DIR %a" pp_step s - in - List.iter (print "%a" pp) paths; - Lwt.return_unit) + run @@ fun () -> + let* t = store in + let* paths = S.list t path in + let pp_step = Irmin.Type.pp S.Path.step_t in + let pp ppf (s, k) = + match S.Tree.destruct k with + | `Contents _ -> Fmt.pf ppf "FILE %a" pp_step s + | `Node _ -> Fmt.pf ppf "DIR %a" pp_step s + in + List.iter (print "%a" pp) paths; + Lwt.return_unit in Term.(mk list $ store () $ path_or_empty)); } @@ -194,52 +194,52 @@ let tree = term = (let tree (S (impl, store, _)) = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let all = ref [] in - let todo = ref [ S.Path.empty ] in - let rec walk () = - match !todo with - | [] -> Lwt.return_unit - | k :: rest -> - todo := rest; - let* childs = S.list t k in - Lwt_list.iter_p - (fun (s, c) -> - let k = S.Path.rcons k s in - match S.Tree.destruct c with - | `Node _ -> - todo := k :: !todo; - Lwt.return_unit - | `Contents _ -> - let+ v = S.get t k in - all := (k, v) :: !all) - childs - >>= walk - in - walk () >>= fun () -> - let all = !all in - let all = - List.map - (fun (k, v) -> - ( Irmin.Type.to_string S.Path.t k, - Irmin.Type.to_string S.Contents.t v )) - all - in - let max_length l = - List.fold_left (fun len s -> max len (String.length s)) 0 l - in - let k_max = max_length (List.map fst all) in - let v_max = max_length (List.map snd all) in - let pad = 79 + k_max + v_max in - List.iter - (fun (k, v) -> - let dots = - String.make (pad - String.length k - String.length v) '.' - in - print "%s%s%s" k dots v) - all; - Lwt.return_unit) + run @@ fun () -> + let* t = store in + let all = ref [] in + let todo = ref [ S.Path.empty ] in + let rec walk () = + match !todo with + | [] -> Lwt.return_unit + | k :: rest -> + todo := rest; + let* childs = S.list t k in + Lwt_list.iter_p + (fun (s, c) -> + let k = S.Path.rcons k s in + match S.Tree.destruct c with + | `Node _ -> + todo := k :: !todo; + Lwt.return_unit + | `Contents _ -> + let+ v = S.get t k in + all := (k, v) :: !all) + childs + >>= walk + in + walk () >>= fun () -> + let all = !all in + let all = + List.map + (fun (k, v) -> + ( Irmin.Type.to_string S.Path.t k, + Irmin.Type.to_string S.Contents.t v )) + all + in + let max_length l = + List.fold_left (fun len s -> max len (String.length s)) 0 l + in + let k_max = max_length (List.map fst all) in + let v_max = max_length (List.map snd all) in + let pad = 79 + k_max + v_max in + List.iter + (fun (k, v) -> + let dots = + String.make (pad - String.length k - String.length v) '.' + in + print "%s%s%s" k dots v) + all; + Lwt.return_unit in Term.(mk tree $ store ())); } @@ -265,12 +265,12 @@ let set = in let set (S (impl, store, _)) author message path v = let (module S) = Store.Impl.generic_keyed impl in - run - (let message = match message with Some s -> s | None -> "set" in - let* t = store in - let path = key S.Path.t path in - let value = value S.Contents.t v in - S.set_exn t ~info:(info (module S) ?author "%s" message) path value) + run @@ fun () -> + let message = match message with Some s -> s | None -> "set" in + let* t = store in + let path = key S.Path.t path in + let value = value S.Contents.t v in + S.set_exn t ~info:(info (module S) ?author "%s" message) path value in Term.(mk set $ store () $ author $ message $ path $ v)); } @@ -284,14 +284,14 @@ let remove = term = (let remove (S (impl, store, _)) author message path = let (module S) = Store.Impl.generic_keyed impl in - run - (let message = - match message with Some s -> s | None -> "remove " ^ path - in - let* t = store in - S.remove_exn t - ~info:(info (module S) ?author "%s" message) - (key S.Path.t path)) + run @@ fun () -> + let message = + match message with Some s -> s | None -> "remove " ^ path + in + let* t = store in + S.remove_exn t + ~info:(info (module S) ?author "%s" message) + (key S.Path.t path) in Term.(mk remove $ store () $ author $ message $ path)); } @@ -312,14 +312,14 @@ let clone = (let clone (S (impl, store, f), remote) depth = let (module S) = Store.Impl.generic_keyed impl in let module Sync = Irmin.Sync.Make (S) in - run - (let* t = store in - let* r = remote in - let* x = apply r f in - Sync.fetch t ?depth x >>= function - | Ok (`Head d) -> S.Head.set t d - | Ok `Empty -> Lwt.return_unit - | Error (`Msg e) -> failwith e) + run @@ fun () -> + let* t = store in + let* r = remote in + let* x = apply r f in + Sync.fetch t ?depth x >>= function + | Ok (`Head d) -> S.Head.set t d + | Ok `Empty -> Lwt.return_unit + | Error (`Msg e) -> failwith e in Term.(mk clone $ remote () $ depth)); } @@ -334,14 +334,14 @@ let fetch = (let fetch (S (impl, store, f), remote) = let (module S) = Store.Impl.generic_keyed impl in let module Sync = Irmin.Sync.Make (S) in - run - (let* t = store in - let* r = remote in - let branch = branch S.Branch.t "import" in - let* t = S.of_branch (S.repo t) branch in - let* x = apply r f in - let* _ = Sync.pull_exn t x `Set in - Lwt.return_unit) + run @@ fun () -> + let* t = store in + let* r = remote in + let branch = branch S.Branch.t "import" in + let* t = S.of_branch (S.repo t) branch in + let* x = apply r f in + let* _ = Sync.pull_exn t x `Set in + Lwt.return_unit in Term.(mk fetch $ remote ())); } @@ -355,21 +355,21 @@ let merge = term = (let merge (S (impl, store, _)) author message branch = let (module S) = Store.Impl.generic_keyed impl in - run - (let message = match message with Some s -> s | None -> "merge" in - let branch = - match Irmin.Type.of_string S.Branch.t branch with - | Ok b -> b - | Error (`Msg msg) -> failwith msg - in - let* t = store in - S.merge_with_branch t branch - ~info:(info (module S) ?author "%s" message) - >|= function - | Ok () -> () - | Error conflict -> - let fmt = Irmin.Type.pp_json Irmin.Merge.conflict_t in - Fmt.epr "CONFLICT: %a\n%!" fmt conflict) + run @@ fun () -> + let message = match message with Some s -> s | None -> "merge" in + let branch = + match Irmin.Type.of_string S.Branch.t branch with + | Ok b -> b + | Error (`Msg msg) -> failwith msg + in + let* t = store in + S.merge_with_branch t branch + ~info:(info (module S) ?author "%s" message) + >|= function + | Ok () -> () + | Error conflict -> + let fmt = Irmin.Type.pp_json Irmin.Merge.conflict_t in + Fmt.epr "CONFLICT: %a\n%!" fmt conflict in let branch_name = let doc = Arg.info ~docv:"BRANCH" ~doc:"Branch to merge from." [] in @@ -389,14 +389,14 @@ let pull = let (module S) = Store.Impl.generic_keyed impl in let message = match message with Some s -> s | None -> "pull" in let module Sync = Irmin.Sync.Make (S) in - run - (let* t = store in - let* r = remote in - let* x = apply r f in - let* _ = - Sync.pull_exn t x (`Merge (info (module S) ?author "%s" message)) - in - Lwt.return_unit) + run @@ fun () -> + let* t = store in + let* r = remote in + let* x = apply r f in + let* _ = + Sync.pull_exn t x (`Merge (info (module S) ?author "%s" message)) + in + Lwt.return_unit in Term.(mk pull $ remote () $ author $ message)); } @@ -411,12 +411,12 @@ let push = (let push (S (impl, store, f), remote) = let (module S) = Store.Impl.generic_keyed impl in let module Sync = Irmin.Sync.Make (S) in - run - (let* t = store in - let* r = remote in - let* x = apply r f in - let* _ = Sync.push_exn t x in - Lwt.return_unit) + run @@ fun () -> + let* t = store in + let* r = remote in + let* x = apply r f in + let* _ = Sync.push_exn t x in + Lwt.return_unit in Term.(mk push $ remote ())); } @@ -430,11 +430,11 @@ let snapshot = term = (let snapshot (S (impl, store, _)) = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let* k = S.Head.get t in - print "%a" S.Commit.pp_hash k; - Lwt.return_unit) + run @@ fun () -> + let* t = store in + let* k = S.Head.get t in + print "%a" S.Commit.pp_hash k; + Lwt.return_unit in Term.(mk snapshot $ store ())); } @@ -454,13 +454,13 @@ let revert = in let revert (S (impl, store, _)) snapshot = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let hash = commit S.Hash.t snapshot in - let* s = S.Commit.of_hash (S.repo t) hash in - match s with - | Some s -> S.Head.set t s - | None -> failwith "invalid commit") + run @@ fun () -> + let* t = store in + let hash = commit S.Hash.t snapshot in + let* s = S.Commit.of_hash (S.repo t) hash in + match s with + | Some s -> S.Head.set t s + | None -> failwith "invalid commit" in Term.(mk revert $ store () $ snapshot)); } @@ -560,18 +560,18 @@ let watch = at_exit (fun () -> match !proc with None -> () | Some p -> p#terminate) in - run - (let* t = store in - let* _ = - S.watch_key t path - (handle_diff - (module S : Irmin.Generic_key.S - with type Schema.Path.t = S.path - and type commit = S.commit) - path command proc) - in - let t, _ = Lwt.task () in - t) + run @@ fun () -> + let* t = store in + let* _ = + S.watch_key t path + (handle_diff + (module S : Irmin.Generic_key.S + with type Schema.Path.t = S.path + and type commit = S.commit) + path command proc) + in + let t, _ = Lwt.task () in + t in let command = let doc = Arg.info ~docv:"COMMAND" ~doc:"Command to execute" [] in @@ -620,33 +620,33 @@ let dot = Printf.sprintf "%2d:%2d:%2d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in - run - (let* t = store in - let call_dot = not no_dot_call in - let buf = Buffer.create 1024 in - Dot.output_buffer ~html:false t ?depth ~full ~date buf >>= fun () -> - let oc = open_out_bin (basename ^ ".dot") in - let* () = - Lwt.finalize - (fun () -> - output_string oc (Buffer.contents buf); - Lwt.return_unit) - (fun () -> - close_out oc; - Lwt.return_unit) - in - if call_dot then ( - let i = Sys.command "/bin/sh -c 'command -v dot'" in - if i <> 0 then - [%logs.err - "Cannot find the `dot' utility. Please install it on your \ - system and be sure it is available in your $PATH."]; - let i = - Sys.command - (Printf.sprintf "dot -Tpng %s.dot -o%s.png" basename basename) - in - if i <> 0 then [%logs.err "The %s.dot is corrupted" basename]); - Lwt.return_unit) + run @@ fun () -> + let* t = store in + let call_dot = not no_dot_call in + let buf = Buffer.create 1024 in + Dot.output_buffer ~html:false t ?depth ~full ~date buf >>= fun () -> + let oc = open_out_bin (basename ^ ".dot") in + let* () = + Lwt.finalize + (fun () -> + output_string oc (Buffer.contents buf); + Lwt.return_unit) + (fun () -> + close_out oc; + Lwt.return_unit) + in + if call_dot then ( + let i = Sys.command "/bin/sh -c 'command -v dot'" in + if i <> 0 then + [%logs.err + "Cannot find the `dot' utility. Please install it on your \ + system and be sure it is available in your $PATH."]; + let i = + Sys.command + (Printf.sprintf "dot -Tpng %s.dot -o%s.png" basename basename) + in + if i <> 0 then [%logs.err "The %s.dot is corrupted" basename]); + Lwt.return_unit in Term.(mk dot $ store () $ basename $ depth $ no_dot_call $ full)); } @@ -737,24 +737,22 @@ let graphql = in let graphql (S (impl, store, remote_fn)) port addr = let (module S) = Store.Impl.generic_keyed impl in - run - (let module Server = - Graphql.Server.Make - (S) - (struct - let remote = remote_fn - end) - in - let* t = store in - let server = Server.v (S.repo t) in - let* ctx = Conduit_lwt_unix.init ~src:addr () in - let ctx = Cohttp_lwt_unix.Net.init ~ctx () in - let on_exn exn = - [%logs.debug "on_exn: %s" (Printexc.to_string exn)] - in - Cohttp_lwt_unix.Server.create ~on_exn ~ctx - ~mode:(`TCP (`Port port)) - server) + run @@ fun () -> + let module Server = + Graphql.Server.Make + (S) + (struct + let remote = remote_fn + end) + in + let* t = store in + let server = Server.v (S.repo t) in + let* ctx = Conduit_lwt_unix.init ~src:addr () in + let ctx = Cohttp_lwt_unix.Net.init ~ctx () in + let on_exn exn = [%logs.debug "on_exn: %s" (Printexc.to_string exn)] in + Cohttp_lwt_unix.Server.create ~on_exn ~ctx + ~mode:(`TCP (`Port port)) + server in Term.(mk graphql $ store () $ port $ addr)); } @@ -803,10 +801,10 @@ let branches = term = (let branches (S (impl, store, _)) = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let+ branches = S.Branch.list (S.repo t) in - List.iter (Fmt.pr "%a\n" (Irmin.Type.pp S.branch_t)) branches) + run @@ fun () -> + let* t = store in + let+ branches = S.Branch.list (S.repo t) in + List.iter (Fmt.pr "%a\n" (Irmin.Type.pp S.branch_t)) branches in Term.(mk branches $ store ())); } @@ -869,59 +867,59 @@ let log = let exception Return in let commits (S (impl, store, _)) plain pager num skip reverse = let (module S) = Store.Impl.generic_keyed impl in - run - (let* t = store in - let fmt f date = - Fmt.pf f "%s %s %02d %02d:%02d:%02d %04d" (weekday date) - (month date) date.tm_mday date.tm_hour date.tm_min date.tm_sec - (date.tm_year + 1900) - in - let repo = S.repo t in - let skip = ref (Option.value ~default:0 skip) in - let num = Option.value ~default:0 num in - let num_count = ref 0 in - let commit formatter key = - if num > 0 && !num_count >= num then raise Return - else if !skip > 0 then - let () = decr skip in - Lwt.return_unit - else - let+ commit = S.Commit.of_key repo key >|= Option.get in - let hash = S.Backend.Commit.Key.to_hash key in - let info = S.Commit.info commit in - let date = S.Info.date info in - let author = S.Info.author info in - let message = S.Info.message info in - let date = Unix.localtime (Int64.to_float date) in - let () = - Fmt.pf formatter "commit %a\nAuthor: %s\nDate: %a\n\n%s\n\n%!" - (Irmin.Type.pp S.hash_t) hash author fmt date message - in - incr num_count - in - let* max = S.Head.get t >|= fun x -> [ `Commit (S.Commit.key x) ] in - let iter ~commit ~max repo = - Lwt.catch - (fun () -> - if reverse then S.Repo.iter ~commit ~min:[] ~max repo - else S.Repo.breadth_first_traversal ~commit ~max repo) - (function Return -> Lwt.return_unit | exn -> raise exn) - in - if plain then - let commit = commit Format.std_formatter in - iter ~commit ~max repo - else - Lwt.catch - (fun () -> - let out = Unix.open_process_out pager in - let commit = commit (Format.formatter_of_out_channel out) in - let+ () = iter ~commit ~max repo in - let _ = Unix.close_process_out out in - ()) - (function - | Sys_error s when String.equal s "Broken pipe" -> - Lwt.return_unit - | exn -> raise exn)) + run @@ fun () -> + let* t = store in + let fmt f date = + Fmt.pf f "%s %s %02d %02d:%02d:%02d %04d" (weekday date) (month date) + date.tm_mday date.tm_hour date.tm_min date.tm_sec + (date.tm_year + 1900) + in + let repo = S.repo t in + let skip = ref (Option.value ~default:0 skip) in + let num = Option.value ~default:0 num in + let num_count = ref 0 in + let commit formatter key = + if num > 0 && !num_count >= num then raise Return + else if !skip > 0 then + let () = decr skip in + Lwt.return_unit + else + let+ commit = S.Commit.of_key repo key >|= Option.get in + let hash = S.Backend.Commit.Key.to_hash key in + let info = S.Commit.info commit in + let date = S.Info.date info in + let author = S.Info.author info in + let message = S.Info.message info in + let date = Unix.localtime (Int64.to_float date) in + let () = + Fmt.pf formatter "commit %a\nAuthor: %s\nDate: %a\n\n%s\n\n%!" + (Irmin.Type.pp S.hash_t) hash author fmt date message + in + incr num_count + in + let* max = S.Head.get t >|= fun x -> [ `Commit (S.Commit.key x) ] in + let iter ~commit ~max repo = + Lwt.catch + (fun () -> + if reverse then S.Repo.iter ~commit ~min:[] ~max repo + else S.Repo.breadth_first_traversal ~commit ~max repo) + (function Return -> Lwt.return_unit | exn -> raise exn) + in + if plain then + let commit = commit Format.std_formatter in + iter ~commit ~max repo + else + Lwt.catch + (fun () -> + let out = Unix.open_process_out pager in + let commit = commit (Format.formatter_of_out_channel out) in + let+ () = iter ~commit ~max repo in + let _ = Unix.close_process_out out in + ()) + (function + | Sys_error s when String.equal s "Broken pipe" -> + Lwt.return_unit + | exn -> raise exn) in Term.(mk commits $ store () $ plain $ pager $ num $ skip $ reverse)); }