objective categorical abstract machine language personal data server
Implement base block storage classes
+185
-32
+8
mist/lib/lex.ml
+8
mist/lib/lex.ml
···
77
77
let encoded = Dag_cbor.encode ipld in
78
78
let cid = Cid.create Dcbor encoded in
79
79
(cid, encoded)
80
+
81
+
let of_cbor encoded : repo_record =
82
+
let decoded = Dag_cbor.decode encoded in
83
+
match of_ipld decoded with
84
+
| `LexMap m ->
85
+
m
86
+
| _ ->
87
+
raise (Failure "Decoded non-record value")
+6
-6
mist/lib/storage/block_map.ml
+6
-6
mist/lib/storage/block_map.ml
···
6
6
7
7
let empty = Cid_map.empty
8
8
9
-
let add m value =
9
+
let add value m =
10
10
let cid, bytes = Lex.to_cbor_block value in
11
11
(Cid_map.add cid bytes m, cid)
12
12
13
-
let set m cid bytes = Cid_map.add cid bytes m
13
+
let set = Cid_map.add
14
14
15
-
let get m cid = Cid_map.find_opt cid m
15
+
let get = Cid_map.find_opt
16
16
17
-
let remove m cid = Cid_map.remove cid m
17
+
let remove = Cid_map.remove
18
18
19
-
let get_many m cids =
19
+
let get_many cids m =
20
20
let blocks, missing =
21
21
List.fold_left
22
22
(fun (b, mis) cid ->
23
-
match get m cid with
23
+
match get cid m with
24
24
| Some bytes ->
25
25
(Cid_map.add cid bytes b, mis)
26
26
| None ->
+60
mist/lib/storage/memory_store.ml
+60
mist/lib/storage/memory_store.ml
···
1
+
open Lwt.Infix
2
+
3
+
module Make () = struct
4
+
type t =
5
+
{ mutable blocks: Block_map.t
6
+
; mutable root: Cid.t option
7
+
; mutable rev: string option }
8
+
9
+
let create ?(blocks = Block_map.empty) () = {blocks; root= None; rev= None}
10
+
11
+
let get_bytes s cid = Lwt.return (Block_map.get cid s.blocks)
12
+
13
+
let has s cid = Lwt.return (Block_map.has cid s.blocks)
14
+
15
+
let get_blocks s cids = Lwt.return (Block_map.get_many cids s.blocks)
16
+
17
+
let read_obj_and_bytes s cid =
18
+
get_bytes s cid
19
+
>|= function
20
+
| Some b ->
21
+
let v = Dag_cbor.decode b in
22
+
Some (v, b)
23
+
| None ->
24
+
None
25
+
26
+
let read_obj s cid = read_obj_and_bytes s cid >|= Option.map fst
27
+
28
+
let read_record s cid =
29
+
match Block_map.get cid s.blocks with
30
+
| Some b ->
31
+
Lwt.return (Lex.of_cbor b)
32
+
| None ->
33
+
raise (Failure "Missing block")
34
+
35
+
let get_root s = Lwt.return s.root
36
+
37
+
let put_block s cid bytes ~rev =
38
+
s.blocks <- Block_map.set cid bytes s.blocks ;
39
+
s.rev <- Some rev ;
40
+
Lwt.return_unit
41
+
42
+
let put_many s blocks =
43
+
s.blocks <- Block_map.merge s.blocks blocks ;
44
+
Lwt.return_unit
45
+
46
+
let update_root s cid ~rev =
47
+
s.root <- Some cid ;
48
+
s.rev <- Some rev ;
49
+
Lwt.return_unit
50
+
51
+
let apply_commit s (c : Repo_store.commit_data) =
52
+
let with_removed =
53
+
Cid.Set.fold
54
+
(fun cid blocks -> Block_map.remove cid blocks)
55
+
c.removed_cids s.blocks
56
+
in
57
+
s.blocks <- Block_map.merge with_removed c.relevant_blocks ;
58
+
s.root <- Some c.cid ;
59
+
Lwt.return_unit
60
+
end
+54
mist/lib/storage/overlay_store.ml
+54
mist/lib/storage/overlay_store.ml
···
1
+
let ( let* ) = Lwt.bind
2
+
3
+
module Make (Top : Repo_store.Readable) (Bottom : Repo_store.Readable) : sig
4
+
include Repo_store.Readable
5
+
6
+
val create : Top.t -> Bottom.t -> t
7
+
end = struct
8
+
type t = {top: Top.t; bottom: Bottom.t}
9
+
10
+
let create top bottom = {top; bottom}
11
+
12
+
let get_bytes {top; bottom} cid =
13
+
let* from_top = Top.get_bytes top cid in
14
+
match from_top with
15
+
| Some _ as res ->
16
+
Lwt.return res
17
+
| None ->
18
+
Bottom.get_bytes bottom cid
19
+
20
+
let has {top; bottom} cid =
21
+
let* from_top = Top.has top cid in
22
+
match from_top with
23
+
| true ->
24
+
Lwt.return_true
25
+
| false ->
26
+
Bottom.has bottom cid
27
+
28
+
let get_blocks {top; bottom} cids =
29
+
let* from_top = Top.get_blocks top cids in
30
+
let* from_bottom = Bottom.get_blocks bottom from_top.missing in
31
+
let merged_blocks = Block_map.merge from_top.blocks from_bottom.blocks in
32
+
Lwt.return {Block_map.blocks= merged_blocks; missing= from_bottom.missing}
33
+
34
+
let read_obj_and_bytes {top; bottom} cid =
35
+
let* from_top = Top.read_obj_and_bytes top cid in
36
+
match from_top with
37
+
| Some _ as res ->
38
+
Lwt.return res
39
+
| None ->
40
+
Bottom.read_obj_and_bytes bottom cid
41
+
42
+
let read_obj {top; bottom} cid =
43
+
let* from_top = Top.read_obj top cid in
44
+
match from_top with
45
+
| Some _ as res ->
46
+
Lwt.return res
47
+
| None ->
48
+
Bottom.read_obj bottom cid
49
+
50
+
let read_record {top; bottom} cid =
51
+
Lwt.catch
52
+
(fun () -> Top.read_record top cid)
53
+
(fun _ -> Bottom.read_record bottom cid)
54
+
end
+39
mist/lib/storage/repo_store.ml
+39
mist/lib/storage/repo_store.ml
···
1
+
type commit_data =
2
+
{ cid: Cid.t
3
+
; rev: string
4
+
; since: string option
5
+
; prev: Cid.t option
6
+
; relevant_blocks: Block_map.t
7
+
; removed_cids: Cid.Set.t }
8
+
9
+
module type Readable = sig
10
+
type t
11
+
12
+
val get_bytes : t -> Cid.t -> bytes option Lwt.t
13
+
14
+
val has : t -> Cid.t -> bool Lwt.t
15
+
16
+
val get_blocks : t -> Cid.t list -> Block_map.with_missing Lwt.t
17
+
18
+
val read_obj_and_bytes : t -> Cid.t -> (Dag_cbor.value * bytes) option Lwt.t
19
+
20
+
val read_obj : t -> Cid.t -> Dag_cbor.value option Lwt.t
21
+
22
+
val read_record : t -> Cid.t -> Lex.repo_record Lwt.t
23
+
end
24
+
25
+
module type Writable = sig
26
+
type t
27
+
28
+
include Readable with type t := t
29
+
30
+
val get_root : t -> Cid.t option Lwt.t
31
+
32
+
val put_block : t -> Cid.t -> bytes -> rev:string -> unit Lwt.t
33
+
34
+
val put_many : t -> Block_map.t -> unit Lwt.t
35
+
36
+
val update_root : t -> Cid.t -> rev:string -> unit Lwt.t
37
+
38
+
val apply_commit : t -> commit_data -> unit Lwt.t
39
+
end
+18
-26
mist/lib/storage/storage.ml
+18
-26
mist/lib/storage/storage.ml
···
1
1
module Block_map = Block_map
2
-
3
-
type commit_data =
4
-
{ cid: Cid.t
5
-
; rev: string
6
-
; since: string option
7
-
; prev: Cid.t option
8
-
; relevant_blocks: Block_map.t
9
-
; removed_cids: Cid.Set.t }
10
-
11
-
module type S = sig
12
-
type t
13
-
14
-
val get_root : t -> Cid.t option Lwt.t
15
-
16
-
val put_block : t -> Cid.t -> bytes -> rev:string -> unit Lwt.t
2
+
module Blob_store = Blob_store
17
3
18
-
val put_many : t -> Block_map.t -> unit Lwt.t
19
-
20
-
val update_root : t -> Cid.t -> rev:string -> unit Lwt.t
21
-
22
-
val apply_commit : t -> commit_data -> unit Lwt.t
4
+
module type Readable_blockstore = Repo_store.Readable
23
5
24
-
val get_bytes : t -> Cid.t -> bytes option Lwt.t
6
+
module type Writable_blockstore = Repo_store.Writable
25
7
26
-
val has : t -> Cid.t -> bool Lwt.t
8
+
module Memory_blockstore = struct
9
+
module Impl = Memory_store.Make ()
10
+
include Impl
27
11
28
-
val get_blocks : t -> Cid.t list -> Block_map.with_missing Lwt.t
12
+
module Readable : Repo_store.Readable with type t = Impl.t = Impl
29
13
30
-
val read_obj_and_bytes : t -> Cid.t -> (Dag_cbor.value * bytes) option Lwt.t
14
+
module Writable : Repo_store.Writable with type t = Impl.t = Impl
15
+
end
31
16
32
-
val read_obj : t -> Cid.t -> Dag_cbor.value option Lwt.t
17
+
module Overlay_blockstore
18
+
(Top : Repo_store.Readable)
19
+
(Bottom : Repo_store.Readable) =
20
+
struct
21
+
module Impl = Overlay_store.Make (Top) (Bottom)
22
+
include Impl
33
23
34
-
val read_record : t -> Cid.t -> Lex.repo_record
24
+
module Readable : Repo_store.Readable with type t = Impl.t = Impl
35
25
end
26
+
27
+
type commit_data = Repo_store.commit_data