├── .gitignore
├── .travis.yml
├── CHANGES.md
├── LICENSE.md
├── Makefile
├── README.md
├── dune-project
├── irmin-indexeddb.opam
├── lib
    ├── branch_store.ml
    ├── config.ml
    ├── content_store.ml
    ├── dune
    ├── html_storage.ml
    ├── html_storage.mli
    ├── irmin_indexeddb.ml
    ├── irmin_indexeddb.mli
    ├── js_api.ml
    ├── raw.ml
    ├── raw.mli
    ├── utf8_codec.ml
    ├── utf8_codec.mli
    └── utils.ml
├── test.html
└── test
    ├── dune
    ├── helpers.js
    ├── test.ml
    └── v3_db.ml


/.gitignore:
--------------------------------------------------------------------------------
1 | _build
2 | .merlin
3 | 


--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: c
2 | sudo: required
3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
4 | script: bash -ex .travis-opam.sh
5 | env:
6 |   - OCAML_VERSION=4.08 PINS="irmin-git.2.0.0:https://github.com/talex5/irmin.git#2.0.0-cuekeeper"
7 | 


--------------------------------------------------------------------------------
/CHANGES.md:
--------------------------------------------------------------------------------
  1 | ## dev
  2 | 
  3 | Update to Irmin 2.3 API, which includes `clear` functions for emptying both the
  4 | raw contents and branch stores.
  5 | 
  6 | `Content_store` has been split into `Content_store_git` and
  7 | `Content_store_non_git`, as we now need to know whether to add the Git header
  8 | when writing.
  9 | 
 10 | ## v2.0
 11 | 
 12 | Update to Irmin 2.0 API. This way that stores are constructed has changed in Irmin 2.0.
 13 | Now, irmin-indexeddb just provides the raw contents and branch stores and the application
 14 | uses these to create a full Irmin store. This means that you can use irmin-indexeddb to
 15 | create either Git-format or Irmin-format stores, and you can avoid a dependency on irmin-git
 16 | if you don't need Git-format stores.
 17 | 
 18 | For Irmin format, use e.g.:
 19 | 
 20 | ```ocaml
 21 | module I = Irmin.Make(Irmin_indexeddb.Content_store)(Irmin_indexeddb.Branch_store)
 22 |     (Irmin.Metadata.None)(Irmin.Contents.String)
 23 |     (Irmin.Path.String_list)(Irmin.Branch.String)(Irmin.Hash.SHA256)
 24 | ```
 25 | 
 26 | For a Git format store, use:
 27 | 
 28 | ```ocaml
 29 | module I = Irmin_git.Generic(Irmin_indexeddb.Content_store)(Irmin_indexeddb.Branch_store)
 30 |     (Irmin.Contents.String)(Irmin.Path.String_list)(Irmin.Branch.String)
 31 | ```
 32 | 
 33 | If you have an existing database created by an older version of
 34 | irmin-indexeddb, then you *must* create a Git-format store.
 35 | 
 36 | ## v1.3
 37 | 
 38 | Update to Irmin 1.3 API.
 39 | 
 40 | ## v1.0
 41 | 
 42 | This version updates irmin-indexeddb to use the Irmin 1.0 API. This is a major
 43 | breaking change to the API because the Irmin API changed a lot in 1.0. When
 44 | upgrading from irmin-indexeddb 0.6, existing databases can still be read. To
 45 | upgrade from earlier releases you must first upgrade to v0.6 and let it convert
 46 | the data from the Irmin 0.10 format to Git format.
 47 | 
 48 | Attempting to open an old-format database using this version will raise the
 49 | exception `Format_too_old Irmin_0_10`. If your application used to use versions
 50 | of irmin-indexeddb before v0.6 then you should catch this and tell users to
 51 | first upgrade to a version of your application that uses v0.6.
 52 | 
 53 | Note that it is no longer possible to pass a custom hash to `Make`. `Irmin_git`
 54 | now always uses SHA1, for compatibilty with Git. It is not possible to upgrade
 55 | from a database using a different hash (I'm not aware of anyone using a different
 56 | hash).
 57 | 
 58 | Due to some missing type equalities in `irmin_git`, you will need to pin this
 59 | branch too:
 60 | 
 61 |     opam pin add irmin-git.1.0.0 https://github.com/talex5/irmin.git#1.0.0-cuekeeper
 62 | 
 63 | ## v0.6
 64 | 
 65 | Data is now stored using the standard Git format, rather than the Irmin 0.10
 66 | custom format. This means that it is possible to export the data and read it
 67 | with Git and also that it is now possible to move to newer versions of Irmin
 68 | without losing data.
 69 | 
 70 | This version will convert any existing data to Git format, translating the old
 71 | `ao`/`rw` stores to new-format `ao_git`/`rw_git` stores. On my machine, converting
 72 | my CueKeeper history from 2015-03-09 to now (15,193 commits) took about 20
 73 | minutes in Firefox. You can provide a `log` argument to the new `create_full`
 74 | function to provide progress updates to users during the migration.
 75 | 
 76 | If the migration is interrupted (e.g. by closing the browser tab) then it will
 77 | restart from the beginning next time. The old-format stores remain after the
 78 | migration, in case something goes wrong.
 79 | 
 80 | The migration updates the schema version from 2 to 3, so that old versions of
 81 | this library will refuse to access it (so the old stores become effectively
 82 | read-only). The next version of this library will upgrade the version from 3 to
 83 | 4 and delete the old-format stores. Newer versions of this library will refuse
 84 | to touch stores in the old format 2.
 85 | 
 86 | It is not easy to install this version of irmin-indexeddb because it requires
 87 | various pinned libraries. See the `.travis.yml` for the exact versions required.
 88 | 
 89 | ## v0.5
 90 | 
 91 | Note: this release still uses Irmin 0.10.x, which is very out-of-date now.
 92 | However, this is a first step towards fixing the bit-rot.
 93 | 
 94 | - Update `js_of_ocaml` 2 -> 3.
 95 | - Update `base64` 2 -> 3.
 96 | - Upgrade opam 1 -> 2.
 97 | - Convert from oasis to dune.
 98 | 
 99 | ## v0.4
100 | 
101 | Release never completed.
102 | Was intended to support the now-obsolete Irmin 0.11.0 format.
103 | 
104 | ## v0.3
105 | 
106 | - Updated for Irmin 0.10.0.
107 | 


--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2019 Thomas Leonard <talex5@gmail.com>
 2 | 
 3 | Permission to use, copy, modify, and distribute this software for any
 4 | purpose with or without fee is hereby granted, provided that the above
 5 | copyright notice and this permission notice appear in all copies.
 6 | 
 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | .PHONY: all clean
2 | 
3 | build:
4 | 	dune build _build/default/test/test.bc.js
5 | 
6 | clean:
7 | 	dune clean
8 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | Irmin-IndexedDB
 2 | ===============
 3 | 
 4 | Copyright Thomas Leonard, 2020
 5 | 
 6 | This is an Irmin backend that stores the data in the web-browser's IndexedDB store.
 7 | 
 8 | 
 9 | Instructions
