fix: update remove, find and contains_hash functions (#15)

* fix: update remove and contains_hash functions

* fix: don't return modules unless they're active in store

* ci: update to 5.1

* chore: update wasmparser

* test: improve new tests

* chore: update deps and lockfile

* cleanup: improve get_hash_and_filename function

* cleanup: improve doc comments

.github/workflows/ocaml.yml

@@ -59,7 +59,7 @@ jobs:
       fail-fast: true
       matrix:
         ocaml-compiler:
-          - 5.0.0
+          - 5.1
         os:
           - macos-latest
           - ubuntu-latest

.ocamlformat

@@ -1 +1,5 @@
-version = 0.25.1
+version = 0.26.1
+doc-comments = after-when-possible
+doc-comments-padding = 2
+doc-comments-tag-only = default
+parse-docstrings = true

Cargo.toml

@@ -7,5 +7,5 @@ edition = "2021"
 crate-type = ["staticlib", "cdylib"]
 
 [dependencies]
-wasmparser = "0.112"
+wasmparser = "0.113"
 

dune-project

@@ -29,7 +29,7 @@
    lwt
    lwt_eio
    eio_main
-   cohttp-lwt-unix
+   (cohttp-lwt-unix (>= "6.0.0~alpha2"))
    fmt
    logs
    websocket

src/dune

@@ -25,11 +25,13 @@
 
 (rule
  (targets libwasm.a dllwasm.so)
- (deps (glob_files *.rs))
+ (deps
+  (glob_files *.rs))
  (action
   (progn
    (run sh -c "cd %{project_root}/../.. && cargo build --release")
-   (run sh -c
-     "mv %{project_root}/../../target/release/libwasm.so ./dllwasm.so 2> /dev/null || \
-      mv %{project_root}/../../target/release/libwasm.dylib ./dllwasm.so")
+   (run
+    sh
+    -c
+    "mv %{project_root}/../../target/release/libwasm.so ./dllwasm.so 2> /dev/null || mv %{project_root}/../../target/release/libwasm.dylib ./dllwasm.so")
    (run mv %{project_root}/../../target/release/libwasm.a libwasm.a))))

src/server_websocket.ml

@@ -18,7 +18,7 @@
 
 open Lwt.Infix
 open Websocket
-module Lwt_IO = Websocket.Make (Cohttp_lwt_unix.IO)
+module Lwt_IO = Websocket.Make (Cohttp_lwt_unix.Private.IO)
 
 let send_frames stream oc =
   let buf = Buffer.create 128 in

src/store.ml

@@ -89,13 +89,31 @@ let path_of_hash hash =
   let b = String.sub hash' 2 (String.length hash' - 2) in
   "objects" // a // b
 
+let hash_eq = Irmin.Type.(unstage (equal Store.Hash.t))
+
+let contains_hash t hash =
+  let rec aux tree =
+    match Store.Tree.destruct tree with
+    | `Contents (c, _) ->
+        let hash' = Store.Tree.Contents.hash c in
+        Lwt.return @@ hash_eq hash hash'
+    | `Node _ ->
+        let* items = Store.Tree.list tree [] in
+        Lwt_list.exists_p (fun (_, tree') -> aux tree') items
+  in
+  let* tree = Store.tree t.db in
+  aux tree
+
 let get_hash_and_filename t path =
   let* hash = hash_or_path ~hash:Lwt.return_some ~path:(Store.hash t.db) path in
   match hash with
   | None -> Lwt.return_none
   | Some hash ->
-      let path = path_of_hash hash in
-      Lwt.return_some (hash, path)
+      let+ exists = contains_hash t hash in
+      if exists then
+        let path = path_of_hash hash in
+        Some (hash, path)
+      else None
 
 let set_path t path hash =
   let* tree = Store.Tree.of_hash (repo t) (`Contents (hash, ())) in
@@ -184,35 +202,41 @@ let set t path hash =
       Error.throw (`Msg "A hash path should not be used with `set` command"))
     ~path:f path
 
-let find_hash { db; _ } hash = Store.Contents.of_hash (Store.repo db) hash
+let find_hash t hash =
+  let* contains = contains_hash t hash in
+  if contains then Store.Contents.of_hash (Store.repo t.db) hash
+  else Lwt.return_none
+
 let find t path = hash_or_path ~hash:(find_hash t) ~path:(Store.find t.db) path
 
 let hash t path =
   hash_or_path ~hash:(fun x -> Lwt.return_some x) ~path:(Store.hash t.db) path
 
-let hash_eq = Irmin.Type.(unstage (equal Store.Hash.t))
-
 let remove t path =
   let info = info t "Remove %a" (Irmin.Type.pp Store.Path.t) path in
   let hash h =
     (* Search through the current tree for any contents that match [h] *)
