futur.blue
objective categorical abstract machine language personal data server
Initial MST/CAR test
+2
-3
ipld/lib/car.ml
+2
-3
ipld/lib/car.ml
+2
-2
ipld/lib/cid.ml
+2
-2
ipld/lib/cid.ml
+2
-2
ipld/lib/dag_cbor.ml
+2
-2
ipld/lib/dag_cbor.ml
···
30
let rec of_yojson (json : Yojson.Safe.t) : value =
31
match json with
32
| `Assoc [("$bytes", `String s)] ->
33
-
`Bytes (Bytes.of_string (Base64.decode_exn s))
34
| `Assoc [("$link", `String s)] ->
35
`Link (Result.get_ok (Cid.of_string s))
36
| `Assoc assoc_list ->
···
67
| `Boolean b ->
68
`Bool b
69
| `Integer i ->
70
-
`Intlit (Int64.to_string i)
71
| `Float f ->
72
`Float f
73
| `String s ->
···
30
let rec of_yojson (json : Yojson.Safe.t) : value =
31
match json with
32
| `Assoc [("$bytes", `String s)] ->
33
+
`Bytes (Bytes.of_string (Base64.decode_exn ~pad:false s))
34
| `Assoc [("$link", `String s)] ->
35
`Link (Result.get_ok (Cid.of_string s))
36
| `Assoc assoc_list ->
···
67
| `Boolean b ->
68
`Bool b
69
| `Integer i ->
70
+
`Int (Int64.to_int i)
71
| `Float f ->
72
`Float f
73
| `String s ->
+4
-4
ipld/test/test_dag_cbor.ml
+4
-4
ipld/test/test_dag_cbor.ml
···
388
389
let test_yojson_roundtrip () =
390
let record_embed_images_0_aspect_ratio : Yojson.Safe.t =
391
-
`Assoc [("height", `Intlit "885"); ("width", `Intlit "665")]
392
in
393
let record_embed_images_0_image : Yojson.Safe.t =
394
`Assoc
395
-
[ ("height", `Intlit "885")
396
-
; ("width", `Intlit "665")
397
; ("mimeType", `String "image/jpeg")
398
-
; ("size", `Intlit "645553") ]
399
in
400
let record_embed_images_0 : Yojson.Safe.t =
401
`Assoc
···
388
389
let test_yojson_roundtrip () =
390
let record_embed_images_0_aspect_ratio : Yojson.Safe.t =
391
+
`Assoc [("height", `Int 885); ("width", `Int 665)]
392
in
393
let record_embed_images_0_image : Yojson.Safe.t =
394
`Assoc
395
+
[ ("height", `Int 885)
396
+
; ("width", `Int 665)
397
; ("mimeType", `String "image/jpeg")
398
+
; ("size", `Int 645553) ]
399
in
400
let record_embed_images_0 : Yojson.Safe.t =
401
`Assoc
+110
-14
mist/lib/mst.ml
+110
-14
mist/lib/mst.ml
···
161
let decode_block_raw b : node_raw =
162
match Dag_cbor.decode b with
163
| `Map node ->
164
if not (StringMap.mem "e" node) then
165
raise (Invalid_argument "mst node missing 'e'") ;
166
let l =
···
378
Lwt.return path_tail ) )
379
380
(* returns all mst entries in order for a car stream *)
381
-
let to_blocks_seq t : (Cid.t * bytes) Lwt_seq.t =
382
let module M = struct
383
type stage =
384
(* currently walking nodes *)
385
| Nodes of
386
{ next: Cid.t list (* next cids to fetch *)
387
; fetched: (Cid.t * bytes) list (* fetched cids and their bytes *)
388
-
; leaves: Cid.Set.t (* seen leaf cids *) }
389
(* done walking nodes, streaming accumulated leaves *)
390
| Leaves of (Cid.t * bytes) list
391
| Done
392
end in
393
let open M in
394
let init_state =
395
-
Nodes {next= [t.root]; fetched= []; leaves= Cid.Set.empty}
396
in
397
let rec step = function
398
| Done ->
···
401
| Nodes ({fetched= (cid, bytes) :: rest; _} as s) ->
402
Lwt.return_some ((cid, bytes), Nodes {s with fetched= rest})
403
(* need to fetch next nodes *)
404
-
| Nodes {next; fetched= []; leaves} ->
405
if List.is_empty next then (
406
(* finished traversing nodes, time to switch to leaves *)
407
-
let leaves_list = Cid.Set.to_list leaves in
408
let%lwt leaves_bm = Store.get_blocks t.blockstore leaves_list in
409
if leaves_bm.missing <> [] then failwith "missing mst leaf blocks" ;
410
-
let leaves_nodes = Block_map.entries leaves_bm.blocks in
411
match leaves_nodes with
412
| [] ->
413
(* with Done, we don't care about the first pair element *)
···
419
(* go ahead and fetch the next nodes *)
420
let%lwt bm = Store.get_blocks t.blockstore next in
421
if bm.missing <> [] then failwith "missing mst nodes" ;
422
-
let fetched, next', leaves' =
423
List.fold_left
424
-
(fun (acc, nxt, lvs) cid ->
425
let bytes =
426
(* we should be safe to do this since we just got the cids from the blockmap *)
427
Block_map.get cid bm.blocks |> Option.get
···
440
nxt )
441
node.e
442
in
443
-
let lvs' =
444
-
(* add each entry in this node to the list of seen leaves *)
445
-
List.fold_left (fun s e -> Cid.Set.add e.v s) lvs node.e
446
in
447
(* prepending is O(1) per prepend + one O(n) to reverse, vs. O(n) per append = O(n^2) total *)
448
-
((cid, bytes) :: acc, nxt', lvs') )
449
-
([], [], leaves) next
450
in
451
step
452
(Nodes
453
{ next= List.rev next'
454
; fetched= List.rev fetched
455
-
; leaves= leaves' } )
456
(* if we're onto yielding leaves, do that *)
457
| Leaves ((cid, bytes) :: rest) ->
458
let next = if rest = [] then Done else Leaves rest in
···
462
Lwt.return_some (Obj.magic (), Done)
463
in
464
Lwt_seq.unfold_lwt step init_state
465
466
(* returns all mst nodes needed to prove the value of a given key *)
467
let rec proof_for_key t root key : Block_map.t Lwt.t =
···
743
let adds, updates, deletes = merge prev_leaves curr_leaves [] [] [] in
744
Lwt.return
745
{adds; updates; deletes; new_mst_blocks; new_leaf_cids; removed_cids}
746
end
···
161
let decode_block_raw b : node_raw =
162
match Dag_cbor.decode b with
163
| `Map node ->
164
+
Yojson.Safe.pretty_print Format.std_formatter
165
+
(Dag_cbor.to_yojson (`Map node)) ;
166
if not (StringMap.mem "e" node) then
167
raise (Invalid_argument "mst node missing 'e'") ;
168
let l =
···
380
Lwt.return path_tail ) )
381
382
(* returns all mst entries in order for a car stream *)
383
+
let to_blocks_stream t : (Cid.t * bytes) Lwt_seq.t =
384
let module M = struct
385
type stage =
386
(* currently walking nodes *)
387
| Nodes of
388
{ next: Cid.t list (* next cids to fetch *)
389
; fetched: (Cid.t * bytes) list (* fetched cids and their bytes *)
390
+
; leaves_seen: Cid.Set.t (* seen leaf cids for dedupe *)
391
+
; leaves_rev: Cid.t list (* reversed encounter order of leaves *) }
392
(* done walking nodes, streaming accumulated leaves *)
393
| Leaves of (Cid.t * bytes) list
394
| Done
395
end in
396
let open M in
397
let init_state =
398
+
Nodes
399
+
{next= [t.root]; fetched= []; leaves_seen= Cid.Set.empty; leaves_rev= []}
400
in
401
let rec step = function
402
| Done ->
···
405
| Nodes ({fetched= (cid, bytes) :: rest; _} as s) ->
406
Lwt.return_some ((cid, bytes), Nodes {s with fetched= rest})
407
(* need to fetch next nodes *)
408
+
| Nodes {next; fetched= []; leaves_seen; leaves_rev} ->
409
if List.is_empty next then (
410
(* finished traversing nodes, time to switch to leaves *)
411
+
let leaves_list = List.rev leaves_rev in
412
let%lwt leaves_bm = Store.get_blocks t.blockstore leaves_list in
413
if leaves_bm.missing <> [] then failwith "missing mst leaf blocks" ;
414
+
let leaves_nodes =
415
+
List.map
416
+
(fun cid ->
417
+
let bytes =
418
+
Block_map.get cid leaves_bm.blocks |> Option.get
419
+
in
420
+
(cid, bytes) )
421
+
leaves_list
422
+
in
423
match leaves_nodes with
424
| [] ->
425
(* with Done, we don't care about the first pair element *)
···
431
(* go ahead and fetch the next nodes *)
432
let%lwt bm = Store.get_blocks t.blockstore next in
433
if bm.missing <> [] then failwith "missing mst nodes" ;
434
+
let fetched, next', leaves_seen', leaves_rev' =
435
List.fold_left
436
+
(fun (acc, nxt, seen, rev) cid ->
437
let bytes =
438
(* we should be safe to do this since we just got the cids from the blockmap *)
439
Block_map.get cid bm.blocks |> Option.get
···
452
nxt )
453
node.e
454
in
455
+
let seen', rev' =
456
+
(* add each entry in this node to the seen set and record encounter order *)
457
+
List.fold_left
458
+
(fun (s, r) e ->
459
+
if Cid.Set.mem e.v s then (s, r)
460
+
else (Cid.Set.add e.v s, e.v :: r) )
461
+
(seen, rev) node.e
462
in
463
(* prepending is O(1) per prepend + one O(n) to reverse, vs. O(n) per append = O(n^2) total *)
464
+
((cid, bytes) :: acc, nxt', seen', rev') )
465
+
([], [], leaves_seen, leaves_rev)
466
+
next
467
in
468
step
469
(Nodes
470
{ next= List.rev next'
471
; fetched= List.rev fetched
472
+
; leaves_seen= leaves_seen'
473
+
; leaves_rev= leaves_rev' } )
474
(* if we're onto yielding leaves, do that *)
475
| Leaves ((cid, bytes) :: rest) ->
476
let next = if rest = [] then Done else Leaves rest in
···
480
Lwt.return_some (Obj.magic (), Done)
481
in
482
Lwt_seq.unfold_lwt step init_state
483
+
484
+
(* returns a car v1 formatted stream containing the mst *)
485
+
let to_car_stream t : bytes Lwt_seq.t =
486
+
t |> to_blocks_stream |> Car.blocks_to_stream (Some t.root)
487
+
488
+
(* returns a car archive containing the mst *)
489
+
let to_car t : bytes Lwt.t =
490
+
t |> to_blocks_stream |> Car.blocks_to_car (Some t.root)
491
492
(* returns all mst nodes needed to prove the value of a given key *)
493
let rec proof_for_key t root key : Block_map.t Lwt.t =
···
769
let adds, updates, deletes = merge prev_leaves curr_leaves [] [] [] in
770
Lwt.return
771
{adds; updates; deletes; new_mst_blocks; new_leaf_cids; removed_cids}
772
+
773
+
(* checks that two msts are identical by recursively comparing their entries *)
774
+
let equal (t1 : t) (t2 : t) : bool Lwt.t =
775
+
let rec nodes_equal (n1 : node) (n2 : node) : bool Lwt.t =
776
+
if n1.layer <> n2.layer then Lwt.return false
777
+
else if List.length n1.entries <> List.length n2.entries then
778
+
Lwt.return false
779
+
else
780
+
let%lwt left_equal =
781
+
n1.left
782
+
>>? function
783
+
| Some l1 -> (
784
+
n2.left
785
+
>>? function
786
+
| Some l2 ->
787
+
nodes_equal l1 l2
788
+
| None ->
789
+
Lwt.return false )
790
+
| None -> (
791
+
n2.left
792
+
>>? function
793
+
| Some _ ->
794
+
Lwt.return false
795
+
| None ->
796
+
Lwt.return true )
797
+
in
798
+
if not left_equal then Lwt.return false
799
+
else
800
+
let rec entries_equal (e1s : entry list) (e2s : entry list) =
801
+
match (e1s, e2s) with
802
+
| [], [] ->
803
+
Lwt.return true
804
+
| e1 :: rest1, e2 :: rest2 ->
805
+
if
806
+
e1.layer <> e2.layer || e1.key <> e2.key
807
+
|| not (Cid.equal e1.value e2.value)
808
+
then Lwt.return false
809
+
else
810
+
let%lwt right_equal =
811
+
e1.right
812
+
>>? function
813
+
| Some r1 -> (
814
+
e2.right
815
+
>>? function
816
+
| Some r2 ->
817
+
nodes_equal r1 r2
818
+
| None ->
819
+
Lwt.return false )
820
+
| None -> (
821
+
e2.right
822
+
>>? function
823
+
| Some _ ->
824
+
Lwt.return false
825
+
| None ->
826
+
Lwt.return true )
827
+
in
828
+
if not right_equal then Lwt.return false
829
+
else entries_equal rest1 rest2
830
+
| _ ->
831
+
Lwt.return false
832
+
in
833
+
entries_equal n1.entries n2.entries
834
+
in
835
+
match%lwt Lwt.all [retrieve_node t1 t1.root; retrieve_node t2 t2.root] with
836
+
| [Some r1; Some r2] ->
837
+
nodes_equal r1 r2
838
+
| [None; None] ->
839
+
Lwt.return true
840
+
| _ ->
841
+
Lwt.return false
842
end
+48
mist/lib/repository.ml
+48
mist/lib/repository.ml
···
···
1
+
type commit =
2
+
{ did: string
3
+
; version: int (* always 3 *)
4
+
; data: Cid.t
5
+
; rev: Tid.t
6
+
; prev: Cid.t option }
7
+
8
+
type signed_commit =
9
+
{ did: string
10
+
; version: int (* always 3 *)
11
+
; data: Cid.t [@of_yojson Cid.of_yojson] [@to_yojson Cid.to_yojson]
12
+
; rev: Tid.t
13
+
; prev: Cid.t option
14
+
[@of_yojson
15
+
function
16
+
| `Assoc link ->
17
+
link |> List.assoc "$link" |> Cid.of_yojson
18
+
|> Result.map (fun cid -> Some cid)
19
+
| `Null ->
20
+
Ok None
21
+
| _ ->
22
+
Error "commit prev not a valid cid"]
23
+
[@to_yojson function Some cid -> Cid.to_yojson cid | None -> `Null]
24
+
; signature: bytes
25
+
[@key "sig"]
26
+
[@of_yojson
27
+
fun x ->
28
+
match Dag_cbor.of_yojson x with
29
+
| `Bytes b ->
30
+
Ok b
31
+
| _ ->
32
+
Error "commit sig not a valid bytes value"]
33
+
[@to_yojson fun x -> Dag_cbor.to_yojson (`Bytes x)] }
34
+
[@@deriving yojson]
35
+
36
+
type signing_key = P256 of bytes | K256 of bytes
37
+
38
+
module Make (Store : Storage.Writable_blockstore) = struct
39
+
type store = Store.t
40
+
41
+
let read_commit store cid : (signed_commit, string) Lwt_result.t =
42
+
let%lwt bytes = Store.get_bytes store cid in
43
+
match bytes with
44
+
| Some b ->
45
+
b |> Dag_cbor.decode_to_yojson |> signed_commit_of_yojson |> Lwt.return
46
+
| None ->
47
+
Lwt.return_error ("commit not found in blockstore: " ^ Cid.to_string cid)
48
+
end
+6
-2
mist/test/dune
+6
-2
mist/test/dune
mist/test/sample.car
mist/test/sample.car
This is a binary file and will not be displayed.
+51
mist/test/test_mst.ml
+51
mist/test/test_mst.ml
···
···
1
+
open Mist
2
+
module MemMst = Mst.Make (Storage.Memory_blockstore)
3
+
module MemRepo = Repository.Make (Storage.Memory_blockstore)
4
+
5
+
let test_roundtrip () =
6
+
let open Lwt.Infix in
7
+
let mst_of_car_bytes bytes =
8
+
let%lwt roots, blocks = Car.read_car_stream (Lwt_seq.of_list [bytes]) in
9
+
let root =
10
+
match roots with
11
+
| [root] ->
12
+
root
13
+
| _ ->
14
+
failwith "expected exactly one root in car stream"
15
+
in
16
+
let%lwt bm =
17
+
Lwt_seq.fold_left
18
+
(fun acc (cid, bytes) -> Storage.Block_map.set cid bytes acc)
19
+
Storage.Block_map.empty blocks
20
+
in
21
+
let store = Storage.Memory_blockstore.create ~blocks:bm () in
22
+
let%lwt commit =
23
+
MemRepo.read_commit store root
24
+
>|= function Ok commit -> commit | Error msg -> failwith msg
25
+
in
26
+
let mst = MemMst.create store commit.data in
27
+
Lwt.return (commit, mst)
28
+
in
29
+
let%lwt ic = Lwt_io.open_file ~mode:Lwt_io.input "sample.car" in
30
+
let%lwt car = Lwt_io.read ic >|= Bytes.of_string in
31
+
let%lwt () = Lwt_io.close ic in
32
+
let%lwt commit, mst = mst_of_car_bytes car in
33
+
let mst_stream = MemMst.to_blocks_stream mst in
34
+
let commit_bytes =
35
+
Dag_cbor.encode_yojson (Repository.signed_commit_to_yojson commit)
36
+
in
37
+
let commit_cid = Cid.create Dcbor commit_bytes in
38
+
let%lwt car' =
39
+
Car.blocks_to_car (Some commit_cid)
40
+
(Lwt_seq.append (Lwt_seq.of_list [(commit_cid, commit_bytes)]) mst_stream)
41
+
in
42
+
let%lwt _, mst' = mst_of_car_bytes car' in
43
+
let%lwt eq = MemMst.equal mst mst' in
44
+
Lwt.return (Alcotest.(check bool) "mst roundtrip" true eq)
45
+
46
+
let () =
47
+
let open Alcotest in
48
+
run "mst"
49
+
[ ( "mst roundtrip"
50
+
, [ test_case "car→mst→car→mst roundtrip" `Quick (fun () ->
51
+
Lwt_main.run (test_roundtrip ()) ) ] ) ]
+1
-1
mist/test/test_tid.ml
+1
-1
mist/test/test_tid.ml