08c75183108223f511d2ddf3c887525dbdd1b30ae2edef9dae8187d15c3f4099.tri (5793B)
1 !import base as B 2 !import handlers as H 3 !import io as HostIO 4 !import io_storage as Storage 5 !import io_artifacts as Stream 6 !import arboricx_server as Store 7 !export load 8 !export loadFrom 9 !export publish 10 !export publishTo 11 !export withFilesystem 12 !export withFilesystemFor 13 !export prepareFilesystem 14 !export publishStream 15 16 -- Domain Results always have empty remainders. Callers map them to HTTP statuses. 17 -- Invalid digests are ordinary input failures; 18 -- malformed request/reply protocols are interpreter failures. 19 -- Eight bounded bit steps, each checking exact Boolean shape and canonical 20 -- termination. The fixed continuation chain validates canonical octet shape 21 -- structurally, including the final high bit. 22 octetEnd = B.triage (t t) (_ : t) (_ _ : t) 23 octetStep next value = B.triage (t t) (_ : t) 24 (bit tail : B.triage 25 (B.triage t (_ : t) (_ _ : next tail) tail) 26 (child : B.triage (next tail) (_ : t) (_ _ : t) child) 27 (_ _ : t) bit) 28 value 29 octetValid = octetStep (octetStep (octetStep (octetStep 30 (octetStep (octetStep (octetStep (octetStep octetEnd))))))) 31 byteC = B.guardC "expected octet" octetValid 32 33 -- These predicates preserve the original accepted list. The scanner allocates 34 -- one final Result and retains the first-error diagnostic and caller's remainder. 35 bytesC value rest = let rec 36 walk remaining = B.triage 37 (B.contractOk value rest) 38 (_ : B.contractErr "not a list" rest) 39 (byte tail : case octetValid byte of 40 (t t) = walk tail 41 _ = B.contractErr "expected octet" rest) 42 remaining 43 in walk value 44 45 checkedDigest service digest next = H.checkWith Store.bundleHashC digest 46 (message : H.pure (B.err ["invalid-digest" message] t)) 47 (original : H.fail "invalid-contract" service "load" original) 48 next 49 loadFrom service digest = checkedDigest service digest 50 (checked : H.checkedRequest service "load" B.anyC loadReplyC checked) 51 load digest = loadFrom "artifacts" digest 52 publishTo service bytes = H.checkedRequest service "publish" bytesC publishReplyC bytes 53 publish bytes = publishTo "artifacts" bytes 54 55 loadReplyC value{((t t), (bytes, t))} rest = case B.checkContract bytesC bytes of 56 ((t t), _) = B.contractOk value rest 57 _ = B.contractErr "expected artifact bytes" rest 58 loadReplyC value{(t, (message, t))} rest = B.contractOk value rest 59 loadReplyC _ rest = B.contractErr "expected artifact-load Result with empty remainder" rest 60 publishReplyC value{((t t), (digest, t))} rest = case B.checkContract Store.bundleHashC digest of 61 ((t t), _) = B.contractOk value rest 62 _ = B.contractErr "expected canonical artifact digest" rest 63 publishReplyC value{(t, (message, t))} rest = B.contractOk value rest 64 publishReplyC _ rest = B.contractErr "expected artifact-publication Result with empty remainder" rest 65 66 -- Native adapter for the domain interface. Limits count bytes; heap usage 67 -- requires a separate bound. Roots/paths follow OS authority. Verify and sync 68 -- every immutable winner, preserving corrupt winners for diagnosis. Loads 69 -- authenticate the exact bytes returned to the caller. 70 loadNative root limit digest = do HostIO.onOk 71 bytes <- Storage.readBytes (Store.bundleObjectPath root digest) limit 72 actual <- Storage.hashBytes limit bytes 73 case B.equal? actual digest of 74 (t t) = HostIO.pure (B.ok bytes t) 75 _ = HostIO.pure (B.err ["integrity-failed" "artifacts/load" "digest mismatch" "unknown"] t) 76 77 publishNative root limit bytes = do HostIO.onOk 78 digest <- Storage.hashBytes limit bytes 79 case B.checkContract Store.bundleHashC digest of 80 ((t t), (checked, t)) = let directory = Store.objectDir root (Store.hashShard checked) in do HostIO.onOk 81 HostIO.ensureDirectory directory 82 HostIO.syncDirectory (Store.pathJoin root "objects") 83 Storage.publishBytes directory (Store.bundleObjectPath root checked) 0 limit bytes 84 HostIO.pure (B.ok checked t) 85 _ = HostIO.fail "Invalid artifact digest reply" 86 87 filesystem root limit service "load" digest = checkedDigest service digest 88 (checked : H.liftIO (loadNative root limit checked)) 89 filesystem root limit service "publish" bytes = H.checkWith bytesC bytes 90 (message : H.fail "invalid-request" service "publish" message) 91 (original : H.fail "invalid-contract" service "publish" original) 92 (checked : H.liftIO (publishNative root limit checked)) 93 filesystem _ _ service operation payload = H.forward service operation payload 94 withFilesystemFor service root limit action = H.handle service (filesystem root limit service) action 95 withFilesystem root limit action = withFilesystemFor "artifacts" root limit action 96 97 -- Parent-first initialization; the configured root's parent must already exist. 98 -- Directory-entry synchronization follows host filesystem guarantees. 99 ensure path = do HostIO.onOk 100 HostIO.ensureDirectory path 101 HostIO.syncDirectory (Storage.parentPath path) 102 prepareFilesystem root = H.liftIO (do HostIO.onOk 103 ensure root 104 ensure (Store.pathJoin root "tmp") 105 ensure (Store.pathJoin root "objects") 106 ensure (Store.pathJoin root "aliases") 107 ensure (Store.pathJoin (Store.pathJoin root "aliases") "names") 108 ensure (Store.pathJoin (Store.pathJoin root "aliases") "packages") 109 ensure (Store.pathJoin root "manifests") 110 HostIO.pure (B.ok t t)) 111 112 -- Bounded producer, existing registry layout. The shard is chosen only after 113 -- hashing the complete stream incrementally. Temporary and object directories 114 -- must share a filesystem. 115 streamDestination root digest = H.liftIO (do HostIO.onOk 116 HostIO.ensureDirectory (Store.objectDir root (Store.hashShard digest)) 117 HostIO.syncDirectory (Store.pathJoin root "objects") 118 HostIO.pure (B.ok (Store.bundleObjectPath root digest) t)) 119 publishStream root expected producer = Stream.publishWith 120 (Store.pathJoin root "tmp") expected (streamDestination root) producer