-    let rec aux tree path =
+    let rec aux tree =
       match Store.Tree.destruct tree with
       | `Contents (c, _) ->
           let hash = Store.Tree.Contents.hash c in
-          if hash_eq hash h then Store.Tree.remove tree path
-          else Lwt.return tree
+          if hash_eq hash h then Store.Tree.remove tree [] else Lwt.return tree
       | `Node _ ->
           let* items = Store.Tree.list tree [] in
           Lwt_list.fold_left_s
-            (fun tree -> function p, _ -> aux tree (Store.Path.rcons path p))
+            (fun tree -> function
+              | p, tree' ->
+                  let* x = aux tree' in
+                  Store.Tree.add_tree tree [ p ] x)
             tree items
     in
     let* tree = Store.tree t.db in
-    let* tree = aux tree [] in
+    let is_empty = Store.Tree.is_empty tree in
+    let* tree' = aux tree in
     Error.mk_lwt @@ fun () ->
-    Store.test_and_set_tree_exn t.db path ~test:(Some tree) ~set:(Some tree)
-      ~info
+    Store.test_and_set_tree_exn t.db []
+      ~test:(if is_empty then None else Some tree)
+      ~set:(Some tree') ~info
   in
   hash_or_path ~path:(Store.remove_exn t.db ~info) ~hash path
 
@@ -234,12 +258,6 @@ let list { db; _ } path =
   in
   aux path
 
-let contains_hash t hash =
-  let+ res =
-    get_hash_and_filename t [ Irmin.Type.to_string Store.Hash.t hash ]
-  in
-  Option.is_some res
-
 let contains t path =
   hash_or_path
     ~hash:(fun h -> contains_hash t h)

src/wasmstore.mli

@@ -47,28 +47,34 @@ val store : t -> Store.t
 val repo : t -> Store.repo
 (** [repo t] returns the underlying irmin repo *)
 
-val v : ?author:string -> ?branch:string -> string -> env:Eio_unix.Stdenv.base -> t Lwt.t
+val v :
+  ?author:string ->
+  ?branch:string ->
+  string ->
+  env:Eio_unix.Stdenv.base ->
+  t Lwt.t
 (** [v ~branch root] opens a store open to [branch] on disk at [root] *)
 
 val snapshot : t -> Store.commit Lwt.t
 (** [snapshot t] gets the current head commit *)
 
 val restore : t -> ?path:string list -> Store.commit -> unit Lwt.t
-(** [restore t commit] sets the head commit, if [path] is provided then only the specfied path
-    will be reverted *)
+(** [restore t commit] sets the head commit, if [path] is provided then only the
+    specfied path will be reverted *)
 
 val rollback : t -> ?path:string list -> int -> unit Lwt.t
-(** [rollback t n] sets the head commit to [n] commits in the past, if [path] is provided then only the specfied 
-    path will be reverted *)
+(** [rollback t n] sets the head commit to [n] commits in the past, if [path] is
+    provided then only the specfied path will be reverted *)
 
 val find : t -> string list -> string option Lwt.t
-(** [find t path] returns the module associated with [path], if path is a single-item list containing 
-    the string representation of the hash then the module will be located using the hash instead. This
-    goes for all functions that accept [path] arguments unless otherwise noted. *)
+(** [find t path] returns the module associated with [path], if path is a
+    single-item list containing the string representation of the hash then the
+    module will be located using the hash instead. This goes for all functions
+    that accept [path] arguments unless otherwise noted. *)
 
 val add : t -> string list -> string -> hash Lwt.t
-(** [add t path wasm_module] sets [path] to [wasm_module] after verifying the module. If [path] is a hash
-    then it will be converted to "[$HASH].wasm". *)
+(** [add t path wasm_module] sets [path] to [wasm_module] after verifying the
+    module. If [path] is a hash then it will be converted to "[$HASH].wasm". *)
 
 val set : t -> string list -> hash -> unit Lwt.t
 (** [set t path hash] sets [path] to an existing [hash] *)
@@ -77,15 +83,15 @@ val import : t -> string list -> string Lwt_stream.t -> hash Lwt.t
 (** [import t path stream] adds a WebAssembly module from the given stream *)
 
 val hash : t -> string list -> hash option Lwt.t
-(** [hash t path] returns the hash associated the the value stored at [path],
-    if it exists *)
+(** [hash t path] returns the hash associated the the value stored at [path], if
+    it exists *)
 
 val remove : t -> string list -> unit Lwt.t
 (** [remove t path] deletes [path] *)
 
 val list : t -> string list -> (string list * hash) list Lwt.t
-(** [list t path] returns a list of modules stored under [path]. This function does not accept
-    a hash parameter in place of [path] *)
+(** [list t path] returns a list of modules stored under [path]. This function
+    does not accept a hash parameter in place of [path] *)
 
 val contains : t -> string list -> bool Lwt.t
 (** [contains t path] returns true if [path] exists *)
@@ -94,14 +100,14 @@ val gc : t -> int Lwt.t
 (** [gc t] runs the GC and returns the number of objects deleted.
 
     When the gc is executed for a branch all prior commits are squashed into one
-    and all non-reachable objects are removed. For example, if an object is still
-    reachable from another branch it will not be deleted. Because of this, running
-    the garbage collector may purge prior commits, potentially causing `restore`
-    to fail. *)
+    and all non-reachable objects are removed. For example, if an object is
+    still reachable from another branch it will not be deleted. Because of this,
+    running the garbage collector may purge prior commits, potentially causing
+    `restore` to fail. *)
 
 val get_hash_and_filename : t -> string list -> (hash * string) option Lwt.t
