tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

c4da73ae1cf8bab999cce2ea3f0054928d571e0469d9b32d8120e9fa98f0e085.tri (7006B)

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