Merge pull request #34 from zshipko/low

Implement Irmin.Generic_key.S using Irmin_client

Dockerfile

@@ -1,5 +1,5 @@
 # base
-FROM ocaml/opam:debian-ocaml-4.12 as base
+FROM ocaml/opam:debian as base
 RUN sudo apt-get update -y
 RUN sudo apt-get install -y git m4 libgmp-dev perl libev-dev pkg-config gnuplot-nox libffi-dev
 RUN opam remote set-url default https://github.com/ocaml/opam-repository.git
@@ -21,14 +21,16 @@ RUN apt-get update -y
 RUN apt-get install -y ca-certificates
 
 ENV PORT=9090
+ENV STORE=pack
 ENV HASH=blake2b
 ENV CONTENTS=string
+ENV CODEC=bin
 
 EXPOSE $PORT
 
 COPY --from=base /irmin-server/_build/default/bin/server/server.exe ./irmin-server
 COPY --from=base /usr/lib/x86_64-linux-gnu/libgmp* /usr/lib/
 COPY --from=base /usr/lib/x86_64-linux-gnu/libev* /usr/lib/
 VOLUME /data
-CMD [ "sh", "-c", "./irmin-server --uri tcp://0.0.0.0:${PORT} --hash ${HASH} --contents ${CONTENTS} --root /data" ]
+CMD [ "sh", "-c", "./irmin-server --uri tcp://0.0.0.0:${PORT} --store ${STORE} --hash ${HASH} --contents ${CONTENTS} --codec ${CODEC} --root /data" ]
 

PROTOCOL.md

@@ -18,6 +18,7 @@ A request is sent from the client to the server
 | Field               | Type                        |
 | ------------------- | --------------------------- |
 | command             | `\n` delimited string       |
+| '\n'                | Extra '\n' character        |
 | request             | Message                     |
 
 ## Response
@@ -43,9 +44,9 @@ A handshake is performed when a client connects to the server
 
 The following is sent as a request from the client to server **AND** the response from server to client
 
-| Field        | Type                     |
-| -------      | ------------------------ |
-| version hash | `\n` delimited string    |
+| Field        | Type                      |
+| -------      | ------------------------- |
+| version hash | `\n` delimited string     |
 
 `version hash` is the hex-encoded hash of the current protocol version (`V1`) using `Store.Hash`.
 

bin/client/client.ml

@@ -20,7 +20,8 @@ let with_timer f =
   let t1 = Sys.time () -. t0 in
   (t1, a)
 
-let init ~uri ~branch ~tls (module Client : Irmin_client.S) : client Lwt.t =
+let init ~uri ~branch ~tls (module Client : Irmin_client_unix.S) : client Lwt.t
+    =
   let* x = Client.connect ~tls ~uri () in
   let+ () =
     match branch with
@@ -30,7 +31,7 @@ let init ~uri ~branch ~tls (module Client : Irmin_client.S) : client Lwt.t =
         >|= Error.unwrap "Branch.set_current"
     | None -> Lwt.return_unit
   in
-  S ((module Client : Irmin_client.S with type t = Client.t), x)
+  S ((module Client : Irmin_client_unix.S with type t = Client.t), x)
 
 let run f time iterations =
   let rec eval iterations =
@@ -58,8 +59,8 @@ let list_server_commands () =
   in
   List.iter
     (fun (name, (module C : Cmd.CMD)) ->
-      Printf.printf "%s:\n\tInput: %s\n\tOutput: %s\n" name (str C.Req.t)
-        (str C.Res.t))
+      Printf.printf "%s:\n\tInput: %s\n\tOutput: %s\n" name (str C.req_t)
+        (str C.res_t))
     Cmd.commands
 
 let ping client =
@@ -75,7 +76,7 @@ let find client path =
       let path =
         Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path"
       in
-      let* result = Client.Store.find client path >|= Error.unwrap "find" in
+      let* result = Client.find client path >|= Error.unwrap "find" in
       match result with
       | Some data ->
           let* () =