10 | ------------
11 | 
12 | You can create stores using either the standard Git format, or using Irmin's own format.
13 | For Git format (you'll need to add `irmin-git` as a dependency), use:
14 | 
15 | ```ocaml
16 | (* A Git-format store. This data can be exported and used with the regular Git
17 |    tools. It can also read data produced by older versions of irmin-indexeddb. *)
18 | module I = Irmin_git.Generic(Irmin_indexeddb.Content_store_git)(Irmin_indexeddb.Branch_store)
19 |     (Irmin.Contents.String)(Irmin.Path.String_list)(Irmin.Branch.String)
20 | ```
21 | 
22 | For Irmin format, use:
23 | 
24 | ```ocaml
25 | (* An Irmin-format store. This allows storing custom metadata or using
26 |    different hash functions, but is not compatible with the Git tools or with
27 |    databases created by older versions of irmin-indexeddb. *)
28 | module I = Irmin.Make(Irmin_indexeddb.Content_store_non_git)(Irmin_indexeddb.Branch_store)
29 |     (Irmin.Metadata.None)(Irmin.Contents.String)(Irmin.Path.String_list)(Irmin.Branch.String)(Irmin.Hash.SHA256)
30 | ```
31 | 
32 | To create a store, use e.g.
33 | 
34 |     let () =
35 |       let config = Irmin_indexeddb.config "MyProg" in
36 |       I.v config make_task >>= fun store ->
37 |       ...
38 | 
39 | The argument to `Irmin_indexeddb.config` is the name of the database to use.
40 | 
41 | Note: In order to provide notifications (to instances running in other tabs),
42 | the backend will also write the current branch head hash into HTML local
43 | storage.
44 | 
45 | 
46 | Bugs
47 | ----
48 | 
49 | Please any send questions or comments to the mirage mailing list:
50 | 
51 | http://lists.xenproject.org/cgi-bin/mailman/listinfo/mirageos-devel
52 | 
53 | Bugs can be reported on the mailing list or as GitHub issues:
54 | 
55 | https://github.com/talex5/irmin-indexeddb/issues
56 | 
57 | 
58 | Conditions
59 | ----------
60 | 
61 | See [LICENSE.md](LICENSE.md).
62 | 
63 | 
64 | [mirage]: https://mirage.io
65 | 


--------------------------------------------------------------------------------
/dune-project:
--------------------------------------------------------------------------------
1 | (lang dune 1.11)
2 | (name irmin-indexeddb)
3 | 


--------------------------------------------------------------------------------
/irmin-indexeddb.opam:
--------------------------------------------------------------------------------
 1 | opam-version: "2.0"
 2 | name: "irmin-indexeddb"
 3 | synopsis: "Irmin backend using the web-browser's IndexedDB store"
 4 | maintainer: "Thomas Leonard <talex5@gmail.com>"
 5 | authors: "Thomas Leonard <talex5@gmail.com>"
 6 | license: "ISC"
 7 | homepage: "https://github.com/talex5/irmin-indexeddb"
 8 | bug-reports: "https://github.com/talex5/irmin-indexeddb/issues"
 9 | depends: [
10 |   "ocaml" {>= "4.8.0"}
11 |   "dune" {>= "1.11"}
12 |   "base64" {>= "3.0.0"}
13 |   "irmin" {>= "2.6.0" & < "3.0.0"}
14 |   "irmin-git" {with-test}
15 |   "cstruct" {>= "1.7.0"}
16 |   "fmt" {>= "0.8.7"}
17 |   "js_of_ocaml" {>= "4.0.0"}
18 |   "js_of_ocaml-lwt"
19 |   "js_of_ocaml-ppx"
20 |   "git"
21 |   "lwt"
22 | ]
23 | build: [
24 |   ["dune" "build" "-p" name "-j" jobs]
25 |   ["dune" "runtest" "-p" name "-j" jobs] {with-test}
26 |   ["dune" "build" "-p" name "@doc"] {with-doc}
27 | ]
28 | dev-repo: "git+https://github.com/talex5/irmin-indexeddb.git"
29 | doc: "https://talex5.github.io/irmin-indexeddb/"
30 | description: """
31 | This is an Irmin backend that stores the data in the web-browser's IndexedDB store.
32 | For more information, see <http://roscidus.com/blog/blog/2015/06/22/cuekeeper-internals-irmin/>
33 | """
34 | 


--------------------------------------------------------------------------------
/lib/branch_store.ml:
--------------------------------------------------------------------------------
  1 | (* Copyright (C) 2020, Thomas Leonard.
  2 |    See the README file for details. *)
  3 | 
  4 | open Lwt.Infix
  5 | open Js_of_ocaml
  6 | 
  7 | module Make (K: Irmin.Type.S) (V: Irmin.Type.S) = struct
  8 |   module W = Irmin.Private.Watch.Make(K)(V)
  9 | 
 10 |   module Key = K
 11 |   module Val = V
 12 | 
 13 |   type key = K.t
 14 |   type value = V.t
 15 |   type watch = W.watch
 16 | 
 17 |   let string_of_key = Irmin.Type.to_string K.t
 18 | 
 19 |   let key_of_string s =
 20 |     match Irmin.Type.of_string K.t s with
 21 |     | Ok k -> k
 22 |     | Error (`Msg m) -> failwith m
 23 | 
 24 |   type t = {
 25 |     r : Raw.store;
 26 |     watch : W.t;
 27 |     prefix : string;
 28 |     notifications : Html_storage.t;
 29 |     mutable listener : (Dom.event_listener_id * int) option;
 30 |   }
 31 | 
 32 |   let v config =
 33 |     let db_name = Irmin.Private.Conf.get config Config.db_name_key in
 34 |     Config.connect db_name >|= fun idb ->
 35 |     let prefix = db_name ^ ".rw." in
 36 |     let watch = W.v () in
 37 |     let notifications = Html_storage.make () in
 38 |     let r = Raw.store idb Config.rw in
 39 |     { watch; r; prefix; notifications; listener = None }
 40 | 
 41 |   let string_of_hash = Irmin.Type.(unstage (to_bin_string V.t))
 42 | 
 43 |   let hash_of_string =
 44 |     let value_of_string = Irmin.Type.(unstage (of_bin_string V.t)) in
 45 |     fun x ->
 46 |       match value_of_string x with
 47 |       | Ok x -> x
 48 |       | Error (`Msg m) -> failwith m
 49 | 
 50 |   let find t k =
 51 |     Raw.get t.r (string_of_key k) >|= function
 52 |     | None -> None
 53 |     | Some s -> Some (hash_of_string s)
 54 | 
 55 |   let mem t k =
 56 |     Raw.get t.r (string_of_key k) >|= function
 57 |     | None -> false
 58 |     | Some _ -> true
 59 | 
 60 |   let list t =
 61 |     Raw.bindings t.r >|=
 62 |     List.map (fun (k, _v) -> key_of_string k)
 63 | 
 64 |   let ref_listener t =
 65 |     match t.listener with
 66 |     | None ->
 67 |         let l =
 68 |           Html_storage.watch t.notifications ~prefix:t.prefix (fun key value ->
 69 |             let subkey = Utils.tail key (String.length t.prefix) in
 70 |             let ir_key = key_of_string subkey in
 71 |             let value = Utils.option_map hash_of_string value in
 72 |             Lwt.async (fun () -> W.notify t.watch ir_key value)
 73 |           ) in
 74 |         t.listener <- Some (l, 1)
 75 |     | Some (l, n) ->
 76 |         t.listener <- Some (l, n + 1)
 77 | 
 78 |   let unref_listener t =
 79 |     match t.listener with
 80 |     | None -> failwith "unref_listener, but not listening!"
 81 |     | Some (l, 1) ->
 82 |         Dom.removeEventListener l;
 83 |         t.listener <- None
 84 |     | Some (l, n) ->
 85 |         assert (n > 1);
 86 |         t.listener <- Some (l, n - 1)
 87 | 
 88 |   let notify t k new_value =
 89 |     (* Notify other tabs *)
 90 |     begin match new_value with
 91 |     | None -> Html_storage.remove t.notifications (t.prefix ^ string_of_key k)
 92 |     | Some v -> Html_storage.set t.notifications (t.prefix ^ string_of_key k) (string_of_hash v)
 93 |     end;
 94 |     (* Notify this tab *)
 95 |     W.notify t.watch k new_value
 96 | 
 97 |   let set t k value =
 98 |     (* Log.warn "Non-atomic update called!"; *)
 99 |     string_of_hash value
100 |     |> Raw.set t.r (string_of_key k) >>= fun () ->
101 |     notify t k (Some value)
102 | 
103 |   let remove t k =
104 |     (* Log.warn "Non-atomic remove called!"; *)
105 |     Raw.remove t.r (string_of_key k) >>= fun () ->
106 |     notify t k None
107 | 
108 |   let test_and_set t k ~test ~set =
109 |     let pred old =
110 |       match old, test with
111 |       | None, None -> true
112 |       | Some old, Some expected -> old = string_of_hash expected
113 |       | _ -> false in
114 |     let new_value = Utils.option_map string_of_hash set in
115 |     Raw.compare_and_set t.r (string_of_key k) ~test:pred ~new_value >>= function
116 |     | true -> notify t k set >|= fun () -> true
117 |     | false -> Lwt.return false
118 | 
119 |   let watch t ?init cb =
120 |     ref_listener t;
121 |     W.watch t.watch ?init cb
122 | 
123 |   let unwatch t w =
124 |     unref_listener t;
125 |     W.unwatch t.watch w
126 | 
127 |   let watch_key t key ?init cb =
128 |     ref_listener t;
129 |     W.watch_key t.watch key ?init cb
130 | 
131 |   let clear t =
132 |     list t >>= fun keys ->
133 |     Raw.clear t.r >>= fun () ->
134 |     Lwt_list.iter_s (fun k -> notify t k None) keys
135 | 
136 |   let close _ = Lwt.return_unit
137 | end
138 | 


--------------------------------------------------------------------------------
/lib/config.ml:
--------------------------------------------------------------------------------
 1 | (* Copyright (C) 2020, Thomas Leonard.
 2 |    See the README file for details. *)
 3 | 
 4 | let db_name_key =
 5 |   Irmin.Private.Conf.(key "indexeddb_db_name" string "Irmin")
 6 | 
 7 | (* These were the stores used in schema version 2 to store the data. *)
 8 | let ao_old = Raw.store_name "ao"
 9 | let rw_old = Raw.store_name "rw"
10 | 
11 | (* These stores were used in schema version 3 to store the data after
12 |    migrating it to Git format. We now use them even for non-Git-format data,
13 |    since with Irmin 2.0 we don't know how the store will be used. *)
14 | let ao = Raw.store_name "ao_git"
15 | let rw = Raw.store_name "rw_git"
16 | 
17 | exception Format_too_old of [`Irmin_0_10]
18 | 
19 | let version = 4
20 | let connect db_name =
21 |   Raw.make db_name ~version ~init:(fun ~old_version upgrader ->
22 |     match old_version with
23 |     | 0 ->
24 |       Raw.create_store upgrader ao;
25 |       Raw.create_store upgrader rw
26 |     | 2 ->
27 |       raise (Format_too_old `Irmin_0_10)
28 |     | 3 ->
29 |       (* Remove old stores from 2->3 migration. *)
30 |       Raw.delete_store upgrader ao_old;
31 |       Raw.delete_store upgrader rw_old
32 |     | _ ->
33 |       failwith "Attempt to upgrade from unknown schema version!"
34 |   )
35 | 
36 | let v db_name = Irmin.Private.Conf.singleton db_name_key db_name
37 | 


--------------------------------------------------------------------------------
/lib/content_store.ml:
--------------------------------------------------------------------------------
 1 | (* Copyright (C) 2020, Thomas Leonard.
 2 |    See the README file for details. *)
 3 | 
 4 | open Lwt.Infix
 5 | 
 6 | module Make (K : Irmin.Hash.S) (V : Irmin.Type.S) = struct
 7 |   type 'a t = Raw.store
 8 |   type key = K.t
 9 |   type value = V.t
10 | 
11 |   let string_of_hash = Irmin.Type.to_string K.t
12 | 
13 |   let value_of_string =
14 |     let value_of_string = Irmin.Type.(unstage (of_bin_string V.t)) in
15 |     fun s ->
16 |       match value_of_string s with
17 |       | Ok x -> x
18 |       | Error (`Msg m) -> failwith m
19 | 
20 |   let string_of_value = Irmin.Type.(unstage (to_bin_string V.t))
21 | 
22 |   let find t k =
23 |     Raw.get t (string_of_hash k) >|= function
24 |     | None -> None
25 |     | Some s -> Some (value_of_string s)
26 | 
27 |   let mem t k =
28 |     Raw.get t (string_of_hash k) >|= function
29 |     | None -> false
30 |     | Some _ -> true
31 | 
32 |   let unsafe_add t key value =
33 |     let value = string_of_value value in
34 |     Raw.set t (string_of_hash key) value
35 | 
36 |   let add t value =
37 |     let value = string_of_value value in
38 |     let k = K.hash (fun add -> add value) in
39 |     Raw.set t (string_of_hash k) value >|= fun () -> k
40 | 
41 |   let batch t fn = fn t
42 | 
43 |   let clear t = Raw.clear t
44 | 
45 |   let close _ = Lwt.return_unit
46 | 
47 |   let v config =
48 |     let db_name = Irmin.Private.Conf.get config Config.db_name_key in
49 |     Config.connect db_name >|= fun idb ->
50 |     Raw.store idb Config.ao
51 | end
52 | 


--------------------------------------------------------------------------------
/lib/dune:
--------------------------------------------------------------------------------
1 | (library
2 |  (public_name irmin-indexeddb)
3 |  (name irmin_indexeddb)
4 |  (preprocess (pps js_of_ocaml-ppx))
5 |  (libraries lwt irmin js_of_ocaml js_of_ocaml-lwt base64))
6 | 


--------------------------------------------------------------------------------
/lib/html_storage.ml:
--------------------------------------------------------------------------------
 1 | (* Copyright (C) 2015, Thomas Leonard.
 2 |  * See the README file for details. *)
 3 | 
 4 | open Js_of_ocaml
 5 | 
 6 | class type storageEvent =
 7 |   object
 8 |     inherit Dom_html.event
 9 |     method key : Js.js_string Js.t Js.readonly_prop
10 |     method oldValue : Js.js_string Js.t Js.opt Js.readonly_prop
11 |     method newValue : Js.js_string Js.t Js.opt Js.readonly_prop
12 |     method url : Js.js_string Js.t Js.readonly_prop
13 |     method storageArea : Dom_html.storage Js.t Js.opt Js.readonly_prop
14 |   end
15 | 
16 | type t = Dom_html.storage Js.t
17 | type key = string
18 | 
19 | let make () =
20 |   Js.Optdef.get Dom_html.window##.localStorage
21 |     (fun () -> failwith "HTML 5 storage is not available")
22 | 
23 | let get t key =
24 |   Js.Opt.case (t##getItem (Js.string key))
25 |     (fun () -> None)
26 |     (fun v -> Some (Js.to_string v |> Utf8_codec.decode))
27 | 
28 | let set t key value =
29 |   let encoded = Utf8_codec.encode value |> Js.string in
30 |   t##setItem (Js.string key) encoded
31 | 
32 | let remove t key =
33 |   t##removeItem (Js.string key)
34 | 
35 | let event = Dom.Event.make "storage"
36 | 
37 | let key (ev:#storageEvent Js.t) = ev##.key
38 | 
39 | let watch t ~prefix fn =
40 |   let on_change (ev : storageEvent Js.t) =
41 |     if ev##.storageArea = Js.Opt.return t then (
42 |       let k = key ev in
43 |       if k##lastIndexOf_from (Js.string prefix) 0 = 0 then (
44 |         let k = Js.to_string k in
45 |         let v =
46 |           Js.Opt.case ev##.newValue
47 |             (fun () -> None)
48 |             (fun v ->
49 |               Some (Js.to_string v |> Utf8_codec.decode)) in
50 |         fn k v
51 |       )
52 |     );
53 |     Js._true in
54 |   Dom.addEventListener Dom_html.window event (Dom.handler on_change) Js._true
55 | 


--------------------------------------------------------------------------------
/lib/html_storage.mli:
--------------------------------------------------------------------------------
 1 | (* Copyright (C) 2015, Thomas Leonard
 2 |  * See the README file for details. *)
 3 | 
 4 | open Js_of_ocaml
 5 | 
 6 | type t
 7 | type key = string
 8 | 
 9 | val make : unit -> t
10 | val get : t -> key -> string option
11 | val set : t -> key -> string -> unit
12 | val remove : t -> key -> unit
13 | 
14 | val watch : t -> prefix:string -> (key -> string option -> unit) -> Dom.event_listener_id
15 | 


--------------------------------------------------------------------------------
/lib/irmin_indexeddb.ml:
--------------------------------------------------------------------------------
 1 | (* Copyright (C) 2020, Thomas Leonard.
 2 |    See the README file for details. *)
 3 | 
 4 | module Content_store_non_git = Content_store.Make
 5 | module Branch_store = Branch_store.Make
 6 | module Raw = Raw
 7 | 
 8 | module Content_store_git (K : Irmin.Hash.S) (V : Irmin.Type.S) =
 9 |   Content_store_non_git (K) (struct type t = V.t let t = Irmin.Type.boxed V.t end)
10 | 
11 | let config = Config.v
12 | 
13 | exception Format_too_old = Config.Format_too_old
14 | 


--------------------------------------------------------------------------------
/lib/irmin_indexeddb.mli:
--------------------------------------------------------------------------------
 1 | (* Copyright (C) 2020, Thomas Leonard
 2 |    See the README file for details. *)
 3 | 
 4 | (** An Irmin backend that stores data in an IndexedDB.
 5 |     Use [Irmin_git.Generic] to create a Git-format store, or [Irmin.Make] for an Irmin-format one. *)
 6 | 
 7 | val config : string -> Irmin.config
 8 | (** [config db_name] is a configuration that stores all values in the given IndexedDB database. *)
 9 | 
10 | module Content_store_git : Irmin.CONTENT_ADDRESSABLE_STORE_MAKER
11 | (** The content-addressable store stores blobs, trees and commits.
12 |     
13 |     This is for use with [Irmin_git] (it always writes boxed values with the Git header). *)
14 | 
15 | module Content_store_non_git : Irmin.CONTENT_ADDRESSABLE_STORE_MAKER
16 | (** The content-addressable store stores blobs, trees and commits.
17 | 
18 |     This is not for use with [Irmin_git], since it doesn't include the Git header. *)
19 | 
20 | module Branch_store : Irmin.ATOMIC_WRITE_STORE_MAKER
21 | (** The branch store records the head commit hash for each branch. *)
22 | 
23 | exception Format_too_old of [`Irmin_0_10]
24 | (** Raised on creation if the existing data format cannot be read by this version of irmin-indexeddb.
25 |     To migrate Irmin 0.10 format data, upgrade to irmin-indexeddb version 0.6 first.
26 |     Note: to be able to read old databases you must use a Git-format store. *)
27 | 
28 | module Raw = Raw
29 | (** Direct access to the stores. This is intended only for use in unit-tests. *)
30 | 


--------------------------------------------------------------------------------
/lib/js_api.ml:
--------------------------------------------------------------------------------
  1 | (* Copyright (C) 2015, Thomas Leonard.
  2 |  * See the README file for details. *)
  3 | 
  4 | (** js_of_ocaml type declarations for the w3c IndexedDB spec: http://www.w3.org/TR/IndexedDB/
  5 |  * Currently only covers the bits needed for CueKeeper.
  6 |  * IndexedDB_lwt provides a more friendly API. *)
  7 | 
  8 | open Js_of_ocaml
  9 | 
 10 | (* Note: we currently assume all keys and values are strings.
 11 |  * This will always be the case for entries added using this interface. *)
 12 | type key = Js.js_string Js.t
 13 | type value = Js.js_string Js.t
 14 | type store_name = Js.js_string Js.t
 15 | type mode = Js.js_string Js.t
 16 | 
 17 | class type versionChangeEvent = object
 18 |   inherit Dom_html.event
 19 | 
 20 |   method oldVersion : int Js.readonly_prop
 21 |   method newVersion : int Js.readonly_prop Js.Opt.t
 22 | end
 23 | class type ['a] errorEvent = object
 24 |   inherit ['a] Dom.event
 25 | end
 26 | class type completeEvent = object
 27 |   inherit Dom_html.event
 28 | end
 29 | class type successEvent = object
 30 |   inherit Dom_html.event
 31 | end
 32 | 
 33 | class type cursor = object
 34 |   method key : key Js.readonly_prop
 35 |   method continue : unit Js.meth
 36 | end
 37 | class type cursorWithValue = object
 38 |   inherit cursor
 39 |   method value : value Js.readonly_prop
 40 | end
 41 | 
 42 | class type dom_exception = object
 43 |   (* Being a bit paranoid marking all these as optdef *)
 44 |   method name : Js.js_string Js.t Js.Optdef.t Js.readonly_prop
 45 |   method message : Js.js_string Js.t Js.Optdef.t Js.readonly_prop
 46 |   method code : int Js.Optdef.t Js.readonly_prop
 47 | end
 48 | 
 49 | class type request = object
 50 |   method error : dom_exception Js.t Js.Opt.t Js.readonly_prop
 51 |   method onerror : ('self Js.t, request errorEvent Js.t) Dom.event_listener Js.prop
 52 |   method onsuccess : ('self Js.t, successEvent Js.t) Dom.event_listener Js.prop
 53 | end
 54 | 
 55 | class type getRequest = object ('self)
 56 |   inherit request
 57 |   method result : value Js.Optdef.t Js.readonly_prop
 58 | end
 59 | 
 60 | class type openCursorRequest = object
 61 |   inherit request
 62 |   method result : cursorWithValue Js.t Js.Opt.t Js.readonly_prop
 63 | end
 64 | 
 65 | class type objectStore = object
 66 |   method add : value -> key -> request Js.t Js.meth
 67 |   method put : value -> key -> request Js.t Js.meth
 68 |   method delete : key -> request Js.t Js.meth
 69 |   method clear : unit -> request Js.t Js.meth
 70 |   method get : key -> getRequest Js.t Js.meth
 71 |   method openCursor : openCursorRequest Js.t Js.meth
 72 | end
 73 | 
 74 | class type transaction = object
 75 |   method oncomplete : ('self Js.t, completeEvent Js.t) Dom.event_listener Js.prop
 76 |   method onerror : ('self Js.t, request errorEvent Js.t) Dom.event_listener Js.prop
 77 |   method onabort : ('self Js.t, request errorEvent Js.t) Dom.event_listener Js.prop
 78 |   method objectStore : store_name -> objectStore Js.t Js.meth
 79 |   method abort : unit Js.meth
 80 | end
 81 | 
 82 | class type database = object
 83 |   method close : unit Js.meth
 84 |   method createObjectStore : store_name -> objectStore Js.t Js.meth
 85 |   method deleteObjectStore : store_name -> unit Js.meth
 86 |   method onerror : ('self Js.t, request errorEvent Js.t) Dom.event_listener Js.prop
 87 |   method transaction : store_name Js.js_array Js.t -> mode -> transaction Js.t Js.meth
 88 | end
 89 | 
 90 | class type openDBRequest = object ('self)
 91 |   inherit request
 92 |   method onupgradeneeded : ('self Js.t, versionChangeEvent Js.t) Dom_html.event_listener Js.prop
 93 |   method onblocked : ('self Js.t, versionChangeEvent Js.t) Dom_html.event_listener Js.prop
 94 |   method result : database Js.t Js.readonly_prop
 95 | end
 96 | 
 97 | class type factory = object
 98 |   method _open : Js.js_string Js.t -> int -> openDBRequest Js.t Js.meth
 99 |   method deleteDatabase : Js.js_string Js.t -> openDBRequest Js.t Js.meth
100 | end
101 | 


--------------------------------------------------------------------------------
/lib/raw.ml:
--------------------------------------------------------------------------------
  1 | (* Copyright (C) 2015, Thomas Leonard.
  2 |  * See the README file for details. *)
  3 | 
  4 | open Lwt
  5 | open Js_of_ocaml
  6 | module Lwt_js = Js_of_ocaml_lwt.Lwt_js
  7 | 
  8 | type db = Js_api.database Js.t
  9 | type store_name = Js.js_string Js.t
 10 | 
 11 | type store = {
 12 |   db : db;
 13 |   store_name : store_name;
 14 | 
 15 |   (* We reuse transactions where possible for performance.
 16 |    * This does mean that if any read fails then the others will hang, but we treat any
 17 |    * read failing as a fatal error anyway. *)
 18 |   mutable ro_trans : (Js_api.transaction Js.t * (exn -> unit) list ref) option;
 19 | }
 20 | 
 21 | type key = string
 22 | type db_name = string
 23 | type db_upgrader = Js_api.database Js.t
 24 | let store_name = Js.string
 25 | 
 26 | let opt_string x ~if_missing =
 27 |   Js.Optdef.case x
 28 |     (fun () -> if_missing)
 29 |     (fun x -> Js.to_string x)
 30 | 
 31 | exception AbortError
 32 | 
 33 | let idb_error typ (event:Js_api.request Js_api.errorEvent Js.t) =
 34 |   let failure msg = Failure (Printf.sprintf "IndexedDB operation (%s) failed: %s" typ msg) in
 35 |   Js.Opt.case event##.target
 36 |     (fun () -> failure "(missing target on error event)")
 37 |     (fun target ->
 38 |       Js.Opt.case target##.error
 39 |         (fun () -> failure "(missing error on request)")
 40 |         (fun error ->
 41 |           let name = opt_string error##.name ~if_missing:"(no name)" in
 42 |           let message = opt_string error##.message ~if_missing:"(no message)" in
 43 |           let code = Js.Optdef.get error##.code (fun () -> 0) in
 44 |           if name = "AbortError" then AbortError
 45 |           else failure (Printf.sprintf "%s: %s (error code %d)" name message code)
 46 |         )
 47 |     )
 48 | 
 49 | let get_factory () =
 50 |   let factory : Js_api.factory Js.t Js.Optdef.t = (Obj.magic Dom_html.window)##.indexedDB in
 51 |   Js.Optdef.get factory
 52 |     (fun () -> failwith "IndexedDB not available")
 53 | 
 54 | let make db_name ~version ~init =
 55 |   let factory = get_factory () in
 56 |   let request = factory##_open (Js.string db_name) version in
 57 |   let t, set_t = Lwt.wait () in
 58 |   request##.onblocked := Dom.handler (fun _event ->
 59 |     print_endline "Waiting for other IndexedDB users to close their connections before upgrading schema version.";
 60 |     Js._true
 61 |   );
 62 |   request##.onupgradeneeded := Dom.handler (fun event ->
 63 |     try
 64 |       let old_version = event##.oldVersion in
 65 |       init ~old_version request##.result;
 66 |       Js._true
 67 |     with ex ->
 68 |       (* Firefox throws the exception away and returns AbortError instead, so save it here. *)
 69 |       Lwt.wakeup_exn set_t ex;
 70 |       raise ex
 71 |   );
 72 |   request##.onerror := Dom.handler (fun event ->
 73 |     begin match Lwt.state t, idb_error "open" event with
 74 |     | Fail _, AbortError -> ()   (* Already reported a better exception *)
 75 |     | _, ex -> Lwt.wakeup_exn set_t ex
 76 |     end;
 77 |     Js._true
 78 |   );
 79 |   request##.onsuccess := Dom.handler (fun _event ->
 80 |     Lwt.wakeup set_t request##.result;
 81 |     Js._true
 82 |   );
 83 |   t
 84 | 
 85 | let close db =
 86 |   db##close
 87 | 
 88 | let delete_database db_name =
 89 |   let factory = get_factory () in
 90 |   let request = factory##deleteDatabase (Js.string db_name) in
 91 |   let t, set_t = Lwt.wait () in
 92 |   request##.onerror := Dom.handler (fun _event ->
 93 |     Lwt.wakeup_exn set_t (Failure "Error trying to delete IndexedDB database");
 94 |     Js._true
 95 |   );
 96 |   request##.onsuccess := Dom.handler (fun _event ->
 97 |     Lwt.wakeup set_t ();
 98 |     Js._true
 99 |   );
100 |   t
101 | 
102 | let store db store_name = { db; store_name; ro_trans = None }
103 | 
104 | let create_store db name =
105 |   db##createObjectStore name |> ignore
106 | 
107 | let delete_store db name =
108 |   db##deleteObjectStore name
109 | 
110 | let rec trans_ro (t:store) setup =
111 |   let r, set_r = Lwt.wait () in
112 |   match t.ro_trans with
113 |   | None ->
114 |       let breakers = ref [Lwt.wakeup_exn set_r] in
115 |       let trans = t.db##transaction (Js.array [| t.store_name |]) (Js.string "readonly") in
116 |       t.ro_trans <- Some (trans, breakers);
117 |       trans##.onerror := Dom.handler (fun event ->
118 |         t.ro_trans <- None;
119 |         let ex = idb_error "RO" event in
120 |         if ex = AbortError then
121 |           print_endline "IndexedDB transaction failed (Safari bug?): will wait and retry";
122 |         !breakers |> List.iter (fun b -> b ex);
123 |         Js._true
124 |       );
125 |       trans##.oncomplete := Dom.handler (fun _event ->
126 |         t.ro_trans <- None;
127 |         Js._true
128 |       );
129 |       setup (trans##objectStore t.store_name) set_r;
130 |       r
131 |   | Some (trans, breakers) ->
132 |       (* Seems we can get here when a transaction is done but oncomplete hasn't been called,
133 |        * so retry if we get an error. *)
134 |       try
135 |         setup (trans##objectStore t.store_name) set_r;
136 |         breakers := Lwt.wakeup_exn set_r :: !breakers;
137 |         r
138 |       with _ex ->
139 |         t.ro_trans <- None;
140 |         trans_ro t setup
141 | 
142 | (* On Safari, transactions can fail unpredictably, so wrap [trans_ro] with auto-retry.
143 |  * See: https://github.com/talex5/cuekeeper/issues/9 *)
144 | let trans_ro t setup =
145 |   let rec retry delay =
146 |     Lwt.catch (fun () -> trans_ro t setup)
147 |       (function
148 |         | AbortError -> Lwt_js.sleep (Random.float delay) >>= fun () -> retry (delay *. 1.2)
149 |         | ex -> fail ex) in
150 |   retry 1.0
151 | 
152 | let trans_rw t setup =
153 |   let r, set_r = Lwt.wait () in
154 |   let trans = t.db##transaction (Js.array [| t.store_name |]) (Js.string "readwrite") in
155 |   trans##.onerror := Dom.handler (fun event ->
156 |     Lwt.wakeup_exn set_r (idb_error "RW" event);
157 |     Js._true
158 |   );
159 |   trans##.onabort := Dom.handler (fun event ->
160 |     Lwt.wakeup_exn set_r (idb_error "RW" event);
161 |     Js._true
162 |   );
163 |   trans##.oncomplete := Dom.handler (fun _event ->
164 |     Lwt.wakeup set_r ();
165 |     Js._true
166 |   );
167 |   setup (trans##objectStore t.store_name);
168 |   r
169 | 
170 | let bindings t =
171 |   let bindings = ref [] in
172 |   trans_ro t
173 |     (fun store set_r ->
174 |       let request = store##openCursor in
175 |       request##.onsuccess := Dom.handler (fun _event ->
176 |         Js.Opt.case request##.result
177 |           (fun () -> Lwt.wakeup set_r !bindings)
178 |           (fun cursor ->
179 |             let key = cursor##.key |> Js.to_string in
180 |             let value = cursor##.value |> Js.to_string |> Utf8_codec.decode in
181 |             bindings := (key, value) :: !bindings;
182 |             cursor##continue
183 |           );
184 |         Js._true
185 |       )
186 |     )
187 | 
188 | let set t key value =
189 |   trans_rw t (fun store ->
190 |     store##put (Js.string (Utf8_codec.encode value)) (Js.string key) |> ignore
191 |   )
192 | 
193 | let remove t key =
194 |   trans_rw t
195 |     (fun store ->
196 |       store##delete (Js.string key) |> ignore
197 |     )
198 | 
199 | let clear t =
200 |   trans_rw t
201 |     (fun store ->
202 |       store##clear () |> ignore
203 |     )
204 | 
205 | let get t key =
206 |   trans_ro t
207 |     (fun store set_r ->
208 |       let request = store##get (Js.string key) in
209 |       request##.onsuccess := Dom.handler (fun _event ->
210 |         Js.Optdef.case request##.result
211 |           (fun () -> None)
212 |           (fun s -> Some (Js.to_string s |> Utf8_codec.decode))
213 |         |> Lwt.wakeup set_r;
214 |         Js._true
215 |       )
216 |     )
217 | 
218 | let compare_and_set t key ~test ~new_value =
219 |   let result = ref None in
220 |   let key = Js.string key in
221 |   trans_rw t
222 |     (fun store ->
223 |       let request = store##get key in
224 |       request##.onsuccess := Dom.handler (fun _event ->
225 |           let actual =
226 |             Utils.option_map (fun x -> Js.to_string x |> Utf8_codec.decode)
227 |               (Js.Optdef.to_option request##.result)
228 |         in
229 |         if test actual then (
230 |           begin match new_value with
231 |           | None -> store##delete key |> ignore
232 |           | Some new_value -> store##put (Js.string (Utf8_codec.encode new_value)) key |> ignore end;
233 |           result := Some true
234 |         ) else (
235 |           result := Some false
236 |         );
237 |         Js._true
238 |       )
239 |     )
240 |   >|= fun () ->
241 |   match !result with
242 |   | None -> failwith "Transaction completed, but no result!"
243 |   | Some x -> x
244 | 


--------------------------------------------------------------------------------
/lib/raw.mli:
--------------------------------------------------------------------------------
 1 | (* Copyright (C) 2015, Thomas Leonard.
 2 |    See the README file for details. *)
 3 | 
 4 | (** Friendly OCaml/Lwt abstraction over IndexedDB. *)
 5 | 
 6 | type db
 7 | type db_upgrader
 8 | type key = string
 9 | type db_name = string
10 | type store
11 | type store_name
12 | 
13 | val store_name : string -> store_name
14 | 
15 | val make : db_name -> version:int -> init:(old_version:int -> db_upgrader -> unit) -> db Lwt.t
16 | (** Connect to database [db_name]. If it doesn't yet exist or is for an older version, calls [init] to initialise it first. *)
17 | 
18 | val close : db -> unit
19 | (** Begin closing the connection (returns immediately). *)
20 | 
21 | val delete_database : db_name -> unit Lwt.t
22 | 
23 | val create_store : db_upgrader -> store_name -> unit
24 | val delete_store : db_upgrader -> store_name -> unit
25 | 
26 | val store : db -> store_name -> store
27 | 
28 | val get : store -> key -> string option Lwt.t
29 | val set : store -> key -> string -> unit Lwt.t
30 | 
31 | val compare_and_set : store -> key -> test:(string option -> bool) -> new_value:string option -> bool Lwt.t
32 | (** If [test current_value] for returns true for the current value of [key], replace it with [new_value].
33 |  * If [new_value] is None, the key is deleted.
34 |  * This happens in a single atomic transaction. *)
35 | 
36 | val remove : store -> key -> unit Lwt.t
37 | val clear : store -> unit Lwt.t
38 | val bindings : store -> (key * string) list Lwt.t
39 | 


--------------------------------------------------------------------------------
/lib/utf8_codec.ml:
--------------------------------------------------------------------------------
 1 | (* From https://github.com/mirage/ezjsonm.
 2 |  * Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org> *)
 3 | let is_valid_utf8 str =
 4 |   try
 5 |     Uutf.String.fold_utf_8 (fun () _ -> function
 6 |       | `Malformed _ -> raise Exit
 7 |       | _ -> ()
 8 |     ) () str;
 9 |     true
10 |   with Exit -> false
11 | 
12 | module B64 = struct
13 |   let encode s =
14 |     match Base64.encode s with
15 |     | Ok x -> x
16 |     | Error (`Msg m) -> failwith m    (* Encoding can't really fail *)
17 | 
18 |   let decode s =
19 |     match Base64.decode s with
20 |     | Ok x -> x
21 |     | Error (`Msg m) -> failwith ("B64.decode: " ^ m)
22 | end
23 | 
24 | let encode s =
25 |   if is_valid_utf8 s then "\"" ^ s
26 |   else "%" ^ B64.encode s
27 | 
28 | let decode s =
29 |   match s.[0] with
30 |   | '%' -> B64.decode (Utils.tail s 1)
31 |   | '"' -> Utils.tail s 1
32 |   | _ -> B64.decode s            (* Old format, base64 *)
33 | 


--------------------------------------------------------------------------------
/lib/utf8_codec.mli:
--------------------------------------------------------------------------------
1 | (* If the data is valid UTF-8 then store it directly (prefixed with '"').
2 |    Otherwise, encode with Base64 (and prefix with "%"). *)
3 | val encode : string -> string
4 | val decode : string -> string
5 | 


--------------------------------------------------------------------------------
/lib/utils.ml:
--------------------------------------------------------------------------------
 1 | (* Copyright (C) 2015, Thomas Leonard.
 2 |  * See the README file for details. *)
 3 | 
 4 | let tail s i =
 5 |   String.sub s i (String.length s - i)
 6 | 
 7 | let option_map f = function
 8 |   | None -> None
 9 |   | Some x -> Some (f x)
10 | 


--------------------------------------------------------------------------------
/test.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html lang="en">
 3 |   <head>
 4 |     <meta charset="utf-8">
 5 |     <title>Irmin-IndexedDB test page</title>
 6 |   </head>
 7 |   <body>
 8 |     <p>If the JavaScript is working, you should see some output here:</p>
 9 |     <pre id='main'></pre>
10 |     <script type="text/javascript" src="_build/default/test/test.bc.js"></script>
11 |   </body>
12 | </html>
13 | 


--------------------------------------------------------------------------------
/test/dune:
--------------------------------------------------------------------------------
1 | (executable
2 |  (name test)
3 |  (modes js)
4 |  (preprocess (pps js_of_ocaml-ppx))
5 |  (js_of_ocaml (javascript_files helpers.js))
6 |  (libraries checkseum.ocaml digestif.ocaml irmin_indexeddb irmin-git))
7 | 


--------------------------------------------------------------------------------
/test/helpers.js:
--------------------------------------------------------------------------------
 1 | //Provides: caml_encore_is_a_sub
 2 | function caml_encore_is_a_sub(va, valen, vb, vblen) {
 3 | 	var a = va.data.buffer;
 4 | 	var b = vb.data.buffer;
 5 | 	var astart = va.data.byteOffset;
 6 | 	var bstart = vb.data.byteOffset;
 7 | 	return a === b && astart >= bstart && astart + valen <= bstart + vblen
 8 | }
 9 | 
10 | //Provides: caml_encore_bigarray_equal
11 | function caml_encore_bigarray_equal(va, vb) {
12 | 	var a = va.data.buffer;
13 | 	var b = vb.data.buffer;
14 | 	return a === b
15 | }
16 | 


--------------------------------------------------------------------------------
/test/test.ml:
--------------------------------------------------------------------------------
  1 | open Lwt
  2 | open Js_of_ocaml
  3 | module Lwt_js_events = Js_of_ocaml_lwt.Lwt_js_events
  4 | module Raw = Irmin_indexeddb.Raw
  5 | 
  6 | (* A Git-format store. This data can be exported and used with the regular Git
  7 |    tools. It can also read data produced by older versions of irmin-indexeddb. *)
  8 | module I = Irmin_git.Generic(Irmin_indexeddb.Content_store_git)(Irmin_indexeddb.Branch_store)
  9 |     (Irmin.Contents.String)(Irmin.Path.String_list)(Irmin.Branch.String)
 10 | 
 11 | (* An Irmin-format store. This allows storing custom metadata or using
 12 |    different hash functions, but is not compatible with the Git tools or with
 13 |    databases created by older versions of irmin-indexeddb. *)
 14 | module Plain = Irmin.Make(Irmin_indexeddb.Content_store_non_git)(Irmin_indexeddb.Branch_store)
 15 |     (Irmin.Metadata.None)(Irmin.Contents.String)(Irmin.Path.String_list)(Irmin.Branch.String)(Irmin.Hash.SHA256)
 16 | 
 17 | let key = ["key"]
 18 | 
 19 | let keys_of_store (type t) (module Store : Irmin.KV with type t = t) (t : t) =
 20 |   Store.list t []
 21 |   >|= List.map (fun (k, subtree) ->
 22 |       let kind =
 23 |         match Store.Tree.destruct subtree with
 24 |         | `Node _ -> `Node
 25 |         | `Contents _ -> `Contents
 26 |       in
 27 |       (k, kind))
 28 | 
 29 | let db_name = "Irmin_IndexedDB_test"
 30 | let upgrade_db_name = "Irmin_IndexedDB_t2"
 31 | let import_db_name = "Irmin_IndexedDB_t3"
 32 | let plain_db_name = "Irmin_IndexedDB_test_plain"
 33 | 
 34 | let start main =
 35 |   let document = Dom_html.document in
 36 |   let print fmt =
 37 |     let add msg =
 38 |       let node = document##createTextNode (Js.string (msg ^ "\n")) in
 39 |       Dom.appendChild main node |> ignore in
 40 |     Fmt.kstr add fmt in
 41 | 
 42 |   let expect ~fmt expected actual =
 43 |     if expected = actual then (
 44 |       print "Got %a, as expected" fmt expected;
 45 |       Lwt.return_unit
 46 |     ) else (
 47 |       print "Got %a, but expected %a!" fmt actual fmt expected;
 48 |       failwith "Tests FAILED"
 49 |     )
 50 |   in
 51 | 
 52 |   let expect_str = expect ~fmt:Fmt.(quote string) in
 53 |   let key_list f xs =
 54 |     let pp_item f (step, _) = Fmt.string f step in
 55 |     Fmt.pf f "[%a]"
 56 |       (Fmt.(list ~sep:(any ",")) pp_item) xs in
 57 | 
 58 |   let dump_bindings db store_name =
 59 |     let store_id = Raw.store_name store_name in
 60 |     let store = Raw.store db store_id in
 61 |     print "let %s = [" store_name;
 62 |     Raw.bindings store >|= fun bindings ->
 63 |     bindings |> List.iter (fun (name, value) ->
 64 |       print "  %S, %S;" name value
 65 |     );
 66 |     print "]" in
 67 | 
 68 |   let load_bindings db store_name bindings =
 69 |     let store_id = Raw.store_name store_name in
 70 |     let store = Raw.store db store_id in
 71 |     bindings |> Lwt_list.iter_s (fun (name, value) ->
 72 |       Raw.set store name value
 73 |     ) in
 74 | 
 75 |   Lwt.catch (fun () ->
 76 |     print "Irmin-IndexedDB test";
 77 | 
 78 |     print "Deleting any previous test databases...";
 79 |     Raw.delete_database db_name >>= fun () ->
 80 |     Raw.delete_database upgrade_db_name >>= fun () ->
 81 |     Raw.delete_database import_db_name >>= fun () ->
 82 |     Raw.delete_database plain_db_name >>= fun () ->
 83 | 
 84 |     let info () = Irmin.Info.v "Test message" ~date:0L ~author:"Test <example.com>" in
 85 |     begin
 86 |       let config = Irmin_indexeddb.config plain_db_name in
 87 |       Plain.Repo.v config >>= Plain.master >>= fun store ->
 88 |       print "Created Irmin-format basic store. Checking it is empty...";
 89 |       keys_of_store (module Plain) store >>= expect ~fmt:key_list [] >>= fun () ->
 90 |       Plain.set_exn ~info store key "value" >>= fun () ->
 91 |       print "Added test item. Reading it back...";
 92 |       Plain.get store key >>= expect_str "value" >>= fun () ->
 93 | 
 94 |       print "Listing contents...";
 95 |       keys_of_store (module Plain) store >>= expect ~fmt:key_list ["key", `Contents] >>= fun () ->
 96 | 
 97 |       Plain.Head.find store >>= function
 98 |       | None -> assert false
 99 |       | Some head ->
100 |       print "Head: %a" Plain.Commit.pp_hash head;
101 |       expect ~fmt:Fmt.(quote string) "Test message" @@ Irmin.Info.message @@ Plain.Commit.info head >>= fun () ->
102 |       Plain.set_exn ~info store key "value3" >>= fun () ->
103 |       Plain.history store >>= fun hist ->
104 |       Plain.History.iter_succ (fun head ->
105 |         print "Parent: %a" Plain.Commit.pp_hash head
106 |       ) hist head;
107 | 
108 |       print "Dumping DB contents... (ignore _git suffix)";
109 | 
110 |       Raw.make plain_db_name ~version:4 ~init:(fun ~old_version:_ _ -> assert false) >>= fun db ->
111 |       dump_bindings db "ao_git" >>= fun () ->
112 |       dump_bindings db "rw_git" >|= fun () ->
113 |       Raw.close db
114 |     end >>= fun () ->
115 | 
116 |     begin
117 |       let config = Irmin_indexeddb.config db_name in
118 |       I.Repo.v config >>= I.master >>= fun store ->
119 |       print "Created Git-format basic store. Checking it is empty...";
120 |       keys_of_store (module I) store >>= expect ~fmt:key_list [] >>= fun () ->
121 |       I.set_exn ~info store key "value" >>= fun () ->
122 |       print "Added test item. Reading it back...";
123 |       I.get store key >>= expect_str "value" >>= fun () ->
124 | 
125 |       print "Listing contents...";
126 |       keys_of_store (module I) store >>= expect ~fmt:key_list ["key", `Contents] >>= fun () ->
127 | 
128 |       I.Head.find store >>= function
129 |       | None -> assert false
130 |       | Some head ->
131 |       print "Head: %a" I.Commit.pp_hash head;
132 |       expect ~fmt:Fmt.(quote string) "Test message" @@ Irmin.Info.message @@ I.Commit.info head >>= fun () ->
133 |       I.set_exn ~info store key "value3" >>= fun () ->
134 |       I.history store >>= fun hist ->
135 |       I.History.iter_succ (fun head ->
136 |         print "Parent: %a" I.Commit.pp_hash head
137 |       ) hist head;
138 | 
139 |       print "Dumping DB contents...";
140 | 
141 |       Raw.make db_name ~version:4 ~init:(fun ~old_version:_ _ -> assert false) >>= fun db ->
142 |       dump_bindings db "ao_git" >>= fun () ->
143 |       dump_bindings db "rw_git" >|= fun () ->
144 |       Raw.close db
145 |     end >>= fun () ->
146 | 
147 |     print "Testing ability to read v3 format db";
148 |     begin
149 |       print "Importing old db dump...";
150 |       let init ~old_version upgrader =
151 |         assert (old_version = 0);
152 |         Raw.(create_store upgrader (store_name "ao"));
153 |         Raw.(create_store upgrader (store_name "rw"));
154 |         Raw.(create_store upgrader (store_name "ao_git"));
155 |         Raw.(create_store upgrader (store_name "rw_git")) in
156 |       Raw.make upgrade_db_name ~version:3 ~init >>= fun db ->
157 |       load_bindings db "ao" V3_db.ao >>= fun () ->
158 |       load_bindings db "rw" V3_db.rw >>= fun () ->
159 |       load_bindings db "ao_git" V3_db.ao_git >>= fun () ->
160 |       load_bindings db "rw_git" V3_db.rw_git >>= fun () ->
161 |       Raw.close db;
162 | 
163 |       print "Opening old db...";
164 |       let config = Irmin_indexeddb.config upgrade_db_name in
165 |       I.Repo.v config >>= fun up_repo ->
166 |       I.master up_repo >>= fun up_store ->
167 |       I.get up_store key >>= expect_str "value2" >>= fun () ->
168 | 
169 |       print "Exporting old db...";
170 |       I.Repo.export up_repo >>= fun slice ->
171 |       I.Head.find up_store >>= function
172 |       | None -> assert false
173 |       | Some head ->
174 |       return (slice, head)
175 |     end >>= fun (slice, head) ->
176 | 
177 |     begin
178 |       Raw.make upgrade_db_name ~version:4 ~init:(fun ~old_version:_ _ -> assert false) >>= fun db ->
179 |       dump_bindings db "ao_git" >>= fun () ->
180 |       dump_bindings db "rw_git"
181 |     end >>= fun () ->
182 | 
183 |     begin
184 |       let config = Irmin_indexeddb.config import_db_name in
185 |       I.Repo.v config >>= fun repo ->
186 |       I.master repo >>= fun store ->
187 |       print "Created new store. Checking it is empty...";
188 |       I.list store [] >>= expect ~fmt:key_list [] >>= fun () ->
189 | 
190 |       print "Importing from bundle...";
191 |       I.Repo.import repo slice >>= function
192 |       | Error (`Msg m) -> Fmt.failwith "Error importing slice: %s" m
193 |       | Ok () ->
194 | 
195 |       I.Head.fast_forward store head >>= function
196 |       | Error _ -> Fmt.failwith "fast_forward_head failed"
197 |       | Ok () ->
198 |       print "Checking import worked...";
199 |       keys_of_store (module I) store >>= expect ~fmt:key_list ["key", `Contents]
200 |     end >>= fun () ->
201 | 
202 |     print "Success!";
203 |     return ()
204 |   ) (fun ex ->
205 |     print "ERROR: %s" (Printexc.to_string ex);
206 |     raise ex
207 |   )
208 | 
209 | let () =
210 |   match Dom_html.tagged (Dom_html.getElementById "main") with
211 |   | Dom_html.Pre main -> Lwt_js_events.async (fun () -> start main)
212 |   | _ -> failwith "Bad 'main' element"
213 | 


--------------------------------------------------------------------------------
/test/v3_db.ml:
--------------------------------------------------------------------------------
 1 | (* A version 3 store, created by migrating a version 2 store. *)
 2 | 
 3 | let ao = [
 4 |   "f32b67c7e26342af42efabc674d441dca0a281c5", "value";
 5 |   "8ae477e323829308b188cae97d0ed5eaf47495ce", "\001\020a\132[\142\252.K\168\1553\195\252Br\212\028DW?\251\001\020\137\183\172\026T\196\180it\192\234\018\164T\129\195&Vb\236\253\024g\204U\001\004User\001\004test";
 6 |   "89b7ac1a54c4b46974c0ea12a45481c3265662ec", "\001\020B\004+\227\249\1681d|E\155\163\236O\180\183<\161\201\227\000\253\024g\204U\001\004User\001\004test";
 7 |   "61845b8efc2e4ba89b33c3fc4272d41c44573ffb", "\001\003key\000\020C\247\1709\015\026\002e\252-\231\001\0013\149\028\007\024\166~";
 8 |   "5ba93c9db0cff93f52b521d7420e43f6eda2784f", "\000";
 9 |   "43f7aa390f1a0265fc2de7010133951c0718a67e", "value2";
10 |   "42042be3f9a831647c459ba3ec4fb4b73ca1c9e3", "\001\003key\000\020\243+g\199\226cB\175B\239\171\198t\212A\220\160\162\129\197";
11 | ]
12 | let ao_git = [
13 |   "a984ad7a8eb212ee25a1fb7d6381c4004e1df247", "tree 31\000100644 key\000j`=B\219\234\246\012H\017C\018\227\202\227Q\140\2056\190";
14 |   "6a603d42dbeaf60c48114312e3cae3518ccd36be", "blob 6\000value2";
15 |   "4f605fcdb9c6d5f1738f443572788974da9d0f39", "commit 206\000tree a984ad7a8eb212ee25a1fb7d6381c4004e1df247\nparent 48b22d046c9e0f66ac9d3a65be95135192a9df66\nauthor User <irmin@openmirage.org> 1439459096 +0000\ncommitter User <irmin@openmirage.org> 1439459096 +0000\n\ntest";
16 |   "48b22d046c9e0f66ac9d3a65be95135192a9df66", "commit 158\000tree 33b327f3872113c362f0952f020ca59ffd92a289\nauthor User <irmin@openmirage.org> 1439459096 +0000\ncommitter User <irmin@openmirage.org> 1439459096 +0000\n\ntest";
17 |   "33b327f3872113c362f0952f020ca59ffd92a289", "tree 31\000100644 key\000(\144\238\173#\223\018\245/)\029\143b&w\172N\219\154+";
18 |   "2890eead23df12f52f291d8f622677ac4edb9a2b", "blob 5\000value";
19 | ]
20 | let rw = [
21 |   "master", "\020\138\228w\227#\130\147\b\177\136\202\233}\014\213\234\244t\149\206";
22 | ]
23 | let rw_git = [
24 |   "master", "O`_\205\185\198\213\241s\143D5rx\137t\218\157\0159";
25 | ]
26 | 


--------------------------------------------------------------------------------