tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

fe110d74ff62d9f16683bae0adcf82c65ce5c4c18cf2ada50927bf2509e0fa5e.tri (6069B)

      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. HTTP status mapping belongs to
     17 -- the caller, not this interface. 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 continuation chain replaces a per-bit recursive fuel test;
     21 -- it neither accepts redundant high zeros nor delegates to unchecked arithmetic.
     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 contracts are predicates, never element transformers. Scan without
     34 -- rebuilding the accepted list or allocating a Result for each accepted byte.
     35 -- Preserve the old first-error diagnostics and the caller's remainder.
     36 bytesC value rest = let rec
     37   walk remaining = B.triage
     38     (B.contractOk value rest)
     39     (_ : B.contractErr "not a list" rest)
     40     (byte tail : case octetValid byte of
     41       (t t) = walk tail
     42       _ = B.contractErr "expected octet" rest)
     43     remaining
     44   in walk value
     45 
     46 loadFrom service digest = case B.checkContract Store.bundleHashC digest of
     47   ((t t), (checked, t)) = H.checkedRequest service "load" B.anyC loadReplyC checked
     48   (t, (message, _)) = H.pure (B.err ["invalid-digest" message] t)
     49   _ = H.fail "invalid-contract" service "load" digest
     50 load digest = loadFrom "artifacts" digest
     51 publishTo service bytes = H.checkedRequest service "publish" bytesC publishReplyC bytes
     52 publish bytes = publishTo "artifacts" bytes
     53 
     54 loadReplyC value{((t t), (bytes, t))} rest = case B.checkContract bytesC bytes of
     55   ((t t), _) = B.contractOk value rest
     56   _ = B.contractErr "expected artifact bytes" rest
     57 loadReplyC value{(t, (message, t))} rest = B.contractOk value rest
     58 loadReplyC _ rest = B.contractErr "expected artifact-load Result with empty remainder" rest
     59 publishReplyC value{((t t), (digest, t))} rest = case B.checkContract Store.bundleHashC digest of
     60   ((t t), _) = B.contractOk value rest
     61   _ = B.contractErr "expected canonical artifact digest" rest
     62 publishReplyC value{(t, (message, t))} rest = B.contractOk value rest
     63 publishReplyC _ rest = B.contractErr "expected artifact-publication Result with empty remainder" rest
     64 
     65 -- Native v2 adapter for the same domain interface. Limits are explicit byte
     66 -- budgets, not heap guarantees. Roots/paths follow OS authority, not v1 grants.
     67 -- Objects are immutable: verify and sync every winner; never repair corruption
     68 -- by overwriting it. Loads authenticate the exact bytes returned to the caller.
     69 loadV2 root limit digest = do V2.onOk
     70   bytes <- Storage.readBytes (Store.bundleObjectPath root digest) limit
     71   actual <- Storage.hashBytes limit bytes
     72   case B.equal? actual digest of
     73     (t t) = V2.pure (B.ok bytes t)
     74     _ = V2.pure (B.err ["integrity-failed" "artifacts/load" "digest mismatch" "unknown"] t)
     75 
     76 publishV2 root limit bytes = do V2.onOk
     77   digest <- Storage.hashBytes limit bytes
     78   case B.checkContract Store.bundleHashC digest of
     79     ((t t), (checked, t)) = let directory = Store.objectDir root (Store.hashShard checked) in do V2.onOk
     80       V2.ensureDirectory directory
     81       V2.syncDirectory (Store.pathJoin root "objects")
     82       Storage.publishBytes directory (Store.bundleObjectPath root checked) 0 limit bytes
     83       V2.pure (B.ok checked t)
     84     _ = V2.fail "Invalid artifact digest reply"
     85 
     86 filesystemV2 root limit service "load" digest = case B.checkContract Store.bundleHashC digest of
     87   ((t t), (checked, t)) = H.liftIO (loadV2 root limit checked)
     88   (t, (message, _)) = H.pure (B.err ["invalid-digest" message] t)
     89   _ = H.fail "invalid-contract" service "load" digest
     90 filesystemV2 root limit service "publish" bytes = case B.checkContract bytesC bytes of
     91   ((t t), (checked, t)) = H.liftIO (publishV2 root limit checked)
     92   (t, (message, _)) = H.fail "invalid-request" service "publish" message
     93   _ = H.fail "invalid-contract" service "publish" bytes
     94 filesystemV2 _ _ service operation payload = H.forward service operation payload
     95 withFilesystemForV2 service root limit action = H.handle service (filesystemV2 root limit service) action
     96 withFilesystemV2 root limit action = withFilesystemForV2 "artifacts" root limit action
     97 
     98 -- Parent-first initialization; the configured root's parent must already exist.
     99 -- Sync directory entries under host filesystem guarantees, not a crash theorem.
    100 ensureV2 path = do V2.onOk
    101   V2.ensureDirectory path
    102   V2.syncDirectory (Storage.parentPath path)
    103 prepareFilesystemV2 root = H.liftIO (do V2.onOk
    104   ensureV2 root
    105   ensureV2 (Store.pathJoin root "tmp")
    106   ensureV2 (Store.pathJoin root "objects")
    107   ensureV2 (Store.pathJoin root "aliases")
    108   ensureV2 (Store.pathJoin (Store.pathJoin root "aliases") "names")
    109   ensureV2 (Store.pathJoin (Store.pathJoin root "aliases") "packages")
    110   ensureV2 (Store.pathJoin root "manifests")
    111   V2.pure (B.ok t t))
    112 
    113 -- Bounded producer, existing registry layout. The shard is chosen only after
    114 -- hashing the complete stream, never by buffering the whole body or guessing its
    115 -- digest. Temporary and object directories must share a filesystem.
    116 streamDestination root digest = H.liftIO (do V2.onOk
    117   V2.ensureDirectory (Store.objectDir root (Store.hashShard digest))
    118   V2.syncDirectory (Store.pathJoin root "objects")
    119   V2.pure (B.ok (Store.bundleObjectPath root digest) t))
    120 publishStreamV2 root expected producer = Stream.publishWith
    121   (Store.pathJoin root "tmp") expected (streamDestination root) producer