@@ -93,7 +94,7 @@ let mem client path =
       let path =
         Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path"
       in
-      let* result = Client.Store.mem client path >|= Error.unwrap "mem" in
+      let* result = Client.mem client path >|= Error.unwrap "mem" in
       Lwt_io.printl (if result then "true" else "false"))
 
 let mem_tree client path =
@@ -102,37 +103,33 @@ let mem_tree client path =
       let path =
         Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path"
       in
-      let* result =
-        Client.Store.mem_tree client path >|= Error.unwrap "mem_tree"
-      in
+      let* result = Client.mem_tree client path >|= Error.unwrap "mem_tree" in
       Lwt_io.printl (if result then "true" else "false"))
 
 let set client path author message contents =
   run (fun () ->
       client >>= fun (S ((module Client), client)) ->
+      let module Info = Irmin_client_unix.Info (Client.Info) in
       let path =
         Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path"
       in
       let contents =
         Irmin.Type.of_string Client.Contents.t contents
         |> Error.unwrap "contents"
       in
-      let info = Client.Info.v ~author "%s" message in
-      let+ () =
-        Client.Store.set client path ~info contents >|= Error.unwrap "set"
-      in
+      let info = Info.v ~author "%s" message in
+      let+ () = Client.set client path ~info contents >|= Error.unwrap "set" in
       Logs.app (fun l -> l "OK"))
 
 let remove client path author message =
   run (fun () ->
       client >>= fun (S ((module Client), client)) ->
+      let module Info = Irmin_client_unix.Info (Client.Info) in
       let path =
         Irmin.Type.of_string Client.Path.t path |> Error.unwrap "path"
       in
-      let info = Client.Info.v ~author "%s" message in
-      let+ () =
-        Client.Store.remove client path ~info >|= Error.unwrap "remove"
-      in
+      let info = Info.v ~author "%s" message in
+      let+ () = Client.remove client path ~info >|= Error.unwrap "remove" in
       Logs.app (fun l -> l "OK"))
 
 let export client filename =
@@ -162,6 +159,7 @@ let stats client =
 let replicate client author message =
   Lwt_main.run
     ( client >>= fun (S ((module Client), client)) ->
+      let module Info = Irmin_client_unix.Info (Client.Info) in
       let diff input =
         Irmin.Type.(
           of_json_string
@@ -183,10 +181,9 @@ let replicate client author message =
               | `Removed _ -> (k, None) :: acc)
             [] (diff input)
         in
-        let info = Client.Info.v ~author "%s" message in
+        let info = Info.v ~author "%s" message in
         let* tree =
-          Client.Store.find_tree client Client.Path.empty
-          >|= Error.unwrap "find_tree"
+          Client.find_tree client Client.Path.empty >|= Error.unwrap "find_tree"
         in
         let tree =
           match tree with Some t -> t | None -> Client.Tree.empty client
@@ -195,7 +192,7 @@ let replicate client author message =
           Client.Tree.batch_update tree batch >|= Error.unwrap "build"
         in
         let* _ =
-          Client.Store.set_tree client ~info Client.Path.empty tree
+          Client.set_tree client ~info Client.Path.empty tree
           >|= Error.unwrap "set_tree"
         in
         loop ()
@@ -206,20 +203,24 @@ let watch client =
   Lwt_main.run
     ( client >>= fun (S ((module Client), client)) ->
       let pp = Irmin.Type.pp Client.Commit.t in
-      Client.watch
-        (fun x ->
-          match x with
-          | `Updated (a, b) ->
-              Logs.app (fun l -> l "Updated (%a, %a)" pp a pp b);
-              Lwt.return_ok `Continue
-          | `Added a ->
-              Logs.app (fun l -> l "Added %a" pp a);
-              Lwt.return_ok `Continue
-          | `Removed a ->
-              Logs.app (fun l -> l "Removed %a" pp a);
-              Lwt.return_ok `Continue)
-        client
-      >|= Error.unwrap "watch" )
+      let* _w =
+        Client.watch
+          (fun x ->
+            match x with
+            | `Updated (a, b) ->
+                Logs.app (fun l -> l "Updated (%a, %a)" pp a pp b);
+                Lwt.return_unit
+            | `Added a ->
+                Logs.app (fun l -> l "Added %a" pp a);
+                Lwt.return_unit
+            | `Removed a ->
+                Logs.app (fun l -> l "Removed %a" pp a);
+                Lwt.return_unit)
+          client
+        >|= Error.unwrap "watch"
+      in
+      let x, _ = Lwt.wait () in
+      x )
 
 let pr_str = Format.pp_print_string
 
