ee1531f86d1faaef4ce7b1ca9151bd2e7b10c3fc0574d0db67ddfce6c012c4e3.tri (5733B)
1 !import base as B 2 !import handlers as H 3 !import io_v2 as V2 4 !import io_v2_storage as Storage 5 !import io_v2_artifacts as Stream 6 !import arboricx_server as Store 7 !export load 8 !export loadFrom 9 !export publish 10 !export publishTo 11 !export withFilesystemV2 12 !export withFilesystemForV2 13 !export prepareFilesystemV2 14 !export publishStreamV2 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 v2 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 loadV2 root limit digest = do V2.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) = V2.pure (B.ok bytes t) 75 _ = V2.pure (B.err ["integrity-failed" "artifacts/load" "digest mismatch" "unknown"] t) 76 77 publishV2 root limit bytes = do V2.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 V2.onOk 81 V2.ensureDirectory directory 82 V2.syncDirectory (Store.pathJoin root "objects") 83 Storage.publishBytes directory (Store.bundleObjectPath root checked) 0 limit bytes 84 V2.pure (B.ok checked t) 85 _ = V2.fail "Invalid artifact digest reply" 86 87 filesystemV2 root limit service "load" digest = checkedDigest service digest 88 (checked : H.liftIO (loadV2 root limit checked)) 89 filesystemV2 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 (publishV2 root limit checked)) 93 filesystemV2 _ _ service operation payload = H.forward service operation payload 94 withFilesystemForV2 service root limit action = H.handle service (filesystemV2 root limit service) action 95 withFilesystemV2 root limit action = withFilesystemForV2 "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 ensureV2 path = do V2.onOk 100 V2.ensureDirectory path 101 V2.syncDirectory (Storage.parentPath path) 102 prepareFilesystemV2 root = H.liftIO (do V2.onOk 103 ensureV2 root 104 ensureV2 (Store.pathJoin root "tmp") 105 ensureV2 (Store.pathJoin root "objects") 106 ensureV2 (Store.pathJoin root "aliases") 107 ensureV2 (Store.pathJoin (Store.pathJoin root "aliases") "names") 108 ensureV2 (Store.pathJoin (Store.pathJoin root "aliases") "packages") 109 ensureV2 (Store.pathJoin root "manifests") 110 V2.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 V2.onOk 116 V2.ensureDirectory (Store.objectDir root (Store.hashShard digest)) 117 V2.syncDirectory (Store.pathJoin root "objects") 118 V2.pure (B.ok (Store.bundleObjectPath root digest) t)) 119 publishStreamV2 root expected producer = Stream.publishWith 120 (Store.pathJoin root "tmp") expected (streamDestination root) producer