-(** [get_hash_and_filename t path] returns a tuple containing the hash and the filename
-    of the object disk relative to the root path *)
+(** [get_hash_and_filename t path] returns a tuple containing the hash and the
+    filename of the object disk relative to the root path *)
 
 val merge : t -> string -> (unit, Irmin.Merge.conflict) result Lwt.t
 (** [merge t branch] merges [branch] into [t] *)
@@ -160,13 +166,14 @@ module Server : sig
     ?port:int ->
     t ->
     unit Lwt.t
-  (** [run ~cors ~auth ~host ~port t] starts the server on [host:port]
-      If [auth] is empty then no authentication is required, otherwise the client should
+  (** [run ~cors ~auth ~host ~port t] starts the server on [host:port] If [auth]
+      is empty then no authentication is required, otherwise the client should
       provide a key using the [Wasmstore-Auth] header. [auth] is a mapping from
       authentication keys to allowed request methods (or [*] as a shortcut for
-      any method). The `cors` parameters will enable CORS when set to true, allowing for
-      browser-based Javascript clients to make requests agains the database.
+      any method). The `cors` parameters will enable CORS when set to true,
+      allowing for browser-based Javascript clients to make requests agains the
+      database.
 
-      Additionally, the [Wasmstore-Branch] header can used to determine which branch
-      to access on any non-[/branch] endpoints *)
+      Additionally, the [Wasmstore-Branch] header can used to determine which
+      branch to access on any non-[/branch] endpoints *)
 end

test/wasmstore.t

@@ -19,8 +19,12 @@ Add wasm module `b`
   $ wasmstore add b.wasm
   d926c50304238d423d63f52f5f460b1a7170fe870e10f031b9cbd74b29bc06e5
 
+Store contains `b`
+  $ wasmstore contains b.wasm
+  true
+
 Make sure the store contains the hash and path
-  $ wasmstore contains 0312a97e84150ab77401b72f951f8af63a05062781ce06c905d5626c615d1bc2
+  $ wasmstore contains b6b033aa8c568449d19e0d440cd31f8fcebaebc9c28070e09073275d8062be31
   true
   $ wasmstore contains a.wasm
   true
@@ -108,3 +112,25 @@ Backup
   $ tar tzf ./backup.tar.gz | grep 'objects/65/8830c0dfcc89d80c695357f0774eb20ca47adb4286eedd52eb527f9cf03fd5'
   ./objects/65/8830c0dfcc89d80c695357f0774eb20ca47adb4286eedd52eb527f9cf03fd5
 
+Add `a` again
+  $ wasmstore add a.wasm testing/123
+  b6b033aa8c568449d19e0d440cd31f8fcebaebc9c28070e09073275d8062be31
+
+Contains `a`
+  $ wasmstore contains testing/123
+  true
+
+Remove `a` by hash
+  $ wasmstore remove b6b033aa8c568449d19e0d440cd31f8fcebaebc9c28070e09073275d8062be31
+
+No longer contains `a`
+  $ wasmstore contains b6b033aa8c568449d19e0d440cd31f8fcebaebc9c28070e09073275d8062be31
+  false
+
+No longer contains `a`
+  $ wasmstore contains testing/123
+  false
+
+No longer contains `a`
+  $ wasmstore find b6b033aa8c568449d19e0d440cd31f8fcebaebc9c28070e09073275d8062be31 > /dev/null
+  [1]

wasmstore.opam

@@ -19,7 +19,7 @@ depends: [
   "lwt"
   "lwt_eio"
   "eio_main"
-  "cohttp-lwt-unix"
+  "cohttp-lwt-unix" {>= "6.0.0~alpha2"}
   "fmt"
   "logs"
   "websocket"