tricu

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

7bce76817a1c9a6df5253b7f983a395d833e3622533a2d209c12a5c0f111aa5f.tri (9031B)

      1 !import prelude *
      2 !import io *
      3 !import http *
      4 !import socket *
      5 !import native_math as Nat
      6 !export *
      7 
      8 -- Store root is trusted configuration. These pure path helpers are not guards;
      9 -- every read/write entrypoint must validate a hash before using it as a path.
     10 pathJoin parent child = append parent (append "/" child)
     11 objectDir root shard = pathJoin (pathJoin root "objects") shard
     12 
     13 hashShard [a | [b | [c | _]]] = [a b c]
     14 hashShard [a | [b | _]] = [a b]
     15 hashShard [a | _] = [a]
     16 hashShard _ = []
     17 
     18 bundleObjectPath root hash = pathJoin (objectDir root (hashShard hash)) (append hash ".arboricx")
     19 
     20 -- Exact canonical lowercase SHA-256 spelling. Literal patterns, unlike numeric
     21 -- range predicates, reject malformed numeral trees without normalizing them.
     22 -- Disjoint compact-bit ranges: 48..55, 56..57, 97, 98..99,
     23 -- 100..101, 102. Every captured bit is checked as an exact Boolean.
     24 bundleBit? t = true
     25 bundleBit? (t t) = true
     26 bundleBit? _ = false
     27 bundleHexByte? (a, (b, (c, 6))) = and? (bundleBit? a) (and? (bundleBit? b) (bundleBit? c))
     28 bundleHexByte? (a, 28) = bundleBit? a
     29 bundleHexByte? 97 = true
     30 bundleHexByte? (a, 49) = bundleBit? a
     31 bundleHexByte? (a, 50) = bundleBit? a
     32 bundleHexByte? 102 = true
     33 bundleHexByte? _ = false
     34 
     35 -- The counter is internal and canonical. At zero inspect only the list shape:
     36 -- never force the 65th byte or its suffix, even for arbitrary malformed trees.
     37 bundleHashBytes [] 0 = true
     38 bundleHashBytes _ 0 = false
     39 bundleHashBytes [byte | rest] remaining = case (bundleHexByte? byte) of
     40   ^true = bundleHashBytes rest (Nat.subtract remaining 1)
     41   _ = false
     42 
     43 bundleHashBytes _ _ = false
     44 
     45 -- The fixed SHA-256 boundary uses structural fuel instead of subtracting a
     46 -- compact-natural counter per character. Retain bundleHashBytes for callers
     47 -- that explicitly supply a length. Both stop before inspecting a 65th element.
     48 bundleHashFuel8 tail = t (t (t (t (t (t (t (t tail)))))))
     49 bundleHashFuel64 = bundleHashFuel8 (bundleHashFuel8 (bundleHashFuel8 (bundleHashFuel8
     50   (bundleHashFuel8 (bundleHashFuel8 (bundleHashFuel8 (bundleHashFuel8 t)))))))
     51 bundleHashScan [] t = true
     52 bundleHashScan _ t = false
     53 bundleHashScan [byte | rest] (t fuel) = case bundleHexByte? byte of
     54   ^true = bundleHashScan rest fuel
     55   _ = false
     56 bundleHashScan _ _ = false
     57 bundleHashValid? hash = bundleHashScan hash bundleHashFuel64
     58 bundleHashC = guardC "expected 64 lowercase hexadecimal hash characters" bundleHashValid?
     59 
     60 -- Directory creation already tolerates existing directories in the Haskell
     61 -- driver. Propagate real failures and stop; void would discard those failures.
     62 ensureDir path = mapErrIO "createDirectory: " (createDirectory path)
     63 ensureStore root = (do onOk_
     64   ensureDir root
     65   ensureDir (pathJoin root "tmp")
     66   ensureDir (pathJoin root "objects")
     67   ensureDir (pathJoin root "aliases")
     68   ensureDir (pathJoin (pathJoin root "aliases") "names")
     69   ensureDir (pathJoin (pathJoin root "aliases") "packages")
     70   ensureDir (pathJoin root "manifests")
     71   pure (ok t t))
     72 
     73 -- Hash opaque bytes ourselves: no public unchecked hash-taking writer. Validate
     74 -- even the digest reply before constructing filesystem actions. Atomic writes
     75 -- use host-managed unique staging in the destination directory, not hash.tmp.
     76 -- Existing-object replacement remains supported. A post-publication sync error
     77 -- can leave the new object visible; this is not rollback or bundle validation.
     78 putBundle root bytes = (do onOk_
     79   hash <- mapErrIO "sha256Hex: " (sha256Hex bytes)
     80   case (checkContract bundleHashC hash) of
     81     ((t t), (value, _)) = (do onOk_
     82       ensureDir (objectDir root (hashShard value))
     83       mapErrIO "atomicWriteBytes: " (atomicWriteBytes (bundleObjectPath root value) bytes)
     84       pure (ok value t))
     85     (t, (diagnostic, _)) = pure (err (append "sha256Hex: " diagnostic) t)
     86     _ = pure (err "sha256Hex: Invalid hash contract result" t))
     87 
     88 -- Translate contract failures before IO, preserving HTTP status/message roles.
     89 getBundleByHash root hash = case (checkContract bundleHashC hash) of
     90   ((t t), (value, _)) = (do bind
     91     reply <- readFile (bundleObjectPath root value)
     92     case reply of
     93       ((t t), (bytes, _)) = pure (ok bytes t)
     94       (t, (message, _)) = pure (err 404 message)
     95       _ = pure (err 404 "Invalid read result"))
     96   (t, (diagnostic, _)) = pure (err 400 diagnostic)
     97   _ = pure (err 400 "Invalid hash contract result")
     98 
     99 -- A proper list prefix; return its exact suffix, without normalizing the tail.
    100 stripPrefix [] input = just input
    101 stripPrefix [wanted | prefix] [byte | rest] = case byte of
    102   ^wanted = stripPrefix prefix rest
    103   _ = nothing
    104 
    105 stripPrefix _ _ = nothing
    106 
    107 bundleHashPrefix = "/_arboricx/bundle/hash/"
    108 bundlePath = "/_arboricx/bundle"
    109 healthPath = "/_arboricx/health"
    110 bundleContentType = "application/vnd.arboricx.bundle"
    111 
    112 htmlLandingPage = "<!DOCTYPE html><html><head><meta name='viewport' content='width=device-width, initial-scale=1'><title>Arboricx Server</title></head><body><h1>Arboricx Server</h1><p>Bundle registry</p><p><a href='https://git.eversole.co/James/tricu'>Made with Love (and trees, lots of trees)</a></p></body></html>"
    113 
    114 bundleResponse bytes = response 200 bundleContentType bytes
    115 
    116 serveBundleHash root hash = (do bind
    117   reply <- getBundleByHash root hash
    118   case reply of
    119     ((t t), (bytes, _)) = pure (bundleResponse bytes)
    120     (t, (status, message)) = pure (errorResponse status message)
    121     _ = pure (errorResponse 500 "Invalid bundle result"))
    122 
    123 healthRoute "GET" ^healthPath = pure (okResponse "OK\n")
    124 healthRoute _ _ = pure notFoundResponse
    125 
    126 putBundleRoute root "POST" ^bundlePath body = (do bind
    127   reply <- putBundle root body
    128   case reply of
    129     ((t t), (hash, _)) = pure (createdResponse hash)
    130     (t, (message, _)) = pure (badRequestResponse (append "Upload failed: " message))
    131     _ = pure (errorResponse 500 "Invalid upload result"))
    132 
    133 putBundleRoute _ _ _ _ = pure notFoundResponse
    134 
    135 getBundleRoute root "GET" target = case (stripPrefix bundleHashPrefix target) of
    136   (t hash) = serveBundleHash root hash
    137   _ = pure notFoundResponse
    138 
    139 getBundleRoute _ _ _ = pure notFoundResponse
    140 
    141 -- Read-only exact-version index. Administrative publication happens locally;
    142 -- this route never resolves dependencies or executes fetched code. HTTP input
    143 -- bytes are canonical naturals. Scan at most 128 bytes per path component.
    144 packagePrefix = "/_arboricx/package/"
    145 packageAlphaNum? byte = (or? (Nat.inRange byte 48 57)
    146   (or? (Nat.inRange byte 65 90) (Nat.inRange byte 97 122)))
    147 packageByte? byte = (or? (packageAlphaNum? byte)
    148   (or? (equal? byte 46) (or? (equal? byte 95) (equal? byte 45))))
    149 packageVersion [] reversed _ = just (reverse reversed)
    150 packageVersion _ _ 0 = nothing
    151 packageVersion [byte | rest] reversed remaining = case (packageByte? byte) of
    152   ^true = packageVersion rest (pair byte reversed) (Nat.subtract remaining 1)
    153   _ = nothing
    154 
    155 packageVersion _ _ _ = nothing
    156 packageName [47 | [first | rest]] reversed _ = case (packageAlphaNum? first) of
    157   ^true = case (packageVersion rest [first] 127) of
    158     (t version) = just (pair (reverse reversed) version)
    159     _ = nothing
    160   _ = nothing
    161 
    162 packageName _ _ 0 = nothing
    163 packageName [byte | rest] reversed remaining = case (packageByte? byte) of
    164   ^true = packageName rest (pair byte reversed) (Nat.subtract remaining 1)
    165   _ = nothing
    166 
    167 packageName _ _ _ = nothing
    168 packageTarget [first | rest] = case (packageAlphaNum? first) of
    169   ^true = packageName rest [first] 127
    170   _ = nothing
    171 
    172 packageTarget _ = nothing
    173 
    174 servePackage root target = case (packageTarget target) of
    175   (t (name, version)) = (do bind
    176     reply <- readFile (pathJoin (pathJoin (pathJoin root "packages") name) version)
    177     case reply of
    178       ((t t), (bytes, _)) = pure (response 200 "application/vnd.arboricx.package-release" bytes)
    179       _ = pure (errorResponse 404 "Package release not found"))
    180   _ = pure (badRequestResponse "Invalid package name/version")
    181 
    182 getRegistryRoute root target = case (stripPrefix packagePrefix target) of
    183   (t suffix) = servePackage root suffix
    184   _ = getBundleRoute root "GET" target
    185 
    186 arboricxRouter _ "GET" "/" _ _ = pure (htmlResponse htmlLandingPage)
    187 arboricxRouter _ "GET" ^healthPath _ _ = healthRoute "GET" healthPath
    188 arboricxRouter root "GET" target _ _ = getRegistryRoute root target
    189 arboricxRouter root "POST" target _ body = putBundleRoute root "POST" target body
    190 arboricxRouter _ _ _ _ _ = pure notFoundResponse
    191 
    192 arboricxHandler root client peer = httpHandlerIO (arboricxRouter root) client peer
    193 
    194 -- Close a newly acquired socket on ordinary bind/listen failures. As elsewhere,
    195 -- finally does not catch terminal abortIO or host exceptions; successful serving
    196 -- delegates scheduling/accept policy to serveForever, without a shutdown hook.
    197 arboricxServer root addr port = (let
    198   failed message = pure (err message t)
    199   opened server = (let
    200     rejected message = finally (failed message) (closeSocket_ server)
    201     ready _ = serveForever server (arboricxHandler root)
    202     in onResult_ (do onOk_
    203       bindSocket server addr port
    204       listen server 128)
    205       rejected ready)
    206   in onResult_ socket failed opened)