tricu

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

server.tri (4674B)

      1 !import prelude *
      2 !import http *
      3 !import native_math as Nat
      4 !export *
      5 
      6 -- Store root is trusted configuration. Every read/write entrypoint must validate
      7 -- a hash before passing it to these pure path constructors.
      8 pathJoin  parent child = append parent (append "/" child)
      9 objectDir root shard   = pathJoin (pathJoin root "objects") shard
     10 
     11 hashShard [a | [b | [c | _]]] = [a b c]
     12 hashShard [a | [b | _]]       = [a b]
     13 hashShard [a | _]             = [a]
     14 hashShard _                   = []
     15 
     16 bundleObjectPath root hash = pathJoin (objectDir root (hashShard hash)) (append hash ".arboricx")
     17 
     18 -- Exact canonical lowercase SHA-256 spelling. Literal patterns, unlike numeric
     19 -- range predicates, reject malformed numeral trees without normalizing them.
     20 -- Disjoint compact-bit ranges: 48..55, 56..57, 97, 98..99,
     21 -- 100..101, 102. Every captured bit is checked as an exact Boolean.
     22 bundleBit? t     = true
     23 bundleBit? (t t) = true
     24 bundleBit? _     = false
     25 bundleHexByte? (a, (b, (c, 6))) = and? (bundleBit? a) (and? (bundleBit? b) (bundleBit? c))
     26 bundleHexByte? (a, 28)          = bundleBit? a
     27 bundleHexByte? 97               = true
     28 bundleHexByte? (a, 49)          = bundleBit? a
     29 bundleHexByte? (a, 50)          = bundleBit? a
     30 bundleHexByte? 102              = true
     31 bundleHexByte? _                = false
     32 
     33 -- The counter is internal and canonical. At zero inspect only the list shape:
     34 -- never force the 65th byte or its suffix, even for arbitrary malformed trees.
     35 bundleHashBytes [] 0 = true
     36 bundleHashBytes _ 0 = false
     37 bundleHashBytes [byte | rest] remaining = case (bundleHexByte? byte) of
     38   ^true = bundleHashBytes rest (Nat.subtract remaining 1)
     39   _ = false
     40 
     41 bundleHashBytes _ _ = false
     42 
     43 -- The fixed SHA-256 boundary uses structural fuel instead of subtracting a
     44 -- compact-natural counter per character. Retain bundleHashBytes for callers
     45 -- that explicitly supply a length. Both stop before inspecting a 65th element.
     46 bundleHashFuel8 tail = t (t (t (t (t (t (t (t tail)))))))
     47 bundleHashFuel64 = bundleHashFuel8 (bundleHashFuel8 (bundleHashFuel8 (bundleHashFuel8
     48   (bundleHashFuel8 (bundleHashFuel8 (bundleHashFuel8 (bundleHashFuel8 t)))))))
     49 bundleHashScan [] t = true
     50 bundleHashScan _ t = false
     51 bundleHashScan [byte | rest] (t fuel) = case bundleHexByte? byte of
     52   ^true = bundleHashScan rest fuel
     53   _ = false
     54 bundleHashScan _ _ = false
     55 bundleHashValid? hash = bundleHashScan hash bundleHashFuel64
     56 bundleHashC = guardC "expected 64 lowercase hexadecimal hash characters" bundleHashValid?
     57 
     58 -- A proper list prefix; return its exact suffix, without normalizing the tail.
     59 stripPrefix [] input = just input
     60 stripPrefix [wanted | prefix] [byte | rest] = case byte of
     61   ^wanted = stripPrefix prefix rest
     62   _ = nothing
     63 
     64 stripPrefix _ _ = nothing
     65 
     66 bundleHashPrefix  = "/_arboricx/bundle/hash/"
     67 bundlePath        = "/_arboricx/bundle"
     68 healthPath        = "/_arboricx/health"
     69 bundleContentType = "application/vnd.arboricx.bundle"
     70 
     71 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>"
     72 
     73 bundleResponse bytes = response 200 bundleContentType bytes
     74 
     75 -- Read-only exact-version index. Administrative publication happens locally;
     76 -- this route never resolves dependencies or executes fetched code. HTTP input
     77 -- bytes are canonical naturals. Scan at most 128 bytes per path component.
     78 packagePrefix = "/_arboricx/package/"
     79 packageAlphaNum? byte = (or? (Nat.inRange byte 48 57)
     80   (or? (Nat.inRange byte 65 90) (Nat.inRange byte 97 122)))
     81 packageByte? byte = (or? (packageAlphaNum? byte)
     82   (or? (equal? byte 46) (or? (equal? byte 95) (equal? byte 45))))
     83 packageVersion [] reversed _ = just (reverse reversed)
     84 packageVersion _ _ 0 = nothing
     85 packageVersion [byte | rest] reversed remaining = case (packageByte? byte) of
     86   ^true = packageVersion rest (pair byte reversed) (Nat.subtract remaining 1)
     87   _ = nothing
     88 
     89 packageVersion _ _ _ = nothing
     90 packageName [47 | [first | rest]] reversed _ = case (packageAlphaNum? first) of
     91   ^true = case (packageVersion rest [first] 127) of
     92     (t version) = just (pair (reverse reversed) version)
     93     _ = nothing
     94   _ = nothing
     95 
     96 packageName _ _ 0 = nothing
     97 packageName [byte | rest] reversed remaining = case (packageByte? byte) of
     98   ^true = packageName rest (pair byte reversed) (Nat.subtract remaining 1)
     99   _ = nothing
    100 
    101 packageName _ _ _ = nothing
    102 packageTarget [first | rest] = case (packageAlphaNum? first) of
    103   ^true = packageName rest [first] 127
    104   _ = nothing
    105 
    106 packageTarget _ = nothing