a91b6edbd8218cd01a61995f249844d5696d1e38c837d6a93b9ecc4f5103eab8.tri (7884B)
1 !import prelude * 2 !import io * 3 !import native_math as N 4 !export sourceObjectTreeDomain 5 !export sourceObjectManifestDomain 6 !export sourceObjectTreeAbi 7 !export sourceObjectTreeKind 8 !export sourceObjectEncodeOnto 9 !export sourceObjectEncode 10 !export sourceObjectDecode 11 !export sourceObjectDecodeComplete 12 !export sourceObjectShard 13 !export sourceObjectPath 14 !export sourceObjectDigest 15 !export sourceObjectHashHex 16 !export sourceObjectHashValid 17 !export sourceObjectVerify 18 !export sourceObjectGet 19 !export sourceObjectStoreAt 20 !export sourceObjectStore 21 !export sourceObjectPutTree 22 !export sourceObjectGetTree 23 24 -- Executable export objects use the existing Arboricx whole-term encoding: 25 -- Leaf 00, Stem 01 child, Fork 02 left right. A hash is over domain UTF-8, 26 -- one zero byte, and the canonical payload (not over a bundle or source). 27 sourceObjectTreeDomain = "arboricx.tree-term.v1" 28 sourceObjectManifestDomain = "arboricx.module-manifest.v1" 29 sourceObjectTreeAbi = "arboricx.abi.tree.v1" 30 sourceObjectTreeKind = "arboricx.tree-term.v1" 31 32 -- Build directly onto a suffix. Appending each encoded left subtree copies 33 -- its byte list once per enclosing fork and retains huge intermediate lists 34 -- for compiler exports. This visits each expanded tree occurrence once. 35 -- Keep triage as the small shape eliminator; canonical preorder is unchanged. 36 sourceObjectEncodeOnto tree suffix = 37 triage 38 (pair 0 suffix) 39 (child : pair 1 (sourceObjectEncodeOnto child suffix)) 40 (left right : pair 2 (sourceObjectEncodeOnto left (sourceObjectEncodeOnto right suffix))) 41 tree 42 sourceObjectEncode tree = sourceObjectEncodeOnto tree t 43 44 sourceObjectDecode bytes = 45 lazyList 46 (_ : err "truncated tree-term" bytes) 47 (tag rest : 48 lazyBool 49 (_ : ok t rest) 50 (_ : lazyBool 51 (_ : lazyResult 52 (problem remaining : err problem remaining) 53 (child remaining : ok (t child) remaining) 54 (sourceObjectDecode rest)) 55 (_ : lazyBool 56 (_ : lazyResult 57 (problem remaining : err problem remaining) 58 (left remaining : lazyResult 59 (problem tail : err problem tail) 60 (right tail : ok (t left right) tail) 61 (sourceObjectDecode remaining)) 62 (sourceObjectDecode rest)) 63 (_ : err "invalid tree-term tag" rest) 64 (equal? tag 2)) 65 (equal? tag 1)) 66 (equal? tag 0)) 67 bytes 68 69 sourceObjectDecodeComplete bytes = 70 lazyResult 71 (problem remaining : err problem remaining) 72 (tree remaining : lazyList 73 (_ : ok tree t) 74 (_ _ : err "trailing tree-term bytes" t) 75 remaining) 76 (sourceObjectDecode bytes) 77 78 -- The shard is taken by finite destructuring: it must not cause recursion 79 -- over an abstract hash during fresh-store normalization. 80 sourceObjectShard hash = 81 matchList t (a r0 : 82 matchList t (b r1 : 83 matchList t (c _ : pair a (pair b (pair c t))) r1) r0) hash 84 sourceObjectPath root hash = 85 append root (append "/objects/" (append (sourceObjectShard hash) 86 (append "/" hash))) 87 sourceObjectDigest domain payload = 88 sha256Hex (append domain (pair 0 payload)) 89 90 -- Native math assumes canonical naturals. Keep the existing behavior for 91 -- arbitrary trees: only canonical bytes use the binary comparison fast path. 92 -- Canonical-byte helpers stay private; malformed trees retain the reference path. 93 sourceObjectByteLeaf? value = triage true (_ : false) (_ _ : false) value 94 sourceObjectByteBit? value = triage true (child : sourceObjectByteLeaf? child) (_ _ : false) value 95 sourceObjectByteOne? value = triage false (child : sourceObjectByteLeaf? child) (_ _ : false) value 96 sourceObjectByteWithin value budget = (triage 97 true 98 (_ : false) 99 (bit rest : lazyBool 100 (_ : lazyBool 101 (_ : sourceObjectByteOne? bit) 102 (_ : andLazy? (sourceObjectByteBit? bit) (_ : sourceObjectByteWithin rest (pred_ budget))) 103 (sourceObjectByteLeaf? rest)) 104 (_ : false) 105 (not? (isZero_? budget))) 106 value) 107 sourceObjectCanonicalByte value = sourceObjectByteWithin value 8 108 -- This compatibility path must not call base's canonical-only arithmetic. 109 -- The historical predecessor leaves Stem values unchanged and interprets any 110 -- non-Leaf bit/tail as truthy. Comparison counts down its finite byte bound; 111 -- structural equality (not numeric equality) controls the strict endpoint. 112 sourceObjectReferencePred value = (triage 113 0 114 (child : t child) 115 (bit rest : lazyBool 116 (_ : matchBool (t t rest) 0 rest) 117 (_ : t (t t) (sourceObjectReferencePred rest)) bit) 118 value) 119 sourceObjectReferenceLte value bound = (lazyBool 120 (_ : true) 121 (_ : lazyBool (_ : false) 122 (_ : sourceObjectReferenceLte (sourceObjectReferencePred value) 123 (sourceObjectReferencePred bound)) (isZero_? bound)) 124 (isZero_? value)) 125 sourceObjectReferenceLt value bound = (and? 126 (sourceObjectReferenceLte value bound) (not? (equal? value bound))) 127 sourceObjectHashByteReference? byte = (or? 128 (and? (not? (sourceObjectReferenceLt byte 48)) (sourceObjectReferenceLte byte 57)) 129 (and? (not? (sourceObjectReferenceLt byte 97)) (sourceObjectReferenceLte byte 102))) 130 sourceObjectHashByte? byte = (lazyBool 131 (_ : N.lowerHex byte) 132 (_ : sourceObjectHashByteReference? byte) 133 (sourceObjectCanonicalByte byte)) 134 sourceObjectHashHex bytes = (lazyList 135 (_ : true) 136 (byte rest : andLazy? (sourceObjectHashByte? byte) (_ : sourceObjectHashHex rest)) 137 bytes) 138 sourceObjectHashValid hash = 139 andLazy? (equal? (length hash) 64) 140 (_ : sourceObjectHashHex hash) 141 142 sourceObjectVerify domain payload expected = 143 144 onResult_ (sourceObjectDigest domain payload) 145 (problem : pure (err problem t)) 146 (actual : lazyBool 147 (_ : pure (ok payload t)) 148 (_ : pure (err "CAS digest mismatch" t)) 149 (equal? actual expected)) 150 151 sourceObjectGet root domain hash = 152 lazyBool 153 (_ : onResult_ (readFile (sourceObjectPath root hash)) 154 (problem : pure (err problem t)) 155 (payload : sourceObjectVerify domain payload hash)) 156 (_ : pure (err "invalid CAS digest" t)) 157 (sourceObjectHashValid hash) 158 159 sourceObjectStore root domain payload = 160 onOk_ (sourceObjectDigest domain payload) (hash : 161 onOk_ (createDirectory root) (_ : 162 onOk_ (createDirectory (append root "/objects")) (_ : 163 onOk_ (createDirectory (append root (append "/objects/" 164 (sourceObjectShard hash)))) (_ : 165 sourceObjectStoreAt root domain payload hash)))) 166 167 -- Host publishes via a unique same-directory temp and an atomic no-replace 168 -- link; tricu owns the object identity and verifies even a racing winner. 169 sourceObjectStoreAt root domain payload hash = 170 onOk_ (writeBytesIfAbsent (sourceObjectPath root hash) payload) (_ : 171 onResult_ (sourceObjectGet root domain hash) 172 (problem : pure (err problem t)) 173 (old : lazyBool 174 (_ : pure (ok hash t)) 175 (_ : pure (err "CAS object exists with different bytes" t)) 176 (equal? old payload))) 177 178 -- tricu owns sharding/directories; the host hashes and atomically transports 179 -- the inert tree in the same canonical format, with verified no-replace writes. 180 sourceObjectPutTree root tree = 181 onOk_ (hashTreeTerm tree) (hash : 182 onOk_ (createDirectory root) (_ : 183 onOk_ (createDirectory (append root "/objects")) (_ : 184 onOk_ (createDirectory (append root (append "/objects/" 185 (sourceObjectShard hash)))) (_ : 186 onOk_ (writeTreeTermIfAbsent (sourceObjectPath root hash) hash tree) 187 (_ : pure (ok hash t)))))) 188 -- Typed verified transport avoids expanding raw executable bytes into a 189 -- tricu byte list for hashing and decoding. The portable codec stays available 190 -- as an independent reference; this path does not silently fall back to it. 191 sourceObjectGetTree root hash = 192 lazyBool 193 (_ : readTreeTerm (sourceObjectPath root hash) hash) 194 (_ : pure (err "invalid CAS digest" t)) 195 (sourceObjectHashValid hash) 196