@@ -266,8 +267,14 @@ let freq =
   Arg.(value @@ opt float 5. doc)
 
 let config =
-  let create uri (branch : string option) tls (store, hash, contents)
-      (module Codec : Conn.Codec.S) config_path () =
+  let create uri (branch : string option) tls (store, hash, contents) codec
+      config_path () =
+    let codec =
+      match codec with
+      | `Bin -> (module Conn.Codec.Bin : Conn.Codec.S)
+      | `Json -> (module Conn.Codec.Json)
+    in
+    let (module Codec) = codec in
     let store, config =
       Irmin_unix.Resolver.load_config ?config_path ?store ?hash ?contents ()
     in

bin/client/dashboard.ml

@@ -37,19 +37,18 @@ let uptime = Widget.display "Uptime" "%.0fs" 0.0
 
 let pack =
   Widget.v
-    (fun (size, adds, finds, cache_misses) ->
+    (fun (adds, finds, cache_misses) ->
       Ui.vcat
         [
           W.printf ~attr:Notty.A.(st bold) "Pack:";
-          W.printf "Size: %fM" size;
           W.printf "Adds: %d" adds;
           W.printf "Finds: %d" finds;
           W.printf "Cache misses: %f" cache_misses;
         ])
-    (0., 0, 0, 0.)
+    (0, 0, 0.)
 
-let commit_diff (type a) (module Client : Irmin_client.S with type commit = a) x
-    =
+let commit_diff (type a)
+    (module Client : Irmin_client_unix.S with type commit = a) x =
   let pr t a =
     let info = Client.Commit.info a in
     let date = Client.Info.date info in
@@ -65,8 +64,8 @@ let commit_diff (type a) (module Client : Irmin_client.S with type commit = a) x
   | `Removed a -> pr "Removed" a
   | `Updated (_a, b) -> pr "Updated" b
 
-let last_updates (type a) (module Client : Irmin_client.S with type commit = a)
-    =
+let last_updates (type a)
+    (module Client : Irmin_client_unix.S with type commit = a) =
   Widget.v
     (fun last_updates ->
       let last_updates = List.map (commit_diff (module Client)) last_updates in
@@ -91,7 +90,7 @@ let main client freq =
   client >>= fun (S ((module Client), client)) ->
   let last_updates =
     last_updates
-      (module Client : Irmin_client.S with type commit = Client.commit)
+      (module Client : Irmin_client_unix.S with type commit = Client.commit)
   in
   let ui =
     let open Lwd_infix in
@@ -121,24 +120,22 @@ let main client freq =
     Lwt.async (fun () ->
         let* stats = Client.stats client >|= Error.unwrap "stats" in
         Widget.set_value uptime stats.uptime;
-        Widget.set_value pack
-          (stats.size, stats.adds, stats.finds.total, stats.cache_misses);
+        Widget.set_value pack (stats.adds, stats.finds.total, stats.cache_misses);
         Widget.set_value heads stats.branches;
         let+ () = Lwt_unix.sleep freq in
         tick client ())
   in
 
   let watch client () =
-    Lwt.async (fun () ->
-        let f x =
-          Widget.set_value last_updates (x :: Lwd.peek last_updates.value);
-          Lwt.return_ok `Continue
-        in
-        Client.watch f client >|= Error.unwrap "watch")
+    let f x =
+      Widget.set_value last_updates (x :: Lwd.peek last_updates.value);
+      Lwt.return_unit
+    in
+    Client.watch f client >|= Error.unwrap "watch"
   in
 
   let* wc = Client.dup client in
-  watch wc ();
+  let* _watch = watch wc () in
   tick client ();
   Nottui_lwt.run (W.scroll_area ui)
 

bin/client/import.ml

@@ -1 +1,2 @@
-type client = S : ((module Irmin_client.S with type t = 'a) * 'a) -> client
+type client =
+  | S : ((module Irmin_client_unix.S with type t = 'a) * 'a) -> client

bin/server/server.ml

@@ -1,6 +1,8 @@
 open Lwt.Syntax
 open Irmin_server_internal
 
+let () = Irmin_unix.set_listen_dir_hook ()
+
 let setup_log style_renderer level =
   Fmt_tty.setup_std_outputs ?style_renderer ();
   Logs.set_level level;
@@ -37,13 +39,20 @@ let main ~readonly ~root ~uri ~tls ~store ~contents ~hash ~config_path
   Server.serve server
 
 let main readonly root uri tls (store, hash, contents) codec config_path () =
+  let codec =
+    match codec with
+    | `Bin -> (module Conn.Codec.Bin : Conn.Codec.S)
+    | `Json -> (module Conn.Codec.Json)
+  in
   Lwt_main.run
   @@ main ~readonly ~root ~uri ~tls ~store ~contents ~hash ~config_path codec
 
 open Cmdliner
 
 let root =
-  let doc = Arg.info ~doc:"Irmin store path" [ "r"; "root" ] in
+  let doc =
+    Arg.info ~docs:"" ~docv:"PATH" ~doc:"Irmin store path" [ "r"; "root" ]
+  in
   Arg.(value @@ opt (some string) None doc)
 
 let readonly =
@@ -56,7 +65,9 @@ let readonly =
   Arg.(value @@ flag doc)
 
 let tls =
-  let doc = Arg.info ~docv:"CERT_FILE,KEY_FILE" ~doc:"TLS config" [ "tls" ] in
+  let doc =
+    Arg.info ~docs:"" ~docv:"CERT_FILE,KEY_FILE" ~doc:"TLS config" [ "tls" ]
+  in
   Arg.(value @@ opt (some (pair string string)) None doc)
 
 let main_term =

examples/branches.ml

@@ -1,8 +1,9 @@
 open Lwt.Syntax
 open Lwt.Infix
+open Irmin_client_unix
 module Store = Irmin_mem.KV.Make (Irmin.Contents.String)
-module Client = Irmin_client_unix.Make (Store)
-module Error = Irmin_client.Error
+module Client = Make (Store)
+module Info = Info (Client.Info)
 
 let main =
   let uri = Uri.of_string "tcp://localhost:9090" in
@@ -15,10 +16,9 @@ let main =
   assert (current_branch = Client.Branch.main);
 
   (* Set a/b/c on [current_branch] *)
-  let info = Client.Info.v "set a/b/c" in
+  let info = Info.v "set a/b/c" in
   let* () =
-    Client.Store.set ~info client [ "a"; "b"; "c" ] "123"
-    >|= Error.unwrap "Store.set"
+    Client.set ~info client [ "a"; "b"; "c" ] "123" >|= Error.unwrap "Store.set"
   in
 
   (* Switch to new [test] branch *)
@@ -29,7 +29,7 @@ let main =
 
   (* Get a/b/c in [test] branch (should be None) *)
   let* abc =
-    Client.Store.find client [ "a"; "b"; "c" ] >|= Error.unwrap "Store.find"
+    Client.find client [ "a"; "b"; "c" ] >|= Error.unwrap "Store.find"
   in
   assert (Option.is_none abc);
 
@@ -39,7 +39,7 @@ let main =
     >|= Error.unwrap "Branch.set_current"
   in
   let+ abc =
-    Client.Store.find client [ "a"; "b"; "c" ] >|= Error.unwrap "Store.find"
+    Client.find client [ "a"; "b"; "c" ] >|= Error.unwrap "Store.find"
   in
   assert (Option.is_some abc)