tricu

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

5e4d9186f5235078c786432b6ac8a2952ee8c87bed8f808503d5107daaa07bac.tri (7339B)

      1 !import base as B
      2 !import io as IO
      3 !import handlers as H
      4 !import io_v2 as V2
      5 !import io_v2_storage as Storage
      6 !import io_v2_artifacts as Stream
      7 !import arboricx_server as Store
      8 !export load
      9 !export loadFrom
     10 !export publish
     11 !export publishTo
     12 !export withFilesystem
     13 !export withFilesystemFor
     14 !export prepareFilesystem
     15 !export withFilesystemV2
     16 !export withFilesystemForV2
     17 !export prepareFilesystemV2
     18 !export publishStreamV2
     19 
     20 -- Domain Results always have empty remainders. HTTP status mapping belongs to
     21 -- the caller, not this interface. Invalid digests are ordinary input failures;
     22 -- malformed request/reply protocols are interpreter failures.
     23 -- Eight bounded bit steps, each checking exact Boolean shape and canonical
     24 -- termination. The continuation chain replaces a per-bit recursive fuel test;
     25 -- it neither accepts redundant high zeros nor delegates to unchecked arithmetic.
     26 octetEnd = B.triage (t t) (_ : t) (_ _ : t)
     27 octetStep next value = B.triage (t t) (_ : t)
     28   (bit tail : B.triage
     29     (B.triage t (_ : t) (_ _ : next tail) tail)
     30     (child : B.triage (next tail) (_ : t) (_ _ : t) child)
     31     (_ _ : t) bit)
     32   value
     33 octetValid = octetStep (octetStep (octetStep (octetStep
     34   (octetStep (octetStep (octetStep (octetStep octetEnd)))))))
     35 byteC = B.guardC "expected octet" octetValid
     36 
     37 -- These contracts are predicates, never element transformers. Scan without
     38 -- rebuilding the accepted list or allocating a Result for each accepted byte.
     39 -- Preserve the old first-error diagnostics and the caller's remainder.
     40 bytesC value rest = let rec
     41   walk remaining = B.triage
     42     (B.contractOk value rest)
     43     (_ : B.contractErr "not a list" rest)
     44     (byte tail : case octetValid byte of
     45       (t t) = walk tail
     46       _ = B.contractErr "expected octet" rest)
     47     remaining
     48   in walk value
     49 
     50 loadFrom service digest = case B.checkContract Store.bundleHashC digest of
     51   ((t t), (checked, t)) = H.checkedRequest service "load" B.anyC loadReplyC checked
     52   (t, (message, _)) = H.pure (B.err ["invalid-digest" message] t)
     53   _ = H.fail "invalid-contract" service "load" digest
     54 load digest = loadFrom "artifacts" digest
     55 publishTo service bytes = H.checkedRequest service "publish" bytesC publishReplyC bytes
     56 publish bytes = publishTo "artifacts" bytes
     57 
     58 loadReplyC value{((t t), (bytes, t))} rest = case B.checkContract bytesC bytes of
     59   ((t t), _) = B.contractOk value rest
     60   _ = B.contractErr "expected artifact bytes" rest
     61 loadReplyC value{(t, (message, t))} rest = B.contractOk value rest
     62 loadReplyC _ rest = B.contractErr "expected artifact-load Result with empty remainder" rest
     63 publishReplyC value{((t t), (digest, t))} rest = case B.checkContract Store.bundleHashC digest of
     64   ((t t), _) = B.contractOk value rest
     65   _ = B.contractErr "expected canonical artifact digest" rest
     66 publishReplyC value{(t, (message, t))} rest = B.contractOk value rest
     67 publishReplyC _ rest = B.contractErr "expected artifact-publication Result with empty remainder" rest
     68 
     69 -- Recheck the digest in the adapter: raw H.request callers do not get an
     70 -- unchecked path-taking entrypoint. Host permissions remain authoritative.
     71 filesystem root service "load" digest = case B.checkContract Store.bundleHashC digest of
     72   ((t t), (checked, t)) = H.liftIO (IO.readFile (Store.bundleObjectPath root checked))
     73   (t, (message, _)) = H.pure (B.err ["invalid-digest" message] t)
     74   _ = H.fail "invalid-contract" service "load" digest
     75 filesystem root service "publish" bytes = case B.checkContract bytesC bytes of
     76   ((t t), (checked, t)) = H.liftIO (Store.putBundle root checked)
     77   (t, (message, _)) = H.fail "invalid-request" service "publish" message
     78   _ = H.fail "invalid-contract" service "publish" bytes
     79 filesystem _ service operation payload = H.forward service operation payload
     80 withFilesystemFor service root action = H.handle service (filesystem root service) action
     81 withFilesystem root action = withFilesystemFor "artifacts" root action
     82 
     83 -- Explicit application startup, not repeated implicitly on every request.
     84 -- Returns the existing store initializer's ordinary Result; requires write grants.
     85 prepareFilesystem root = H.liftIO (Store.ensureStore root)
     86 
     87 -- Native v2 adapter for the same domain interface. Limits are explicit byte
     88 -- budgets, not heap guarantees. Roots/paths follow OS authority, not v1 grants.
     89 -- Objects are immutable: verify and sync every winner; never repair corruption
     90 -- by overwriting it. Loads authenticate the exact bytes returned to the caller.
     91 loadV2 root limit digest = do V2.onOk
     92   bytes <- Storage.readBytes (Store.bundleObjectPath root digest) limit
     93   actual <- Storage.hashBytes limit bytes
     94   case B.equal? actual digest of
     95     (t t) = V2.pure (B.ok bytes t)
     96     _ = V2.pure (B.err ["integrity-failed" "artifacts/load" "digest mismatch" "unknown"] t)
     97 
     98 publishV2 root limit bytes = do V2.onOk
     99   digest <- Storage.hashBytes limit bytes
    100   case B.checkContract Store.bundleHashC digest of
    101     ((t t), (checked, t)) = let directory = Store.objectDir root (Store.hashShard checked) in do V2.onOk
    102       V2.ensureDirectory directory
    103       V2.syncDirectory (Store.pathJoin root "objects")
    104       Storage.publishBytes directory (Store.bundleObjectPath root checked) 0 limit bytes
    105       V2.pure (B.ok checked t)
    106     _ = V2.fail "Invalid artifact digest reply"
    107 
    108 filesystemV2 root limit service "load" digest = case B.checkContract Store.bundleHashC digest of
    109   ((t t), (checked, t)) = H.liftIO (loadV2 root limit checked)
    110   (t, (message, _)) = H.pure (B.err ["invalid-digest" message] t)
    111   _ = H.fail "invalid-contract" service "load" digest
    112 filesystemV2 root limit service "publish" bytes = case B.checkContract bytesC bytes of
    113   ((t t), (checked, t)) = H.liftIO (publishV2 root limit checked)
    114   (t, (message, _)) = H.fail "invalid-request" service "publish" message
    115   _ = H.fail "invalid-contract" service "publish" bytes
    116 filesystemV2 _ _ service operation payload = H.forward service operation payload
    117 withFilesystemForV2 service root limit action = H.handle service (filesystemV2 root limit service) action
    118 withFilesystemV2 root limit action = withFilesystemForV2 "artifacts" root limit action
    119 
    120 -- Parent-first initialization; the configured root's parent must already exist.
    121 -- Sync directory entries under host filesystem guarantees, not a crash theorem.
    122 ensureV2 path = do V2.onOk
    123   V2.ensureDirectory path
    124   V2.syncDirectory (Storage.parentPath path)
    125 prepareFilesystemV2 root = H.liftIO (do V2.onOk
    126   ensureV2 root
    127   ensureV2 (Store.pathJoin root "tmp")
    128   ensureV2 (Store.pathJoin root "objects")
    129   ensureV2 (Store.pathJoin root "aliases")
    130   ensureV2 (Store.pathJoin (Store.pathJoin root "aliases") "names")
    131   ensureV2 (Store.pathJoin (Store.pathJoin root "aliases") "packages")
    132   ensureV2 (Store.pathJoin root "manifests")
    133   V2.pure (B.ok t t))
    134 
    135 -- Bounded producer, existing registry layout. The shard is chosen only after
    136 -- hashing the complete stream, never by buffering the whole body or guessing its
    137 -- digest. Temporary and object directories must share a filesystem.
    138 streamDestination root digest = H.liftIO (do V2.onOk
    139   V2.ensureDirectory (Store.objectDir root (Store.hashShard digest))
    140   V2.syncDirectory (Store.pathJoin root "objects")
    141   V2.pure (B.ok (Store.bundleObjectPath root digest) t))
    142 publishStreamV2 root expected producer = Stream.publishWith
    143   (Store.pathJoin root "tmp") expected (streamDestination root) producer