Source file inode.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
open! Import
include Inode_intf
exception Max_depth of int
module Make_internal
(Conf : Conf.S)
(H : Irmin.Hash.S) (Key : sig
include Irmin.Key.S with type hash = H.t
val unfindable_of_hash : hash -> t
end)
(Node : Irmin.Node.Generic_key.S
with type hash = H.t
and type contents_key = Key.t
and type node_key = Key.t) =
struct
(** If [should_be_stable ~length ~root] is true for an inode [i], then [i]
hashes the same way as a [Node.t] containing the same entries. *)
let should_be_stable ~length ~root =
if length = 0 then true
else if not root then false
else if length <= Conf.stable_hash then true
else false
module Node = struct
include Node
module H = Irmin.Hash.Typed (H) (Node)
let hash = H.hash
end
let max_depth = int_of_float (log (2. ** 50.) /. log (float Conf.entries))
module T = struct
type hash = H.t [@@deriving irmin ~pp ~to_bin_string ~equal]
type key = Key.t [@@deriving irmin ~pp ~equal]
type node_key = Node.node_key [@@deriving irmin]
type contents_key = Node.contents_key [@@deriving irmin]
type step = Node.step
[@@deriving irmin ~compare ~to_bin_string ~of_bin_string ~short_hash]
type metadata = Node.metadata [@@deriving irmin ~equal]
type value = Node.value [@@deriving irmin ~equal]
module Metadata = Node.Metadata
exception Dangling_hash = Node.Dangling_hash
let raise_dangling_hash c hash =
let context = "Irmin_pack.Inode." ^ c in
raise (Dangling_hash { context; hash })
let unsafe_keyvalue_of_hashvalue = function
| `Contents (h, m) -> `Contents (Key.unfindable_of_hash h, m)
| `Node h -> `Node (Key.unfindable_of_hash h)
let hashvalue_of_keyvalue = function
| `Contents (k, m) -> `Contents (Key.to_hash k, m)
| `Node k -> `Node (Key.to_hash k)
end
module Step =
Irmin.Hash.Typed
(H)
(struct
type t = T.step
let t = T.step_t
end)
module Child_ordering : Child_ordering with type step := T.step = struct
open T
type key = bytes
let log_entry = int_of_float (log (float Conf.entries) /. log 2.)
let () =
assert (log_entry >= 1);
assert ((not (Conf.inode_child_order = `Hash_bits)) || log_entry <= 10);
assert (Conf.entries = int_of_float (2. ** float log_entry))
let key =
match Conf.inode_child_order with
| `Hash_bits ->
fun s -> Bytes.unsafe_of_string (hash_to_bin_string (Step.hash s))
| `Seeded_hash | `Custom _ ->
fun s -> Bytes.unsafe_of_string (step_to_bin_string s)
let hash_bits ~depth k =
assert (Bytes.length k = Step.hash_size);
let byte = 8 in
let initial_bit_pos = log_entry * depth in
let n = initial_bit_pos / byte in
let r = initial_bit_pos mod byte in
if n >= Step.hash_size then raise (Max_depth depth);
if r + log_entry <= byte then
let i = Bytes.get_uint8 k n in
let e0 = i lsr (byte - log_entry - r) in
let r0 = e0 land (Conf.entries - 1) in
r0
else
let i0 = Bytes.get_uint8 k n in
let to_read = byte - r in
let rest = log_entry - to_read in
let mask = (1 lsl to_read) - 1 in
let r0 = (i0 land mask) lsl rest in
if n + 1 >= Step.hash_size then raise (Max_depth depth);
let i1 = Bytes.get_uint8 k (n + 1) in
let r1 = i1 lsr (byte - rest) in
r0 + r1
let short_hash = Irmin.Type.(unstage (short_hash bytes))
let seeded_hash ~depth k = abs (short_hash ~seed:depth k) mod Conf.entries
let index =
match Conf.inode_child_order with
| `Seeded_hash -> seeded_hash
| `Hash_bits -> hash_bits
| `Custom f -> f
end
module StepMap = struct
include Map.Make (struct
type t = T.step
let compare = T.compare_step
end)
let of_list l = List.fold_left (fun acc (k, v) -> add k v acc) empty l
end
module Val_ref : sig
open T
type t [@@deriving irmin]
type v = private Key of Key.t | Hash of hash Lazy.t
val inspect : t -> v
val of_key : key -> t
val of_hash : hash Lazy.t -> t
val promote_exn : t -> key -> unit
val to_hash : t -> hash
val to_lazy_hash : t -> hash Lazy.t
val to_key_exn : t -> key
val is_key : t -> bool
end = struct
open T
(** Nodes that have been persisted to an underlying store are referenced via
keys. Otherwise, when building in-memory inodes (e.g. via [Portable] or
[of_concrete_exn]) lazily-computed hashes are used instead. If such
values are persisted, the hash reference can be promoted to a key
reference (but [Key] values are never demoted to hashes).
NOTE: in future, we could reflect the case of this type in a type
parameter and refactor the [layout] types below to get static guarantees
that [Portable] nodes (with hashes for internal pointers) are not saved
without first saving their children. *)
type v = Key of Key.t | Hash of hash Lazy.t [@@deriving irmin ~pp_dump]
type t = v ref
let inspect t = !t
let of_key k = ref (Key k)
let of_hash h = ref (Hash h)
let promote_exn t k =
let existing_hash =
match !t with
| Key k' ->
Key.to_hash k'
| Hash h -> Lazy.force h
in
if not (equal_hash existing_hash (Key.to_hash k)) then
Fmt.failwith
"Attempted to promote existing reference %a to an inconsistent key %a"
pp_dump_v !t pp_key k;
t := Key k
let to_hash t =
match !t with Hash h -> Lazy.force h | Key k -> Key.to_hash k
let to_lazy_hash t =
match !t with Hash h -> h | Key k -> lazy (Key.to_hash k)
let is_key t = match !t with Key _ -> true | _ -> false
let to_key_exn t =
match !t with
| Key k -> k
| Hash h ->
Fmt.failwith "Encountered unkeyed hash but expected key: %a" pp_hash
(Lazy.force h)
let t =
let pre_hash_hash = Irmin.Type.(unstage (pre_hash hash_t)) in
let pre_hash x f =
match !x with
| Key k -> pre_hash_hash (Key.to_hash k) f
| Hash h -> pre_hash_hash (Lazy.force h) f
in
Irmin.Type.map ~pre_hash v_t (fun x -> ref x) (fun x -> !x)
end
module Bin = struct
open T
(** Distinguishes between the two possible modes of binary value. *)
type _ mode = Ptr_key : key mode | Ptr_any : Val_ref.t mode
type 'vref with_index = { index : int; vref : 'vref } [@@deriving irmin]
type 'vref tree = {
depth : int;
length : int;
entries : 'vref with_index list;
}
[@@deriving irmin]
type 'vref v = Values of (step * value) list | Tree of 'vref tree
[@@deriving irmin ~pre_hash]
module V =
Irmin.Hash.Typed
(H)
(struct
type t = Val_ref.t v [@@deriving irmin]
end)
type 'vref t = { hash : H.t Lazy.t; root : bool; v : 'vref v }
let t : type vref. vref Irmin.Type.t -> vref t Irmin.Type.t =
fun vref_t ->
let open Irmin.Type in
let v_t = v_t vref_t in
let pre_hash_v = pre_hash_v vref_t in
let pre_hash x = pre_hash_v x.v in
record "Bin.t" (fun hash root v -> { hash = Lazy.from_val hash; root; v })
|+ field "hash" H.t (fun t -> Lazy.force t.hash)
|+ field "root" bool (fun t -> t.root)
|+ field "v" v_t (fun t -> t.v)
|> sealr
|> like ~pre_hash
let v ~hash ~root v = { hash; root; v }
let hash t = Lazy.force t.hash
let depth t =
match t.v with
| Values _ -> if t.root then Some 0 else None
| Tree t -> Some t.depth
end
module Compress = struct
open T
type dict_key = int [@@deriving irmin]
type pack_offset = int63 [@@deriving irmin]
type name = Indirect of dict_key | Direct of step
type address = Offset of pack_offset | Hash of H.t [@@deriving irmin]
type ptr = { index : int; hash : address } [@@deriving irmin]
type tree = { depth : int; length : int; entries : ptr list }
[@@deriving irmin]
type value =
| Contents of name * address * metadata
| Node of name * address
let is_default = T.(equal_metadata Metadata.default)
let[@ocamlformat "disable"] value_t : value Irmin.Type.t =
let module Payload = struct
let io = [%typ: dict_key * pack_offset]
let ih = [%typ: dict_key * H.t]
let do_ = [%typ: step * pack_offset]
let dh = [%typ: step * H.t]
let x_io = [%typ: dict_key * pack_offset * metadata]
let x_ih = [%typ: dict_key * H.t * metadata]
let x_do = [%typ: step * pack_offset * metadata]
let x_dh = [%typ: step * H.t * metadata]
end in
let open Irmin.Type in
variant "Compress.value"
(fun
contents_io contents_x_io node_io contents_ih contents_x_ih node_ih
contents_do contents_x_do node_do contents_dh contents_x_dh node_dh
-> function
| Node (Indirect n, Offset o) -> node_io (n, o)
| Node (Indirect n, Hash h) -> node_ih (n, h)
| Node (Direct n, Offset o) -> node_do (n, o)
| Node (Direct n, Hash h) -> node_dh (n, h)
| Contents (Indirect n, Offset o, m) -> if is_default m then contents_io (n, o) else contents_x_io (n, o, m)
| Contents (Indirect n, Hash h, m) -> if is_default m then contents_ih (n, h) else contents_x_ih (n, h, m)
| Contents (Direct n, Offset o, m) -> if is_default m then contents_do (n, o) else contents_x_do (n, o, m)
| Contents (Direct n, Hash h, m) -> if is_default m then contents_dh (n, h) else contents_x_dh (n, h, m))
|~ case1 "contents-io" Payload.io (fun (n, o) -> Contents (Indirect n, Offset o, Metadata.default))
|~ case1 "contents-x-io" Payload.x_io (fun (n, i, m) -> Contents (Indirect n, Offset i, m))
|~ case1 "node-io" Payload.io (fun (n, i) -> Node (Indirect n, Offset i))
|~ case1 "contents-ih" Payload.ih (fun (n, h) -> Contents (Indirect n, Hash h, Metadata.default))
|~ case1 "contents-x-ih" Payload.x_ih (fun (n, h, m) -> Contents (Indirect n, Hash h, m))
|~ case1 "node-ih" Payload.ih (fun (n, h) -> Node (Indirect n, Hash h))
|~ case1 "contents-do" Payload.do_ (fun (n, i) -> Contents (Direct n, Offset i, Metadata.default))
|~ case1 "contents-x-do" Payload.x_do (fun (n, i, m) -> Contents (Direct n, Offset i, m))
|~ case1 "node-do" Payload.do_ (fun (n, i) -> Node (Direct n, Offset i))
|~ case1 "contents-dh" Payload.dh (fun (n, i) -> Contents (Direct n, Hash i, Metadata.default))
|~ case1 "contents-x-dh" Payload.x_dh (fun (n, i, m) -> Contents (Direct n, Hash i, m))
|~ case1 "node-dd" Payload.dh (fun (n, i) -> Node (Direct n, Hash i))
|> sealv
type v = Values of value list | Tree of tree
[@@deriving irmin ~encode_bin ~decode_bin ~size_of]
let dynamic_size_of_v_encoding =
match Irmin.Type.Size.of_encoding v_t with
| Irmin.Type.Size.Dynamic f -> f
| _ -> assert false
type kind = Pack_value.Kind.t
[@@deriving irmin ~encode_bin ~decode_bin ~size_of]
type nonrec int = int [@@deriving irmin ~encode_bin ~decode_bin]
let no_length = 0
let is_real_length length = not (length = 0)
type v1 = { mutable length : int; v : v } [@@deriving irmin]
(** [length] is the length of the binary encoding of [v]. It is not known
right away. [length] is [no_length] when it isn't known. Calling
[encode_bin] or [size_of] will make [length] known. *)
(** [tagged_v] sits between [v] and [t]. It is a variant with the header
binary encoded as the magic. *)
type tagged_v =
| V0_stable of v
| V0_unstable of v
| V1_root of v1
| V1_nonroot of v1
[@@deriving irmin]
let encode_bin_tv_staggered ({ v; _ } as tv) kind f =
match size_of_v v with
| Some length ->
tv.length <- length;
encode_bin_kind kind f;
encode_bin_int length f;
encode_bin_v v f
| None ->
let buf = Buffer.create 1024 in
encode_bin_v v (Buffer.add_string buf);
let length = Buffer.length buf in
tv.length <- length;
encode_bin_kind kind f;
encode_bin_int length f;
f (Buffer.contents buf)
let encode_bin_tv tv f =
match tv with
| V0_stable _ -> assert false
| V0_unstable _ -> assert false
| V1_root { length; v } when is_real_length length ->
encode_bin_kind Pack_value.Kind.Inode_v2_root f;
encode_bin_int length f;
encode_bin_v v f
| V1_nonroot { length; v } when is_real_length length ->
encode_bin_kind Pack_value.Kind.Inode_v2_nonroot f;
encode_bin_int length f;
encode_bin_v v f
| V1_root tv -> encode_bin_tv_staggered tv Pack_value.Kind.Inode_v2_root f
| V1_nonroot tv ->
encode_bin_tv_staggered tv Pack_value.Kind.Inode_v2_nonroot f
let decode_bin_tv s off =
let kind = decode_bin_kind s off in
match kind with
| Pack_value.Kind.Inode_v1_unstable ->
let v = decode_bin_v s off in
V0_unstable v
| Inode_v1_stable ->
let v = decode_bin_v s off in
V0_stable v
| Inode_v2_root ->
let length = decode_bin_int s off in
assert (is_real_length length);
let v = decode_bin_v s off in
V1_root { length; v }
| Inode_v2_nonroot ->
let length = decode_bin_int s off in
assert (is_real_length length);
let v = decode_bin_v s off in
V1_nonroot { length; v }
| Commit_v1 | Commit_v2 -> assert false
| Contents -> assert false
| Dangling_parent_commit -> assert false
let size_of_tv =
let of_encoding s off =
let offref = ref off in
let kind = decode_bin_kind s offref in
let magic_len = 1 in
match kind with
| Pack_value.Kind.Inode_v1_unstable | Inode_v1_stable ->
let vlen = dynamic_size_of_v_encoding s !offref in
magic_len + vlen
| Inode_v2_root | Inode_v2_nonroot ->
let before = !offref in
let vlen = decode_bin_int s offref in
let after = !offref in
let lenlen = after - before in
magic_len + lenlen + vlen
| Commit_v1 | Commit_v2 | Contents -> assert false
| Dangling_parent_commit -> assert false
in
Irmin.Type.Size.custom_dynamic ~of_encoding ()
let tagged_v_t =
Irmin.Type.like ~bin:(encode_bin_tv, decode_bin_tv, size_of_tv) tagged_v_t
type t = { hash : H.t; tv : tagged_v } [@@deriving irmin]
let v ~root ~hash v =
let length = no_length in
let tv =
if root then V1_root { v; length } else V1_nonroot { v; length }
in
{ hash; tv }
(** The rule to determine the [is_root] property of a v0 [Value] is a bit
convoluted, it relies on the fact that back then the following property
was enforced: [Conf.stable_hash > Conf.entries].
When [t] is of tag [Values], then [t] is root iff [t] is stable.
When [t] is stable, then [t] is a root, because:
- Only 2 functions produce stable inodes: [stabilize] and [empty].
- Only the roots are output of [stabilize].
- An empty map can only be located at the root.
When [t] is a root of tag [Value], then [t] is stable, because:
- All the roots are output of [stabilize].
- When an unstable inode enters [stabilize], it becomes stable if it has
at most [Conf.stable_hash] leaves.
- A [Value] has at most [Conf.stable_hash] leaves because
[Conf.entries <= Conf.stable_hash] is enforced. *)
let is_root = function
| { tv = V0_stable (Values _); _ } -> true
| { tv = V0_unstable (Values _); _ } -> false
| { tv = V0_stable (Tree { depth; _ }); _ }
| { tv = V0_unstable (Tree { depth; _ }); _ } ->
depth = 0
| { tv = V1_root _; _ } -> true
| { tv = V1_nonroot _; _ } -> false
end
(** [Val_impl] defines the recursive structure of inodes.
{3 Inode Layout}
{4 Layout Types}
The layout ['a layout] associated to an inode ['a t] defines certain
properties of the inode:
- When [Total], the inode is self contained and immutable.
- When [Partial], chunks of the inode might be missing but they can be
fetched from the backend when needed using the available [find] function
stored in the layout. Mutable pointers act as cache.
- When [Truncated], chunks of the inode might be missing. Those chunks are
unreachable because the pointer to the backend is missing. The inode is
immutable.
{4 Layout Instantiation}
The layout of an inode is determined from the module [Val], it depends on
the way the inode was constructed:
- When [Total], it originates from [Val.v] or [Val.empty].
- When [Partial], it originates from [Val.of_bin], which is only used by
[Inode.find].
- When [Truncated], it either originates from an [Irmin.Type]
deserialisation or from a proof.
Almost all other functions in [Val_impl] are polymorphic regarding the
layout of the manipulated inode.
{4 Details on the [Truncated] Layout}
The [Truncated] layout is identical to [Partial] except for the missing
[find] function.
On the one hand, when creating the root of a [Truncated] inode, the
pointers to children inodes - if any - are set to the [Broken] tag,
meaning that we know the hash to such children but we will have no way to
load them in the future. On the other hand, when adding child to a
[Truncated] inode, there is no such problem, the pointer is then set to
the [Intact] tag.
A tree of inode only made of [Intact] tags is similar to a [Total] layout.
As of Irmin 2.4 (February 2022), inode deserialisation using Repr happens
in [irmin/slice.ml] and [irmin/sync_ext.ml], and maybe some other places.
At some point we might want to forbid such deserialisations and instead
use something in the flavour of [Val.of_bin] to create [Partial] inodes.
{3 Topmost Inode Ancestor}
[Val_impl.t] is a recursive type, it is labelled with a [depth] integer
that indicates the recursion depth. An inode with [depth = 0] corresponds
to the root of a directory, its hash is the hash of the directory.
A [Val.t] points to the topmost [Val_impl.t] of an inode tree. In most
scenarios, that topmost inode has [depth = 0], but it is also legal for
the topmost inode to be an intermediate inode, i.e. with [depth > 0].
The only way for an inode tree to have an intermediate inode as root is to
fetch it from the backend by calling [Make_ext.find], using the hash of
that inode.
Write-only operations are not permitted when the root is an intermediate
inode. *)
module Val_impl = struct
open T
type _ layout =
| Total : total_ptr layout
| Partial : find -> partial_ptr layout
| Truncated : truncated_ptr layout
and find = expected_depth:int -> key -> partial_ptr t option
and partial_ptr_target =
| Dirty of partial_ptr t
| Lazy of key
| Lazy_loaded of partial_ptr t
(** A partial pointer differentiates the [Dirty] and [Lazy_loaded]
cases in order to remember that only the latter should be
collected when [clear] is called.
The child in [Lazy_loaded] can only emanate from the disk. It can
be savely collected on [clear].
The child in [Dirty] can only emanate from a user modification,
e.g. through the [add] or [to_concrete] functions. It shouldn't be
collected on [clear] because it will be needed for [save]. *)
and partial_ptr = { mutable target : partial_ptr_target }
and total_ptr = Total_ptr of total_ptr t [@@unboxed]
and truncated_ptr =
| Broken of Val_ref.t
(** Initially [Hash.t], then set to [Key.t] when we try to save the
parent and successfully index the hash. *)
| Intact of truncated_ptr t
and 'ptr tree = { depth : int; length : int; entries : 'ptr option array }
and 'ptr v = Values of value StepMap.t | Tree of 'ptr tree
and 'ptr t = {
root : bool;
v : 'ptr v;
v_ref : Val_ref.t;
(** Represents what is known about [v]'s presence in a corresponding
store. Will be a [hash] if [v] is purely in-memory, and a [key] if
[v] has been written to / loaded from a store. *)
}
module Ptr = struct
let val_ref : type ptr. ptr layout -> ptr -> Val_ref.t = function
| Total -> fun (Total_ptr ptr) -> ptr.v_ref
| Partial _ -> (
fun { target } ->
match target with
| Lazy key -> Val_ref.of_key key
| Lazy_loaded { v_ref; _ } | Dirty { v_ref; _ } -> v_ref)
| Truncated -> ( function Broken v -> v | Intact ptr -> ptr.v_ref)
let key_exn : type ptr. ptr layout -> ptr -> key = function
| Total -> fun (Total_ptr ptr) -> Val_ref.to_key_exn ptr.v_ref
| Partial _ -> (
fun { target } ->
match target with
| Lazy key -> key
| Lazy_loaded { v_ref; _ } | Dirty { v_ref; _ } ->
Val_ref.to_key_exn v_ref)
| Truncated -> (
function
| Broken h -> Val_ref.to_key_exn h
| Intact ptr -> Val_ref.to_key_exn ptr.v_ref)
(** [force = false] will cause [target] to raise an exception when
encountering a tag [Lazy] inside a [Partial] inode. This feature is
used by [to_concrete] to make shallow the non-loaded inode branches. *)
let target :
type ptr.
expected_depth:int ->
cache:bool ->
force:bool ->
string ->
ptr layout ->
ptr ->
ptr t =
fun ~expected_depth ~cache ~force context layout ->
match layout with
| Total -> fun (Total_ptr t) -> t
| Partial find -> (
function
| { target = Dirty entry } | { target = Lazy_loaded entry } ->
entry
| { target = Lazy key } as t -> (
if not force then raise_dangling_hash context (Key.to_hash key);
match find ~expected_depth key with
| None ->
Fmt.failwith "%a: unknown inode key (%s)" pp_key key context
| Some x ->
if cache then t.target <- Lazy_loaded x;
x))
| Truncated -> (
function
| Intact entry -> entry
| Broken vref ->
let h = Val_ref.to_hash vref in
raise_dangling_hash context h)
let of_target : type ptr. ptr layout -> ptr t -> ptr = function
| Total -> fun target -> Total_ptr target
| Partial _ -> fun target -> { target = Dirty target }
| Truncated -> fun target -> Intact target
let of_key : type ptr. ptr layout -> key -> ptr = function
| Total -> assert false
| Partial _ -> fun key -> { target = Lazy key }
| Truncated -> fun key -> Broken (Val_ref.of_key key)
type ('input, 'output) cps = { f : 'r. 'input -> ('output -> 'r) -> 'r }
[@@ocaml.unboxed]
let save :
type ptr.
broken:(hash, key) cps ->
save_dirty:(ptr t, key) cps ->
clear:bool ->
ptr layout ->
ptr ->
unit =
fun ~broken ~save_dirty ~clear -> function
| Total ->
fun (Total_ptr entry) ->
save_dirty.f entry (fun key ->
Val_ref.promote_exn entry.v_ref key)
| Partial _ -> (
function
| { target = Dirty entry } as box ->
save_dirty.f entry (fun key ->
if clear then box.target <- Lazy key
else (
box.target <- Lazy_loaded entry;
Val_ref.promote_exn entry.v_ref key))
| { target = Lazy_loaded entry } as box ->
save_dirty.f entry (fun key ->
if clear then box.target <- Lazy key)
| { target = Lazy _ } -> ())
| Truncated -> (
function
| Intact entry ->
save_dirty.f entry (fun key ->
Val_ref.promote_exn entry.v_ref key)
| Broken vref ->
if not (Val_ref.is_key vref) then
broken.f (Val_ref.to_hash vref) (fun key ->
Val_ref.promote_exn vref key))
let clear :
type ptr.
iter_dirty:(ptr layout -> ptr t -> unit) -> ptr layout -> ptr -> unit
=
fun ~iter_dirty layout ptr ->
match layout with
| Partial _ -> (
match ptr with
| { target = Lazy _ } -> ()
| { target = Dirty ptr } -> iter_dirty layout ptr
| { target = Lazy_loaded ptr } as box ->
let key = Val_ref.to_key_exn ptr.v_ref in
box.target <- Lazy key)
| Total | Truncated -> ()
end
let pred layout t =
match t.v with
| Tree i ->
let key_of_ptr = Ptr.key_exn layout in
Array.fold_left
(fun acc -> function
| None -> acc
| Some ptr -> (None, `Inode (key_of_ptr ptr)) :: acc)
[] i.entries
| Values l ->
StepMap.fold
(fun s v acc ->
let v =
match v with
| `Node _ as k -> (Some s, k)
| `Contents (k, _) -> (Some s, `Contents k)
in
v :: acc)
l []
let length_of_v = function
| Values vs -> StepMap.cardinal vs
| Tree vs -> vs.length
let length t = length_of_v t.v
let rec clear layout t =
match t.v with
| Tree i ->
Array.iter
(Option.iter (Ptr.clear ~iter_dirty:clear layout))
i.entries
| Values _ -> ()
let nb_children t =
match t.v with
| Tree i ->
Array.fold_left
(fun i -> function None -> i | Some _ -> i + 1)
0 i.entries
| Values vs -> StepMap.cardinal vs
type cont = off:int -> len:int -> (step * value) Seq.node
let rec seq_tree layout bucket_seq ~depth ~cache : cont -> cont =
fun k ~off ~len ->
assert (off >= 0);
assert (len > 0);
match bucket_seq () with
| Seq.Nil -> k ~off ~len
| Seq.Cons (None, rest) -> seq_tree layout rest ~depth ~cache k ~off ~len
| Seq.Cons (Some i, rest) ->
let trg =
let expected_depth = depth + 1 in
Ptr.target ~expected_depth ~cache ~force:true "seq_tree" layout i
in
let trg_len = length trg in
if off - trg_len >= 0 then
let off = off - trg_len in
seq_tree layout rest ~depth ~cache k ~off ~len
else
seq_v layout trg.v ~cache
(seq_tree layout rest ~depth ~cache k)
~off ~len
and seq_values layout value_seq : cont -> cont =
fun k ~off ~len ->
assert (off >= 0);
assert (len > 0);
match value_seq () with
| Seq.Nil -> k ~off ~len
| Cons (x, rest) ->
if off = 0 then
let len = len - 1 in
if len = 0 then
Seq.Cons (x, Seq.empty)
else Seq.Cons (x, fun () -> seq_values layout rest k ~off ~len)
else
let off = off - 1 in
seq_values layout rest k ~off ~len
and seq_v layout v ~cache : cont -> cont =
fun k ~off ~len ->
assert (off >= 0);
assert (len > 0);
match v with
| Tree t ->
let depth = t.depth in
seq_tree layout (Array.to_seq t.entries) ~depth ~cache k ~off ~len
| Values vs -> seq_values layout (StepMap.to_seq vs) k ~off ~len
let list_v layout v ~cache k ~off ~len =
match v with
| Tree _ ->
let s () = seq_v layout v ~cache k ~off ~len in
List.of_seq s
| Values vs ->
if off = 0 && len = Int.max_int then StepMap.bindings vs
else
let seq () = seq_values layout (StepMap.to_seq vs) k ~off ~len in
List.of_seq seq
let empty_continuation : cont = fun ~off:_ ~len:_ -> Seq.Nil
let seq layout ?offset:(off = 0) ?length:(len = Int.max_int) ?(cache = true)
t : (step * value) Seq.t =
if off < 0 then invalid_arg "Invalid pagination offset";
if len < 0 then invalid_arg "Invalid pagination length";
if len = 0 then Seq.empty
else fun () -> seq_v layout t.v ~cache empty_continuation ~off ~len
let list layout ?offset:(off = 0) ?length:(len = Int.max_int)
?(cache = true) t : (step * value) list =
if off < 0 then invalid_arg "Invalid pagination offset";
if len < 0 then invalid_arg "Invalid pagination length";
if len = 0 then []
else list_v layout t.v ~cache empty_continuation ~off ~len
let seq_tree layout ?(cache = true) i : (step * value) Seq.t =
let off = 0 in
let len = Int.max_int in
fun () -> seq_v layout (Tree i) ~cache empty_continuation ~off ~len
let seq_v layout ?(cache = true) v : (step * value) Seq.t =
let off = 0 in
let len = Int.max_int in
fun () -> seq_v layout v ~cache empty_continuation ~off ~len
let to_bin_v :
type ptr vref. ptr layout -> vref Bin.mode -> ptr v -> vref Bin.v =
fun layout mode node ->
Stats.incr_inode_to_binv ();
match node with
| Values vs ->
let vs = StepMap.bindings vs in
Bin.Values vs
| Tree t ->
let vref_of_ptr : ptr -> vref =
match mode with
| Bin.Ptr_any -> Ptr.val_ref layout
| Bin.Ptr_key -> Ptr.key_exn layout
in
let _, entries =
Array.fold_left
(fun (i, acc) -> function
| None -> (i + 1, acc)
| Some ptr ->
let vref = vref_of_ptr ptr in
(i + 1, { Bin.index = i; vref } :: acc))
(0, []) t.entries
in
let entries = List.rev entries in
Bin.Tree { depth = t.depth; length = t.length; entries }
let is_root t = t.root
let is_stable t = should_be_stable ~length:(length t) ~root:(is_root t)
let to_bin layout mode t =
let v = to_bin_v layout mode t.v in
Bin.v ~root:(is_root t) ~hash:(Val_ref.to_lazy_hash t.v_ref) v
type len = [ `Eq of int | `Ge of int ] [@@deriving irmin]
module Concrete = struct
type kinded_key =
| Contents of contents_key
| Contents_x of metadata * contents_key
| Node of node_key
[@@deriving irmin]
type entry = { name : step; key : kinded_key } [@@deriving irmin]
type 'a pointer = { index : int; pointer : hash; tree : 'a }
[@@deriving irmin]
type 'a tree = { depth : int; length : int; pointers : 'a pointer list }
[@@deriving irmin]
type t = Tree of t tree | Values of entry list | Blinded
[@@deriving irmin]
let to_entry (name, v) =
match v with
| `Contents (contents_key, m) ->
if T.equal_metadata m Metadata.default then
{ name; key = Contents contents_key }
else { name; key = Contents_x (m, contents_key) }
| `Node node_key -> { name; key = Node node_key }
let of_entry e =
( e.name,
match e.key with
| Contents key -> `Contents (key, Metadata.default)
| Contents_x (m, key) -> `Contents (key, m)
| Node key -> `Node key )
type error =
[ `Invalid_hash of hash * hash * t
| `Invalid_depth of int * int * t
| `Invalid_length of len * int * t
| `Duplicated_entries of t
| `Duplicated_pointers of t
| `Unsorted_entries of t
| `Unsorted_pointers of t
| `Blinded_root
| `Too_large_values of t
| `Empty ]
[@@deriving irmin]
let rec length = function
| Values l -> `Eq (List.length l)
| Tree t ->
List.fold_left
(fun acc p ->
match (acc, length p.tree) with
| `Eq x, `Eq y -> `Eq (x + y)
| (`Eq x | `Ge x), (`Eq y | `Ge y) -> `Ge (x + y))
(`Eq 0) t.pointers
| Blinded -> `Ge 0
let pp = Irmin.Type.pp_json t
let pp_len ppf = function
| `Eq e -> Fmt.pf ppf "%d" e
| `Ge e -> Fmt.pf ppf "'at least %d'" e
let pp_error ppf = function
| `Invalid_hash (got, expected, t) ->
Fmt.pf ppf "invalid hash for %a@,got: %a@,expecting: %a" pp t
pp_hash got pp_hash expected
| `Invalid_depth (got, expected, t) ->
Fmt.pf ppf "invalid depth for %a@,got: %d@,expecting: %d" pp t got
expected
| `Invalid_length (got, expected, t) ->
Fmt.pf ppf "invalid length for %a@,got: %a@,expecting: %d" pp t
pp_len got expected
| `Duplicated_entries t -> Fmt.pf ppf "duplicated entries: %a" pp t
| `Duplicated_pointers t -> Fmt.pf ppf "duplicated pointers: %a" pp t
| `Unsorted_entries t -> Fmt.pf ppf "entries should be sorted: %a" pp t
| `Unsorted_pointers t ->
Fmt.pf ppf "pointers should be sorted: %a" pp t
| `Blinded_root -> Fmt.pf ppf "blinded root"
| `Too_large_values t ->
Fmt.pf ppf "A Values should have at most Conf.entries elements: %a"
pp t
| `Empty -> Fmt.pf ppf "concrete subtrees cannot be empty"
end
let to_concrete ~force (la : 'ptr layout) (t : 'ptr t) =
let rec aux t =
let h = Val_ref.to_hash t.v_ref in
match t.v with
| Tree tr ->
( h,
Concrete.Tree
{
depth = tr.depth;
length = tr.length;
pointers =
Array.fold_left
(fun (i, acc) e ->
match e with
| None -> (i + 1, acc)
| Some t ->
let expected_depth = tr.depth + 1 in
let pointer, tree =
try
aux
(Ptr.target ~expected_depth ~cache:true ~force
"to_concrete" la t)
with Dangling_hash { hash; _ } ->
(hash, Concrete.Blinded)
in
(i + 1, { Concrete.index = i; tree; pointer } :: acc))
(0, []) tr.entries
|> snd
|> List.rev;
} )
| Values l ->
( h,
Concrete.Values (List.map Concrete.to_entry (StepMap.bindings l))
)
in
snd (aux t)
exception Invalid_hash of hash * hash * Concrete.t
exception Invalid_depth of int * int * Concrete.t
exception Invalid_length of len * int * Concrete.t
exception Empty
exception Duplicated_entries of Concrete.t
exception Duplicated_pointers of Concrete.t
exception Unsorted_entries of Concrete.t
exception Unsorted_pointers of Concrete.t
exception Blinded_root
exception Too_large_values of Concrete.t
let hash_equal = Irmin.Type.(unstage (equal hash_t))
let of_concrete_exn : type a. depth:int -> a layout -> _ -> a t =
fun ~depth la t ->
let sort_entries =
List.sort_uniq (fun x y -> compare x.Concrete.name y.Concrete.name)
in
let sort_pointers =
List.sort_uniq (fun x y -> compare x.Concrete.index y.Concrete.index)
in
let check_entries t es =
if es = [] then raise Empty;
let s = sort_entries es in
if List.compare_length_with es Conf.entries > 0 then
raise (Too_large_values t);
if List.compare_lengths s es <> 0 then raise (Duplicated_entries t);
if s <> es then raise (Unsorted_entries t)
in
let check_pointers t ps =
if ps = [] then raise Empty;
let s = sort_pointers ps in
if List.length s <> List.length ps then raise (Duplicated_pointers t);
if s <> ps then raise (Unsorted_pointers t)
in
let hash v = Bin.V.hash (to_bin_v la Bin.Ptr_any v) in
let rec aux depth t =
match t with
| Concrete.Blinded -> None
| Concrete.Values l ->
check_entries t l;
Some (Values (StepMap.of_list (List.map Concrete.of_entry l)))
| Concrete.Tree tr ->
let entries = Array.make Conf.entries None in
check_pointers t tr.pointers;
List.iter
(fun { Concrete.index; pointer; tree } ->
match aux (depth + 1) tree with
| None ->
let ptr =
match la with
| Total -> assert false
| Partial _ ->
let k = Key.unfindable_of_hash pointer in
Ptr.of_key la k
| Truncated ->
let v_ref = Val_ref.of_hash (Lazy.from_val pointer) in
(Broken v_ref : a)
in
entries.(index) <- Some ptr
| Some v ->
let hash = hash v in
if not (hash_equal hash pointer) then
raise (Invalid_hash (hash, pointer, t));
let v_ref = Val_ref.of_hash (Lazy.from_val pointer) in
let t = { v_ref; root = false; v } in
entries.(index) <- Some (Ptr.of_target la t))
tr.pointers;
if depth <> tr.depth then raise (Invalid_depth (depth, tr.depth, t));
let () =
match Concrete.length t with
| `Eq length ->
if length <> tr.length then
raise (Invalid_length (`Eq length, tr.length, t))
| `Ge length ->
if length > tr.length then
raise (Invalid_length (`Ge length, tr.length, t))
in
Some (Tree { depth = tr.depth; length = tr.length; entries })
in
let v =
match aux depth t with None -> raise Blinded_root | Some v -> v
in
let length = length_of_v v in
let hash =
if should_be_stable ~length ~root:(depth = 0) then
let node = Node.of_seq (seq_v la v) in
Node.hash node
else hash v
in
{ v_ref = Val_ref.of_hash (Lazy.from_val hash); root = depth = 0; v }
let of_concrete ~depth la t =
try Ok (of_concrete_exn ~depth la t) with
| Invalid_hash (x, y, z) -> Error (`Invalid_hash (x, y, z))
| Invalid_depth (x, y, z) -> Error (`Invalid_depth (x, y, z))
| Invalid_length (x, y, z) -> Error (`Invalid_length (x, y, z))
| Empty -> Error `Empty
| Duplicated_entries t -> Error (`Duplicated_entries t)
| Duplicated_pointers t -> Error (`Duplicated_pointers t)
| Unsorted_entries t -> Error (`Unsorted_entries t)
| Unsorted_pointers t -> Error (`Unsorted_pointers t)
| Too_large_values t -> Error (`Too_large_values t)
| Blinded_root -> Error `Blinded_root
let hash t = Val_ref.to_hash t.v_ref
let hash_exn ?(force = true) t =
match Val_ref.inspect t.v_ref with
| Key k -> Key.to_hash k
| Hash h ->
if Lazy.is_val h || force then Lazy.force h else raise Not_found
let check_write_op_supported t =
if not @@ is_root t then
failwith "Cannot perform operation on non-root inode value."
let stabilize_root layout t =
let n = length t in
if n > Conf.stable_hash then { t with root = true }
else
let v_ref =
Val_ref.of_hash
(lazy
(let vs = seq layout ~cache:false t in
Node.hash (Node.of_seq vs)))
in
{ v_ref; v = t.v; root = true }
let index ~depth k =
if depth >= max_depth then raise (Max_depth depth);
Child_ordering.index ~depth k
(** This function shouldn't be called with the [Total] layout. In the
future, we could add a polymorphic variant to the GADT parameter to
enfoce that. *)
let of_bin layout (t : key Bin.t) =
let v =
match t.Bin.v with
| Bin.Values vs ->
let vs = StepMap.of_list vs in
Values vs
| Tree t ->
let entries = Array.make Conf.entries None in
let ptr_of_key = Ptr.of_key layout in
List.iter
(fun { Bin.index; vref } ->
entries.(index) <- Some (ptr_of_key vref))
t.entries;
Tree { depth = t.Bin.depth; length = t.length; entries }
in
{ v_ref = Val_ref.of_hash t.Bin.hash; root = t.Bin.root; v }
let recompute_hash layout t =
if is_stable t then
let vs = seq layout ~cache:false t in
Node.hash (Node.of_seq vs)
else
let v = to_bin_v layout Bin.Ptr_any t.v in
let hash = Bin.V.hash v in
hash
let empty : 'a. 'a layout -> 'a t =
fun _ ->
let v_ref = Val_ref.of_hash (lazy (Node.hash (Node.empty ()))) in
{ root = false; v_ref; v = Values StepMap.empty }
let values layout vs =
let length = StepMap.cardinal vs in
if length = 0 then empty layout
else
let v = Values vs in
let v_ref =
Val_ref.of_hash (lazy (Bin.V.hash (to_bin_v layout Bin.Ptr_any v)))
in
{ v_ref; root = false; v }
let tree layout is =
let v = Tree is in
let v_ref =
Val_ref.of_hash (lazy (Bin.V.hash (to_bin_v layout Bin.Ptr_any v)))
in
{ v_ref; root = false; v }
let is_empty t =
match t.v with Values vs -> StepMap.is_empty vs | Tree _ -> false
let find_value ~cache layout t s =
let key = Child_ordering.key s in
let rec aux = function
| Values vs -> ( try Some (StepMap.find s vs) with Not_found -> None)
| Tree t -> (
let i = index ~depth:t.depth key in
let x = t.entries.(i) in
match x with
| None -> None
| Some i ->
let expected_depth = t.depth + 1 in
aux
(Ptr.target ~expected_depth ~cache ~force:true "find_value"
layout i)
.v)
in
aux t.v
let find ?(cache = true) layout t s = find_value ~cache layout t s
let rec add layout ~depth ~copy ~replace parent s key v k =
Stats.incr_inode_rec_add ();
match parent.v with
| Values vs ->
let length =
if replace then StepMap.cardinal vs else StepMap.cardinal vs + 1
in
let parent =
if length <= Conf.entries then values layout (StepMap.add s v vs)
else
let vs = StepMap.bindings (StepMap.add s v vs) in
let empty =
tree layout
{ length = 0; depth; entries = Array.make Conf.entries None }
in
let aux t (s', v) =
let key' = Child_ordering.key s' in
(add [@tailcall]) layout ~depth ~copy:false ~replace t s' key' v
(fun x -> x)
in
List.fold_left aux empty vs
in
k parent
| Tree tr -> (
assert (depth = tr.depth);
let length = if replace then tr.length else tr.length + 1 in
let entries = if copy then Array.copy tr.entries else tr.entries in
let i = index ~depth key in
match entries.(i) with
| None ->
let child = values layout (StepMap.singleton s v) in
entries.(i) <- Some (Ptr.of_target layout child);
let parent = tree layout { tr with length; entries } in
k parent
| Some ptr ->
let child =
let expected_depth = depth + 1 in
Ptr.target ~expected_depth ~cache:true ~force:true "add" layout
ptr
in
(add [@tailcall]) layout ~depth:(depth + 1) ~copy ~replace child s
key v (fun child ->
entries.(i) <- Some (Ptr.of_target layout child);
let parent = tree layout { tr with length; entries } in
k parent))
let add layout ~copy t s v =
let k = Child_ordering.key s in
match find_value ~cache:true layout t s with
| Some v' when equal_value v v' -> t
| Some _ ->
add ~depth:0 layout ~copy ~replace:true t s k v Fun.id
|> stabilize_root layout
| None ->
add ~depth:0 layout ~copy ~replace:false t s k v Fun.id
|> stabilize_root layout
let rec remove layout parent s key k =
Stats.incr_inode_rec_remove ();
match parent.v with
| Values vs ->
let parent = values layout (StepMap.remove s vs) in
k parent
| Tree tr -> (
let depth = tr.depth in
let len = tr.length - 1 in
if len <= Conf.entries then
let vs = seq_tree layout tr in
let vs = StepMap.of_seq vs in
let vs = StepMap.remove s vs in
let parent = values layout vs in
k parent
else
let entries = Array.copy tr.entries in
let i = index ~depth key in
match entries.(i) with
| None -> assert false
| Some ptr ->
let child =
let expected_depth = depth + 1 in
Ptr.target ~expected_depth ~cache:true ~force:true "remove"
layout ptr
in
if length child = 1 then (
entries.(i) <- None;
let parent = tree layout { depth; length = len; entries } in
k parent)
else
(remove [@tailcall]) layout child s key (fun child ->
entries.(i) <- Some (Ptr.of_target layout child);
let parent =
tree layout { tr with length = len; entries }
in
k parent))
let remove layout t s =
let k = Child_ordering.key s in
match find_value ~cache:true layout t s with
| None -> t
| Some _ -> remove layout t s k Fun.id |> stabilize_root layout
let of_seq la l =
let t =
let rec aux_big seq inode =
match seq () with
| Seq.Nil -> inode
| Seq.Cons ((s, v), rest) ->
aux_big rest (add la ~copy:false inode s v)
in
let len =
ref 0
in
let rec aux_small seq map =
match seq () with
| Seq.Nil ->
assert (!len <= Conf.entries);
values la map
| Seq.Cons ((s, v), rest) ->
let map =
StepMap.update s
(function
| None ->
incr len;
Some v
| Some _ -> Some v)
map
in
if !len = Conf.entries then aux_big rest (values la map)
else aux_small rest map
in
aux_small l StepMap.empty
in
stabilize_root la t
let save layout ~add ~index ~mem t =
let clear =
false
in
let iter_entries =
let broken h k =
match index h with
| None ->
Fmt.failwith
"You are trying to save to the backend an inode deserialized \
using [Irmin.Type] that used to contain pointer(s) to inodes \
which are unknown to the backend. Hash: %a"
pp_hash h
| Some key ->
k key
in
fun ~save_dirty arr ->
let iter_ptr =
Ptr.save ~broken:{ f = broken } ~save_dirty ~clear layout
in
Array.iter (Option.iter iter_ptr) arr
in
let rec aux ~depth t =
match t.v with
| Values _ -> (
[%log.debug "Inode.save values depth:%d" depth];
let unguarded_add hash =
let value =
to_bin layout Bin.Ptr_key t
in
let key = add hash value in
Val_ref.promote_exn t.v_ref key;
key
in
match Val_ref.inspect t.v_ref with
| Key key ->
if mem key then key else unguarded_add (Key.to_hash key)
| Hash hash -> unguarded_add (Lazy.force hash))
| Tree n ->
[%log.debug "Inode.save tree depth:%d" depth];
let save_dirty t k =
let key =
match Val_ref.inspect t.v_ref with
| Key key -> if mem key then key else aux ~depth:(depth + 1) t
| Hash hash -> (
match index (Lazy.force hash) with
| Some key ->
if mem key then key
else
aux ~depth:(depth + 1) t
| None -> aux ~depth:(depth + 1) t)
in
Val_ref.promote_exn t.v_ref key;
k key
in
iter_entries ~save_dirty:{ f = save_dirty } n.entries;
let bin =
to_bin layout Bin.Ptr_key t
in
let key = add (Val_ref.to_hash t.v_ref) bin in
Val_ref.promote_exn t.v_ref key;
key
in
aux ~depth:0 t
let check_stable layout t =
let rec check t any_stable_ancestor =
let stable = is_stable t || any_stable_ancestor in
match t.v with
| Values _ -> true
| Tree tree ->
Array.for_all
(function
| None -> true
| Some t ->
let t =
let expected_depth = tree.depth + 1 in
Ptr.target ~expected_depth ~cache:true ~force:true
"check_stable" layout t
in
(if stable then not (is_stable t) else true)
&& check t stable)
tree.entries
in
check t (is_stable t)
let contains_empty_map layout t =
let rec check_lower t =
match t.v with
| Values l when StepMap.is_empty l -> true
| Values _ -> false
| Tree inodes ->
Array.exists
(function
| None -> false
| Some t ->
let expected_depth = inodes.depth + 1 in
Ptr.target ~expected_depth ~cache:true ~force:true
"contains_empty_map" layout t
|> check_lower)
inodes.entries
in
check_lower t
let is_tree t = match t.v with Tree _ -> true | Values _ -> false
module Proof = struct
type value = [ `Contents of hash * metadata | `Node of hash ]
[@@deriving irmin]
type t =
[ `Blinded of hash
| `Values of (step * value) list
| `Inode of int * (int * t) list ]
[@@deriving irmin]
let weaken_step_value (step, v) = (step, hashvalue_of_keyvalue v)
let strengthen_step_value (step, v) =
(step, unsafe_keyvalue_of_hashvalue v)
let rec proof_of_concrete :
type a. hash Lazy.t -> Concrete.t -> (t -> a) -> a =
fun h concrete k ->
match concrete with
| Blinded -> k (`Blinded (Lazy.force h))
| Values vs ->
let l =
List.map Concrete.of_entry vs |> List.map weaken_step_value
in
k (`Values l)
| Tree tr ->
let proofs =
List.fold_left
(fun acc (e : _ Concrete.pointer) ->
let hash = Lazy.from_val e.pointer in
proof_of_concrete hash e.tree (fun proof ->
(e.index, proof) :: acc))
[] (List.rev tr.pointers)
in
k (`Inode (tr.length, proofs))
let hash_values ~depth l =
let inode = values Truncated (StepMap.of_list l) in
let t =
match depth with 0 -> { inode with root = true } | _ -> inode
in
hash t
let hash_inode ~depth ~length es =
let entries = Array.make Conf.entries None in
List.iter (fun (index, ptr) -> entries.(index) <- Some ptr) es;
let v : truncated_ptr v = Tree { depth; length; entries } in
Bin.V.hash (to_bin_v Truncated Bin.Ptr_any v)
let rec concrete_of_proof :
type a. depth:int -> t -> (hash -> Concrete.t -> a) -> a =
fun ~depth proof k ->
match proof with
| `Blinded h -> k h Concrete.Blinded
| `Values vs ->
let vs = List.map strengthen_step_value vs in
assert (List.compare_length_with vs Conf.entries <= 0);
let hash = hash_values ~depth vs in
let c = Concrete.Values (List.map Concrete.to_entry vs) in
k hash c
| `Inode (length, proofs) -> concrete_of_inode ~length ~depth proofs k
and concrete_of_inode :
type a.
length:int ->
depth:int ->
(int * t) list ->
(hash -> Concrete.t -> a) ->
a =
fun ~length ~depth proofs k ->
let rec aux ps es = function
| [] ->
let c = Concrete.Tree { depth; length; pointers = ps } in
let hash = hash_inode ~depth ~length es in
k hash c
| (index, proof) :: proofs ->
concrete_of_proof ~depth:(depth + 1) proof (fun pointer tree ->
let ps = { Concrete.tree; pointer; index } :: ps in
let h = Val_ref.of_hash (Lazy.from_val pointer) in
let es = (index, Broken h) :: es in
aux ps es proofs)
in
aux [] [] (List.rev proofs)
let proof_of_concrete h p = proof_of_concrete h p Fun.id
let concrete_of_proof ~depth p = concrete_of_proof ~depth p (fun _ t -> t)
let to_proof la t : t =
let p =
if is_stable t then
let bindings =
seq la t
|> Seq.map Concrete.to_entry
|> List.of_seq
|> List.fast_sort (fun x y ->
compare_step x.Concrete.name y.Concrete.name)
in
Concrete.Values bindings
else to_concrete ~force:false la t
in
proof_of_concrete (Val_ref.to_lazy_hash t.v_ref) p
let of_proof (Partial _ as la) ~depth (proof : t) =
match proof with
| `Values vs when List.compare_length_with vs Conf.entries > 0 -> (
if depth <> 0 then None
else
let t =
of_seq Total (List.map strengthen_step_value vs |> List.to_seq)
in
let hash =
hash t
in
let v_ref = Val_ref.of_hash (Lazy.from_val hash) in
match t.v with
| Values _ -> assert false
| Tree { depth; length; entries } ->
let ptr_of_key = Ptr.of_key la in
let entries =
Array.map
(function
| None -> None
| Some ptr ->
let hash =
Ptr.val_ref Total ptr |> Val_ref.to_hash
in
let key = Key.unfindable_of_hash hash in
Some (ptr_of_key key))
entries
in
let v = Tree { depth; length; entries } in
let t = { v_ref; v; root = true } in
Some t)
| _ -> (
let c = concrete_of_proof ~depth proof in
match of_concrete la ~depth c with
| Ok v -> Some v
| Error _ -> None)
let of_concrete t = proof_of_concrete (lazy (failwith "blinded root")) t
let to_concrete = concrete_of_proof ~depth:0
end
module Snapshot = struct
include T
type kinded_hash = Contents of hash * metadata | Node of hash
[@@deriving irmin]
type entry = { step : string; hash : kinded_hash } [@@deriving irmin]
type inode_tree = {
depth : int;
length : int;
pointers : (int * hash) list;
}
[@@deriving irmin]
type v = Inode_tree of inode_tree | Inode_value of entry list
[@@deriving irmin]
type inode = { v : v; root : bool } [@@deriving irmin]
end
let of_entry ~index e : step * Node.value =
let step =
match T.step_of_bin_string e.Snapshot.step with
| Ok s -> s
| Error (`Msg m) -> Fmt.failwith "step of bin error: %s" m
in
( step,
match e.hash with
| Snapshot.Contents (hash, m) ->
let key = index hash in
`Contents (key, m)
| Node hash ->
let key = index hash in
`Node key )
let of_inode_tree ~index layout tr =
let entries = Array.make Conf.entries None in
let ptr_of_key hash =
let key = index hash in
Ptr.of_key layout key
in
List.iter
(fun (index, pointer) -> entries.(index) <- Some (ptr_of_key pointer))
tr.Snapshot.pointers;
{ depth = tr.depth; length = tr.length; entries }
let of_snapshot ~index layout (v : Snapshot.inode) =
let t =
match v.v with
| Inode_value vs ->
values layout (StepMap.of_list (List.map (of_entry ~index) vs))
| Inode_tree tr -> tree layout (of_inode_tree ~index layout tr)
in
if v.root then stabilize_root layout t else t
end
module Raw = struct
type hash = H.t [@@deriving irmin]
type key = Key.t
type t = T.key Bin.t [@@deriving irmin]
type metadata = T.metadata [@@deriving irmin]
type Pack_value.kinded += Node of t
let to_kinded t = Node t
let of_kinded = function Node n -> n | _ -> assert false
let depth = Bin.depth
exception Invalid_depth of { expected : int; got : int; v : t }
let kind (t : t) =
if t.root then Pack_value.Kind.Inode_v2_root
else Pack_value.Kind.Inode_v2_nonroot
let repr_size = Mem.repr_size t
(** [repr_size] undercounts the size of an inode by around this factor.
A value of 4.5 was empirically observed by averaging the ratio between
[Mem.reachable_bytes] and [repr_size] during a few runs of a trace
replay. This value is rounded to 5 to prevent float-int conversion
during weight calculation, at the expense of letting fewer objects into
the LRU. *)
let repr_size_adjustment = 5
let weight t =
Pack_value.Deferred (fun () -> repr_size_adjustment * repr_size t)
let hash t = Bin.hash t
let step_to_bin = T.step_to_bin_string
let step_of_bin = T.step_of_bin_string
let encode_compress = Irmin.Type.(unstage (encode_bin Compress.t))
let decode_compress = Irmin.Type.(unstage (decode_bin Compress.t))
let = function
| Pack_value.Kind.Contents ->
Conf.contents_length_header
| k -> Pack_value.Kind.length_header_exn k
let decode_compress_length =
match Irmin.Type.Size.of_encoding Compress.t with
| Unknown | Static _ -> assert false
| Dynamic f -> f
let encode_bin :
dict:(string -> int option) ->
offset_of_key:(Key.t -> int63 option) ->
hash ->
t Irmin.Type.encode_bin =
fun ~dict ~offset_of_key hash t ->
Stats.incr_inode_encode_bin ();
let step s : Compress.name =
let str = step_to_bin s in
if String.length str <= 3 then Direct s
else match dict str with Some i -> Indirect i | None -> Direct s
in
let address_of_key key : Compress.address =
match offset_of_key key with
| Some off -> Compress.Offset off
| None ->
Compress.Hash (Key.to_hash key)
in
let ptr : T.key Bin.with_index -> Compress.ptr =
fun n ->
let hash = address_of_key n.vref in
{ index = n.index; hash }
in
let value : T.step * T.value -> Compress.value = function
| s, `Contents (c, m) ->
let s = step s in
let v = address_of_key c in
Compress.Contents (s, v, m)
| s, `Node n ->
let s = step s in
let v = address_of_key n in
Compress.Node (s, v)
in
let v : T.key Bin.v -> Compress.v = function
| Values vs -> Values (List.map value vs)
| Tree { depth; length; entries } ->
let entries = List.map ptr entries in
Tree { Compress.depth; length; entries }
in
let t = Compress.v ~root:t.root ~hash (v t.v) in
encode_compress t
exception Exit of [ `Msg of string ]
let decode_bin :
dict:(int -> string option) ->
key_of_offset:(int63 -> key) ->
key_of_hash:(hash -> key) ->
t Irmin.Type.decode_bin =
fun ~dict ~key_of_offset ~key_of_hash t pos_ref ->
Stats.incr_inode_decode_bin ();
let i = decode_compress t pos_ref in
let step : Compress.name -> T.step = function
| Direct n -> n
| Indirect s -> (
match dict s with
| None -> raise_notrace (Exit (`Msg "dict"))
| Some s -> (
match step_of_bin s with
| Error e -> raise_notrace (Exit e)
| Ok v -> v))
in
let key : Compress.address -> T.key = function
| Offset off -> key_of_offset off
| Hash n -> key_of_hash n
in
let ptr : Compress.ptr -> T.key Bin.with_index =
fun n ->
let vref = key n.hash in
{ index = n.index; vref }
in
let value : Compress.value -> T.step * T.value = function
| Contents (n, h, metadata) ->
let name = step n in
let hash = key h in
(name, `Contents (hash, metadata))
| Node (n, h) ->
let name = step n in
let hash = key h in
(name, `Node hash)
in
let t : Compress.tagged_v -> T.key Bin.v =
fun tv ->
let v =
match tv with
| V0_stable v -> v
| V0_unstable v -> v
| V1_root { v; _ } -> v
| V1_nonroot { v; _ } -> v
in
match v with
| Values vs -> Values (List.rev_map value (List.rev vs))
| Tree { depth; length; entries } ->
let entries = List.map ptr entries in
Tree { depth; length; entries }
in
let root = Compress.is_root i in
let v = t i.tv in
Bin.v ~root ~hash:(Lazy.from_val i.hash) v
let decode_bin_length = decode_compress_length
let decode_children_offsets ~entry_of_offset ~entry_of_hash t pos_ref =
let i = decode_compress t pos_ref in
let { Compress.tv; _ } = i in
let v =
match tv with
| V0_stable v | V0_unstable v -> v
| V1_root { v; _ } | V1_nonroot { v; _ } -> v
in
let entry_of_address = function
| Compress.Offset offset -> entry_of_offset offset
| Hash h -> entry_of_hash h
in
match v with
| Values ls ->
List.map
(function
| Compress.Contents (_, address, _) | Node (_, address) ->
entry_of_address address)
ls
| Tree { entries; _ } ->
List.map
(function ({ hash; _ } : Compress.ptr) -> entry_of_address hash)
entries
module Snapshot = Val_impl.Snapshot
let to_entry : T.step * Node.value -> Snapshot.entry =
fun (name, v) ->
let step = step_to_bin name in
match v with
| `Contents (contents_key, m) ->
let h = Key.to_hash contents_key in
{ Snapshot.step; hash = Contents (h, m) }
| `Node node_key ->
let h = Key.to_hash node_key in
{ step; hash = Node h }
let to_snapshot : t -> Snapshot.inode =
fun t ->
match t.v with
| Bin.Tree tree ->
let inode_tree =
{
Snapshot.depth = tree.depth;
length = tree.length;
pointers =
List.map
(fun { Bin.index; vref } ->
let hash = Key.to_hash vref in
(index, hash))
tree.entries;
}
in
{ v = Inode_tree inode_tree; root = t.root }
| Values vs ->
let vs = List.map to_entry vs in
let v = Snapshot.Inode_value vs in
{ v; root = t.root }
end
module Snapshot = Val_impl.Snapshot
let to_snapshot = Raw.to_snapshot
type hash = T.hash
type key = Key.t
let pp_hash = T.pp_hash
module Val_portable = struct
include T
module I = Val_impl
type t =
| Total of I.total_ptr I.t
| Partial of I.partial_ptr I.layout * I.partial_ptr I.t
| Truncated of I.truncated_ptr I.t
type 'b apply_fn = { f : 'a. 'a I.layout -> 'a I.t -> 'b } [@@unboxed]
let apply : t -> 'b apply_fn -> 'b =
fun t f ->
match t with
| Total v -> f.f I.Total v
| Partial (layout, v) -> f.f layout v
| Truncated v -> f.f I.Truncated v
type map_fn = { f : 'a. 'a I.layout -> 'a I.t -> 'a I.t } [@@unboxed]
let map : t -> map_fn -> t =
fun t f ->
match t with
| Total v ->
let v' = f.f I.Total v in
if v == v' then t else Total v'
| Partial (layout, v) ->
let v' = f.f layout v in
if v == v' then t else Partial (layout, v')
| Truncated v ->
let v' = f.f I.Truncated v in
if v == v' then t else Truncated v'
let pred t = apply t { f = (fun layout v -> I.pred layout v) }
let of_seq l =
Stats.incr_inode_of_seq ();
Total (I.of_seq Total l)
let of_list l = of_seq (List.to_seq l)
let seq ?offset ?length ?cache t =
apply t { f = (fun layout v -> I.seq layout ?offset ?length ?cache v) }
let list ?offset ?length ?cache t =
apply t { f = (fun layout v -> I.list layout ?offset ?length ?cache v) }
let empty () = of_list []
let is_empty t = apply t { f = (fun _ v -> I.is_empty v) }
let find ?cache t s =
apply t { f = (fun layout v -> I.find ?cache layout v s) }
let add t s value =
Stats.incr_inode_add ();
let f layout v =
I.check_write_op_supported v;
I.add ~copy:true layout v s value
in
map t { f }
let remove t s =
Stats.incr_inode_remove ();
let f layout v =
I.check_write_op_supported v;
I.remove layout v s
in
map t { f }
let t : t Irmin.Type.t =
let pre_hash_binv = Irmin.Type.(unstage (pre_hash (Bin.v_t Val_ref.t))) in
let pre_hash_node = Irmin.Type.(unstage (pre_hash Node.t)) in
let pre_hash x =
let stable = apply x { f = (fun _ v -> I.is_stable v) } in
if not stable then
let bin =
apply x { f = (fun layout v -> I.to_bin layout Bin.Ptr_any v) }
in
pre_hash_binv bin.v
else
let vs =
seq x
in
pre_hash_node (Node.of_seq vs)
in
let module Ptr_any = struct
let t =
Irmin.Type.map (Bin.t Val_ref.t)
(fun _ -> assert false)
(fun x ->
apply x { f = (fun layout v -> I.to_bin layout Bin.Ptr_any v) })
type nonrec t = t [@@deriving irmin ~equal ~compare ~pp]
let encode_json = Irmin.Type.encode_json t
let decode_json _ = failwith "TODO"
end in
Irmin.Type.map ~pre_hash ~pp:Ptr_any.pp
~json:(Ptr_any.encode_json, Ptr_any.decode_json)
~equal:Ptr_any.equal ~compare:Ptr_any.compare (Bin.t T.key_t)
(fun bin -> Truncated (I.of_bin I.Truncated bin))
(fun x ->
apply x { f = (fun layout v -> I.to_bin layout Bin.Ptr_key v) })
let hash_exn ?force t = apply t { f = (fun _ v -> I.hash_exn ?force v) }
let save ?(allow_non_root = false) ~add ~index ~mem t =
if Conf.forbid_empty_dir_persistence && is_empty t then
failwith
"Persisting an empty node is forbidden by the configuration of the \
irmin-pack store";
let f layout v =
if not allow_non_root then I.check_write_op_supported v;
I.save layout ~add ~index ~mem v
in
apply t { f }
let of_raw (find' : expected_depth:int -> key -> key Bin.t option) v =
Stats.incr_inode_of_raw ();
let rec find ~expected_depth h =
Option.map (I.of_bin layout) (find' ~expected_depth h)
and layout = I.Partial find in
Partial (layout, I.of_bin layout v)
let recompute_hash t =
apply t { f = (fun layout v -> I.recompute_hash layout v) }
let to_raw t =
apply t { f = (fun layout v -> I.to_bin layout Bin.Ptr_key v) }
let stable t = apply t { f = (fun _ v -> I.is_stable v) }
let length t = apply t { f = (fun _ v -> I.length v) }
let clear t = apply t { f = (fun layout v -> I.clear layout v) }
let nb_children t = apply t { f = (fun _ v -> I.nb_children v) }
let index ~depth s = I.index ~depth (Child_ordering.key s)
let integrity_check t =
let f layout v =
let check_stable () =
let check () = I.check_stable layout v in
let n = length t in
if n > Conf.stable_hash then (not (stable t)) && check ()
else stable t && check ()
in
let contains_empty_map_non_root () =
let check () = I.contains_empty_map layout v in
if I.is_tree v then check () else false
in
check_stable () && not (contains_empty_map_non_root ())
in
apply t { f }
let merge ~contents ~node : t Irmin.Merge.t =
let merge = Node.merge ~contents ~node in
let to_node t = of_seq (Node.seq t) in
let of_node n = Node.of_seq (seq n) in
Irmin.Merge.like t merge of_node to_node
let with_handler f_env t =
match t with
| Total _ -> t
| Truncated _ -> t
| Partial ((I.Partial find as la), v) ->
let find_v ~expected_depth h =
match find ~expected_depth h with
| None -> None
| Some v -> Some (Partial (la, v))
in
let find = f_env find_v in
let find_ptr ~expected_depth h =
match find ~expected_depth h with
| Some (Partial (_, v)) -> Some v
| _ -> None
in
let la = I.Partial find_ptr in
Partial (la, v)
let head t =
let f la (v : _ I.t) =
if Val_impl.is_stable v then
let elts =
I.seq la v
|> List.of_seq
|> List.fast_sort (fun (x, _) (y, _) -> compare_step x y)
in
`Node elts
else
match v.v with
| I.Values n -> `Node (List.of_seq (StepMap.to_seq n))
| I.Tree v ->
let entries = ref [] in
for i = Array.length v.entries - 1 downto 0 do
match v.entries.(i) with
| None -> ()
| Some ptr ->
let h = I.Ptr.val_ref la ptr |> Val_ref.to_hash in
entries := (i, h) :: !entries
done;
`Inode (v.length, !entries)
in
apply t { f }
end
module Val = struct
include Val_portable
module Portable = struct
include Val_portable
type node_key = hash [@@deriving irmin]
type contents_key = hash [@@deriving irmin]
type value = [ `Contents of hash * metadata | `Node of hash ]
[@@deriving irmin]
let of_node t = t
let of_list bindings =
bindings
|> List.map (fun (k, v) -> (k, unsafe_keyvalue_of_hashvalue v))
|> of_list
let of_seq bindings =
bindings
|> Seq.map (fun (k, v) -> (k, unsafe_keyvalue_of_hashvalue v))
|> of_seq
let seq ?offset ?length ?cache t =
seq ?offset ?length ?cache t
|> Seq.map (fun (k, v) -> (k, hashvalue_of_keyvalue v))
let add : t -> step -> value -> t =
fun t s v -> add t s (unsafe_keyvalue_of_hashvalue v)
let list ?offset ?length ?cache t =
list ?offset ?length ?cache t
|> List.map (fun (s, v) -> (s, hashvalue_of_keyvalue v))
let find ?cache t s = find ?cache t s |> Option.map hashvalue_of_keyvalue
let merge =
let promote_merge :
hash option Irmin.Merge.t -> key option Irmin.Merge.t =
fun t ->
Irmin.Merge.like [%typ: key option] t (Option.map Key.to_hash)
(Option.map Key.unfindable_of_hash)
in
fun ~contents ~node ->
merge ~contents:(promote_merge contents) ~node:(promote_merge node)
module Proof = I.Proof
type proof = I.Proof.t [@@deriving irmin]
let to_proof (t : t) : proof =
apply t { f = (fun la v -> I.Proof.to_proof la v) }
let of_proof ~depth (p : proof) =
let find ~expected_depth:_ k =
raise_dangling_hash "of_proof@find" (Key.to_hash k)
in
let la = I.Partial find in
Option.map (fun v -> Partial (la, v)) (I.Proof.of_proof la ~depth p)
type 'a find = expected_depth:int -> 'a -> t option
let with_handler : (hash find -> hash find) -> t -> t =
let to_hash : key find -> hash find =
fun find ~expected_depth h ->
find ~expected_depth (Key.unfindable_of_hash h)
in
let to_key : hash find -> key find =
fun find ~expected_depth k -> find ~expected_depth (Key.to_hash k)
in
fun f_env t ->
with_handler (fun find -> find |> to_hash |> f_env |> to_key) t
let head t =
match head t with
| `Inode _ as x -> x
| `Node l -> `Node (List.map Proof.weaken_step_value l)
end
let to_concrete t =
apply t { f = (fun la v -> I.to_concrete ~force:true la v) }
let of_concrete t =
match I.of_concrete Truncated ~depth:0 t with
| Ok t -> Ok (Truncated t)
| Error _ as e -> e
module Snapshot = I.Snapshot
module Concrete = I.Concrete
let of_snapshot t ~index find' =
let rec find ~expected_depth h =
match find' ~expected_depth h with
| None -> None
| Some v -> Some (I.of_bin layout v)
and layout = I.Partial find in
Partial (layout, I.of_snapshot layout t ~index)
end
end
module Make
(H : Irmin.Hash.S)
(Key : Irmin.Key.S with type hash = H.t)
(Node : Irmin.Node.Generic_key.S
with type hash = H.t
and type contents_key = Key.t
and type node_key = Key.t)
(Inter : Internal
with type hash = H.t
and type key = Key.t
and type Snapshot.metadata = Node.metadata
and type Val.step = Node.step)
(Pack : Indexable.S
with type hash = H.t
and type key = Key.t
and type value = Inter.Raw.t) =
struct
module Hash = H
module Key = Key
module Val = Inter.Val
type 'a t = 'a Pack.t
type key = Key.t [@@deriving irmin ~equal]
type hash = Hash.t
type value = Inter.Val.t
let mem t k = Pack.mem t k
let index t k = Pack.index t k
exception Invalid_depth = Inter.Raw.Invalid_depth
let pp_value = Irmin.Type.pp Inter.Raw.t
let pp_invalid_depth ppf (expected, got, v) =
Fmt.pf ppf "Invalid depth: got %d, expecting %d (%a)" got expected pp_value
v
let check_depth_opt ~expected_depth:expected = function
| None -> ()
| Some v -> (
match Inter.Raw.depth v with
| None -> ()
| Some got ->
if got <> expected then raise (Invalid_depth { expected; got; v }))
let unsafe_find ~check_integrity t k =
match Pack.unsafe_find ~check_integrity t k with
| None -> None
| Some v ->
let find ~expected_depth k =
let v = Pack.unsafe_find ~check_integrity t k in
check_depth_opt ~expected_depth v;
v
in
let v = Val.of_raw find v in
Some v
let find t k = unsafe_find ~check_integrity:true t k |> Lwt.return
let save ?allow_non_root t v =
let add k v =
Pack.unsafe_append ~ensure_unique:true ~overcommit:false t k v
in
Val.save ?allow_non_root ~add ~index:(Pack.index_direct t)
~mem:(Pack.unsafe_mem t) v
let hash_exn = Val.hash_exn
let add t v = Lwt.return (save t v)
let equal_hash = Irmin.Type.(unstage (equal H.t))
let check_hash expected got =
if equal_hash expected got then ()
else
Fmt.invalid_arg "corrupted value: got %a, expecting %a" Inter.pp_hash
expected Inter.pp_hash got
let unsafe_add t k v =
check_hash k (hash_exn v);
Lwt.return (save t v)
let batch = Pack.batch
let close = Pack.close
let decode_bin_length = Inter.Raw.decode_bin_length
let protect_from_invalid_depth_exn f =
Lwt.catch f (function
| Invalid_depth { expected; got; v } ->
let msg = Fmt.to_to_string pp_invalid_depth (expected, got, v) in
Lwt.return (Error msg)
| e -> Lwt.fail e)
let integrity_check_inodes t k =
protect_from_invalid_depth_exn @@ fun () ->
find t k >|= function
| None ->
assert false
| Some v ->
if Inter.Val.integrity_check v then Ok ()
else
let msg =
Fmt.str "Problematic inode %a" (Irmin.Type.pp Inter.Val.t) v
in
Error msg
end