diff --git a/app/dune b/app/dune new file mode 100644 index 0000000..b078fe5 --- /dev/null +++ b/app/dune @@ -0,0 +1,4 @@ +(executable + (name mgit) + (public_name mgit) + (libraries git-unix git-kv)) diff --git a/app/mgit.ml b/app/mgit.ml new file mode 100644 index 0000000..a8d076f --- /dev/null +++ b/app/mgit.ml @@ -0,0 +1,97 @@ +let () = Printexc.record_backtrace true + +open Rresult +open Lwt.Infix + +let get ~quiet store key = + Git_kv.get store key >>= function + | Ok contents when not quiet -> + Fmt.pr "@[%a@]\n%!" (Hxd_string.pp Hxd.default) contents ; + Lwt.return (Ok 0) + | Ok _ -> Lwt.return (Ok 0) + | Error err -> + if not quiet then Fmt.epr "%a.\n%!" Git_kv.pp_error err ; + Lwt.return (Ok 1) + +let list ~quiet store key = + Git_kv.list store key >>= function + | Ok lst when not quiet -> + List.iter (fun (name, k) -> match k with + | `Dictionary -> Fmt.pr "d %s\n%!" name + | `Value -> Fmt.pr "- %s\n%!" name) lst ; + Lwt.return (Ok 0) + | Ok _ -> Lwt.return (Ok 0) + | Error err -> + if not quiet then Fmt.epr "%a.\n%!" Git_kv.pp_error err ; + Lwt.return (Ok 1) + +let pull ~quiet store = + Git_kv.pull store >>= function + | Error (`Msg err) -> if not quiet then Fmt.epr "%s.\n%!" err ; Lwt.return (Ok 1) + | Ok diff when not quiet -> + List.iter (function + | `Add key -> Fmt.pr "+ %a\n%!" Mirage_kv.Key.pp key + | `Remove key -> Fmt.pr "- %a\n%!" Mirage_kv.Key.pp key + | `Change key -> Fmt.pr "* %a\n%!" Mirage_kv.Key.pp key) diff ; + Lwt.return (Ok 0) + | Ok _ -> Lwt.return (Ok 0) + +let save store filename = + let oc = open_out filename in + Git_kv.to_octets store >>= fun contents -> + output_string oc contents ; + close_out oc ; + Lwt.return (Ok 0) + +let trim lst = + List.fold_left (fun acc -> function + | "" -> acc + | str -> str :: acc) [] lst |> List.rev + +let with_key ~f key = + match Mirage_kv.Key.v key with + | key -> f key + | exception _ -> + Fmt.epr "Invalid key: %S.\n%!" key ; + Lwt.return (Ok 1) + +let repl store ic = + let rec go () = Fmt.pr "# %!" ; match String.split_on_char ' ' (input_line ic) |> trim with + | [ "get"; key; ] -> + with_key ~f:(get ~quiet:false store) key >|= ignore >>= go + | [ "list"; key; ] -> + with_key ~f:(list ~quiet:false store) key >|= ignore >>= go + | [ "pull"; ] -> + Fmt.pr "\n%!" ; pull ~quiet:false store >|= ignore >>= go + | [ "quit"; ] -> Lwt.return () + | [ "save"; filename ] -> + save store filename >|= ignore >>= fun _ -> + Fmt.pr "\n%!" ; go () + | _ -> Fmt.epr "Invalid command.\n%!" ; go () + | exception End_of_file -> Lwt.return () in + go () + +let run remote = function + | None -> + Lwt_main.run @@ + (Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> + Git_kv.connect ctx remote >>= fun t -> + repl t stdin) + | Some filename -> + let contents = + let ic = open_in filename in + let ln = in_channel_length ic in + let bs = Bytes.create ln in + really_input ic bs 0 ln ; + Bytes.unsafe_to_string bs in + Lwt_main.run + ( Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> + Git_kv.of_octets ctx ~remote contents >>= function + | Ok t -> repl t stdin + | Error (`Msg err) -> Fmt.failwith "%s." err ) + +let () = match Sys.argv with + | [| _; remote; |] -> run remote None + | [| _; remote; filename; |] when Sys.file_exists filename -> + run remote (Some filename) + | _ -> Fmt.epr "%s []\n%!" Sys.argv.(0) diff --git a/dune-project b/dune-project index a3e0732..9a0a39f 100644 --- a/dune-project +++ b/dune-project @@ -1,3 +1,4 @@ -(lang dune 2.6) +(lang dune 2.8) (name git-kv) (formatting disabled) +(cram enable) diff --git a/src/git_kv.ml b/src/git_kv.ml index 3a713bc..672110a 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -37,11 +37,13 @@ let split_url s = Smart_git.Endpoint.of_string s |> to_invalid, main let fpath_to_key ~root v = - Mirage_kv.Key.v (Fpath.to_string (Option.get (Fpath.relativize ~root v))) + if Fpath.equal root v + then Mirage_kv.Key.empty + else Mirage_kv.Key.v (Fpath.to_string (Option.get (Fpath.relativize ~root v))) let diff store commit0 commit1 = let open Lwt.Infix in - let root = Fpath.v "." in + let root = Fpath.v "./" in let tbl0 = Hashtbl.create 0x10 in Store.fold store (fun () ?name ~length:_ hash _value -> Option.iter (fun name -> Hashtbl.add tbl0 (fpath_to_key ~root name) hash) name ; @@ -50,12 +52,13 @@ let diff store commit0 commit1 = Store.fold store (fun () ?name ~length:_ hash _value -> Option.iter (fun name -> Hashtbl.add tbl1 (fpath_to_key ~root name) hash) name ; Lwt.return ()) () ~path:root commit1 >>= fun () -> - let diff = Hashtbl.fold (fun name hash diff -> match Hashtbl.find_opt tbl1 name with + let diff = Hashtbl.fold (fun name hash diff -> + match Hashtbl.find_opt tbl1 name with | Some hash' when not (Digestif.SHA1.equal hash hash') -> `Change name :: diff | Some _ -> diff | None -> `Remove name :: diff) tbl0 [] in let diff = Hashtbl.fold (fun name _hash diff -> - if Hashtbl.mem tbl0 name + if not (Hashtbl.mem tbl0 name) then `Add name :: diff else diff) tbl1 diff in Lwt.return diff @@ -238,11 +241,6 @@ let pack t ~commit stream = go 0 >>= fun () -> let hash = SHA1.get !ctx in stream (Some (SHA1.to_raw_string hash)) ; - stream (Some (SHA1.to_raw_string commit)) ; - (* XXX(dinosaure): PACK file + the hash of the commit. The hash of the commit - is not really needed if we assert that we store only one commit finally. We - can just, for the decoding, unpack everything and find the only commit - available into the PACK file. *) stream None ; Lwt.return_unit @@ -346,6 +344,8 @@ let stream_of_string str = | false -> closed := true ; Lwt.return_some str let map contents ~pos len = + let off = Int64.to_int pos in + let len = min (String.length contents - off) len in Bigstringaf.of_string ~off:(Int64.to_int pos) ~len contents let unpack contents = @@ -398,7 +398,10 @@ let of_octets ctx ~remote data = unpack data >>= fun (store, head) -> let edn, branch = split_url remote in Lwt.return_ok { ctx ; edn ; branch ; store ; head; }) - (fun _exn -> + (fun exn -> + Fmt.epr ">>> Got an exception: %s.\n%!" (Printexc.to_string exn) ; + Fmt.epr ">>> %s.\n%!" + (Printexc.raw_backtrace_to_string (Printexc.get_raw_backtrace ())) ; Lwt.return_error (`Msg "Invalid PACK file")) let exists t key = @@ -426,7 +429,7 @@ let get t key = | Blob b -> Ok (Git.Blob.to_string b) | _ -> Error (`Value_expected key) -let get_partial t key ~offset ~length = +let _get_partial t key ~offset ~length = let open Lwt_result.Infix in get t key >|= fun data -> if String.length data < offset then @@ -483,7 +486,7 @@ let digest t key = ~some:(fun x -> Ok (Store.Hash.to_hex x)) t.head |> Lwt.return -let size t key = +let _size t key = let open Lwt_result.Infix in get t key >|= fun data -> String.length data diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..18a03d6 --- /dev/null +++ b/test/dune @@ -0,0 +1,3 @@ +(cram + (package git-kv) + (deps %{bin:mgit})) diff --git a/test/simple.t b/test/simple.t new file mode 100644 index 0000000..15be0b1 --- /dev/null +++ b/test/simple.t @@ -0,0 +1,46 @@ +Simple test of our Git Key-Value store + $ mkdir simple + $ cd simple + $ git init -q 2> /dev/null + $ git config init.defaultBranch main + $ git checkout -b main -q + $ git config user.email "romain@mirage.io" + $ git config user.name "Romain Calascibetta" + $ echo "Hello World!" > foo + $ git add foo + $ export DATE="2016-08-21 17:18:43 +0200" + $ export GIT_COMMITTER_DATE="2016-08-21 17:18:43 +0200" + $ git commit --date "$DATE" -q -m . + $ cd .. + $ git daemon --base-path=. --export-all --reuseaddr --pid-file=pid --detach + $ mgit git://localhost/simple < get /foo + > save db.pack + > quit + # 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. + # + # + $ tail -c20 db.pack | base64 - + 5LI0Ny5+PX6FCDkSPYcRzZlCcUc= + $ mgit git://localhost/simple db.pack < get /foo + > quit + # 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. + # + $ cd simple + $ echo "Git rocks!" > bar + $ git add bar + $ git commit --date "$DATE" -q -m . + $ cd .. + $ mgit git://localhost/simple db.pack < pull + > get /bar + > get /foo + > quit + # + + /bar + * / + # 00000000: 4769 7420 726f 636b 7321 0a Git rocks!. + # 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. + # + $ kill $(cat pid)