futur.blue
objective categorical abstract machine language personal data server
1type t =
2 { (* We only implement CIDv1 *)
3 version: int
4 ; (* Multicodec type for the data; 0x55 for raw data or 0x71 for DAG-CBOR *)
5 codec: codec
6 ; (* Digest of the data *)
7 digest: digest
8 ; (* CID bytes *)
9 bytes: bytes }
10
11and digest =
12 { (* Multicodec type for the digest; always 0x12 for SHA-256 *)
13 codec: int
14 ; (* Hash bytes *)
15 contents: bytes }
16
17and codec = Raw | Dcbor
18
19let version = 1
20
21let hash_sha256 = 0x12
22
23let codec_raw = 0x55
24
25let codec_dcbor = 0x71
26
27let codec_byte = function Raw -> codec_raw | Dcbor -> codec_dcbor
28
29let codec_of_byte b = if b = codec_raw then Raw else Dcbor
30
31let create codec data =
32 let buf = Buffer.create 36 in
33 Buffer.add_uint8 buf version ;
34 Buffer.add_uint8 buf @@ codec_byte codec ;
35 Buffer.add_uint8 buf hash_sha256 ;
36 Buffer.add_uint8 buf 32 ;
37 let digest = Digestif.SHA256.(data |> digest_bytes |> to_raw_string) in
38 Buffer.add_string buf digest ;
39 let bytes = Buffer.to_bytes buf in
40 { version
41 ; codec
42 ; digest= {codec= hash_sha256; contents= Bytes.of_string digest}
43 ; bytes }
44
45let create_empty codec =
46 let buf = Buffer.create 4 in
47 Buffer.add_uint8 buf version ;
48 Buffer.add_uint8 buf @@ codec_byte codec ;
49 Buffer.add_uint8 buf hash_sha256 ;
50 Buffer.add_uint8 buf 0 ;
51 let bytes = Buffer.to_bytes buf in
52 { version
53 ; codec
54 ; digest= {codec= hash_sha256; contents= Bytes.sub bytes 4 0}
55 ; bytes }
56
57let decode_first bytes =
58 let version = Char.code (Bytes.get bytes 0) in
59 let codec = Char.code (Bytes.get bytes 1) in
60 let digest_codec = Char.code (Bytes.get bytes 2) in
61 let digest_length = Char.code (Bytes.get bytes 3) in
62 if version <> 1 then
63 failwith (Printf.sprintf "Unsupported CID version %d" version) ;
64 if codec <> codec_raw && codec <> codec_dcbor then
65 failwith (Printf.sprintf "Unsupported CID codec %d" codec) ;
66 if digest_codec <> hash_sha256 then
67 failwith (Printf.sprintf "Unsupported CID digest codec %d" digest_codec) ;
68 if digest_length <> 32 && digest_length <> 0 then
69 failwith (Printf.sprintf "Incorrect CID digest length %d" digest_length) ;
70 if Bytes.length bytes < 4 + digest_length then
71 failwith (Printf.sprintf "CID too short %d" (Bytes.length bytes)) ;
72 ( { version
73 ; codec= codec_of_byte codec
74 ; digest= {codec= digest_codec; contents= Bytes.sub bytes 4 digest_length}
75 ; bytes= Bytes.sub bytes 0 (digest_length + 4) }
76 , Bytes.sub bytes (digest_length + 4) (Bytes.length bytes - digest_length - 4)
77 )
78
79let decode bytes =
80 let cid, remainder = decode_first bytes in
81 if Bytes.length remainder > 0 then
82 failwith
83 (Printf.sprintf "CID has %d trailing bytes" (Bytes.length remainder)) ;
84 cid
85
86let of_string str =
87 (* 36 byte CID in base32 = 58 chars + 1 char prefix *)
88 (* 4 byte CID in base32 = 7 chars + 1 char prefix *)
89 if String.length str <> 59 && String.length str <> 8 then
90 Error (Printf.sprintf "CID too short %s" str)
91 else
92 match Multibase.decode str with
93 | Ok (_, cid) -> (
94 match decode (Bytes.of_string cid) with
95 | cid ->
96 Ok cid
97 | exception msg ->
98 Error (Printf.sprintf "CID decode error: %s" (Printexc.to_string msg))
99 )
100 | Error (`Msg msg) ->
101 Error msg
102 | Error (`Unsupported t) ->
103 Error
104 (Printf.sprintf "Unsupported multibase %s"
105 (Multibase.Encoding.to_string t) )
106
107let to_string cid =
108 match Multibase.encode `Base32 (Bytes.to_string cid.bytes) with
109 | Ok str ->
110 str
111 | Error (`Msg msg) ->
112 failwith msg
113 | Error (`Unsupported t) ->
114 failwith
115 (Printf.sprintf "Unsupported multibase %s"
116 (Multibase.Encoding.to_string t) )
117
118let of_bytes bytes =
119 (* 36 byte CID + 1 byte prefix *)
120 (* 4 byte CID + 1 byte prefix *)
121 if Bytes.length bytes <> 37 && Bytes.length bytes <> 5 then
122 Error (Printf.sprintf "CID too short %d" (Bytes.length bytes))
123 else if Bytes.get bytes 0 <> Char.unsafe_chr 0 then
124 Error (Printf.sprintf "CID has non-zero prefix %c" (Bytes.get bytes 0))
125 else Ok (decode (Bytes.sub bytes 1 (Bytes.length bytes - 1)))
126
127let to_bytes cid =
128 let buf = Buffer.create (1 + Bytes.length cid.bytes) in
129 Buffer.add_uint8 buf 0 ;
130 Buffer.add_bytes buf cid.bytes ;
131 Buffer.to_bytes buf
132
133let as_cid str = Result.get_ok @@ of_string str
134
135let to_yojson cid = `Assoc [("$link", `String (to_string cid))]
136
137let of_yojson = function
138 | `Assoc [("$link", `String str)] ->
139 of_string str
140 | `String str ->
141 of_string str
142 | s ->
143 Error (Printf.sprintf "invalid CID: %s" (Yojson.Safe.to_string s))
144
145let compare a b = String.compare (to_string a) (to_string b)
146
147let equal a b = String.equal (to_string a) (to_string b)
148
149let hash = Hashtbl.hash
150
151module Set = Set.Make (struct
152 type nonrec t = t
153
154 let compare = compare
155end)
156
157module Map = Map.Make (struct
158 type nonrec t = t
159
160 let compare = compare
161end)