Finally, make the first PoC about git-state

app/dune

@@ -0,0 +1,4 @@
+(executable
+ (name mgit)
+ (public_name mgit)
+ (libraries git-unix git-kv))

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 "@[<hov>%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 <remote> [<filename>]\n%!" Sys.argv.(0)

dune-project

@@ -1,3 +1,4 @@
-(lang dune 2.6)
+(lang dune 2.8)
 (name git-kv)
 (formatting disabled)
+(cram enable)

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

test/dune

@@ -0,0 +1,3 @@
+(cram
+ (package git-kv)
+ (deps %{bin:mgit}))

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 <<EOF
+  > 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 <<EOF
+  > 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 <<EOF
+  > 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)