tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

9e767e8541e080d26a22a10d16bd54b1231f7e4a9b1cde075170224949320347.tri (6624B)

      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 bundleHexByte? 48 = true
     23 bundleHexByte? 49 = true
     24 bundleHexByte? 50 = true
     25 bundleHexByte? 51 = true
     26 bundleHexByte? 52 = true
     27 bundleHexByte? 53 = true
     28 bundleHexByte? 54 = true
     29 bundleHexByte? 55 = true
     30 bundleHexByte? 56 = true
     31 bundleHexByte? 57 = true
     32 bundleHexByte? 97 = true
     33 bundleHexByte? 98 = true
     34 bundleHexByte? 99 = true
     35 bundleHexByte? 100 = true
     36 bundleHexByte? 101 = true
     37 bundleHexByte? 102 = true
     38 bundleHexByte? _ = false
     39 
     40 -- The counter is internal and canonical. At zero inspect only the list shape:
     41 -- never force the 65th byte or its suffix, even for arbitrary malformed trees.
     42 bundleHashBytes [] 0 = true
     43 bundleHashBytes _ 0 = false
     44 bundleHashBytes [byte | rest] remaining = (let
     45   checked ^true = bundleHashBytes rest (Nat.subtract remaining 1)
     46   checked _ = false
     47   in checked (bundleHexByte? byte))
     48 bundleHashBytes _ _ = false
     49 
     50 bundleHashValid? hash = bundleHashBytes hash 64
     51 bundleHashC = guardC "expected 64 lowercase hexadecimal hash characters" bundleHashValid?
     52 
     53 -- Directory creation already tolerates existing directories in the Haskell
     54 -- driver. Propagate real failures and stop; void would discard those failures.
     55 ensureDir path = mapErrIO "createDirectory: " (createDirectory path)
     56 ensureStore root = (do onOk_
     57   ensureDir root
     58   ensureDir (pathJoin root "tmp")
     59   ensureDir (pathJoin root "objects")
     60   ensureDir (pathJoin root "aliases")
     61   ensureDir (pathJoin (pathJoin root "aliases") "names")
     62   ensureDir (pathJoin (pathJoin root "aliases") "packages")
     63   ensureDir (pathJoin root "manifests")
     64   pure (ok t t))
     65 
     66 -- Hash opaque bytes ourselves: no public unchecked hash-taking writer. Validate
     67 -- even the digest reply before constructing filesystem actions. Atomic writes
     68 -- use host-managed unique staging in the destination directory, not hash.tmp.
     69 -- Existing-object replacement remains supported. A post-publication sync error
     70 -- can leave the new object visible; this is not rollback or bundle validation.
     71 putBundle root bytes = (let
     72   rejected diagnostic = pure (err (append "sha256Hex: " diagnostic) t)
     73   checked ((t t), (hash, _)) = (do onOk_
     74     ensureDir (objectDir root (hashShard hash))
     75     mapErrIO "atomicWriteBytes: " (atomicWriteBytes (bundleObjectPath root hash) bytes)
     76     pure (ok hash t))
     77   checked (t, (diagnostic, _)) = rejected diagnostic
     78   checked _ = rejected "Invalid hash contract result"
     79   in do onOk_
     80     hash <- mapErrIO "sha256Hex: " (sha256Hex bytes)
     81     checked (checkContract bundleHashC hash))
     82 
     83 -- Translate contract failures before IO, preserving HTTP status/message roles.
     84 getBundleByHash root hash = (let
     85   readReply ((t t), (bytes, _)) = pure (ok bytes t)
     86   readReply (t, (message, _)) = pure (err 404 message)
     87   readReply _ = pure (err 404 "Invalid read result")
     88   checked ((t t), (value, _)) = (do bind
     89     reply <- readFile (bundleObjectPath root value)
     90     readReply reply)
     91   checked (t, (diagnostic, _)) = pure (err 400 diagnostic)
     92   checked _ = pure (err 400 "Invalid hash contract result")
     93   in checked (checkContract bundleHashC hash))
     94 
     95 -- A proper list prefix; return its exact suffix, without normalizing the tail.
     96 stripPrefix [] input = just input
     97 stripPrefix [wanted | prefix] [byte | rest] = (let
     98   matched ^wanted = stripPrefix prefix rest
     99   matched _ = nothing
    100   in matched byte)
    101 stripPrefix _ _ = nothing
    102 
    103 bundleHashPrefix = "/_arboricx/bundle/hash/"
    104 bundlePath = "/_arboricx/bundle"
    105 healthPath = "/_arboricx/health"
    106 bundleContentType = "application/vnd.arboricx.bundle"
    107 
    108 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>"
    109 
    110 bundleResponse bytes = response 200 bundleContentType bytes
    111 
    112 serveBundleHash root hash = (let
    113   respond ((t t), (bytes, _)) = pure (bundleResponse bytes)
    114   respond (t, (status, message)) = pure (errorResponse status message)
    115   respond _ = pure (errorResponse 500 "Invalid bundle result")
    116   in do bind
    117     reply <- getBundleByHash root hash
    118     respond reply)
    119 
    120 healthRoute "GET" ^healthPath = pure (okResponse "OK\n")
    121 healthRoute _ _ = pure notFoundResponse
    122 
    123 putBundleRoute root "POST" ^bundlePath body = (let
    124   respond ((t t), (hash, _)) = pure (createdResponse hash)
    125   respond (t, (message, _)) = pure (badRequestResponse (append "Upload failed: " message))
    126   respond _ = pure (errorResponse 500 "Invalid upload result")
    127   in do bind
    128     reply <- putBundle root body
    129     respond reply)
    130 putBundleRoute _ _ _ _ = pure notFoundResponse
    131 
    132 getBundleRoute root "GET" target = (let
    133   selected (t hash) = serveBundleHash root hash
    134   selected _ = pure notFoundResponse
    135   in selected (stripPrefix bundleHashPrefix target))
    136 getBundleRoute _ _ _ = pure notFoundResponse
    137 
    138 arboricxRouter _ "GET" "/" _ _ = pure (htmlResponse htmlLandingPage)
    139 arboricxRouter _ "GET" ^healthPath _ _ = healthRoute "GET" healthPath
    140 arboricxRouter root "GET" target _ _ = getBundleRoute root "GET" target
    141 arboricxRouter root "POST" target _ body = putBundleRoute root "POST" target body
    142 arboricxRouter _ _ _ _ _ = pure notFoundResponse
    143 
    144 arboricxHandler root client peer = httpHandlerIO (arboricxRouter root) client peer
    145 
    146 -- Close a newly acquired socket on ordinary bind/listen failures. As elsewhere,
    147 -- finally does not catch terminal abortIO or host exceptions; successful serving
    148 -- delegates scheduling/accept policy to serveForever, without a shutdown hook.
    149 arboricxServer root addr port = (let
    150   failed message = pure (err message t)
    151   opened server = (let
    152     rejected message = finally (failed message) (closeSocket_ server)
    153     ready _ = serveForever server (arboricxHandler root)
    154     in onResult_ (do onOk_
    155       bindSocket server addr port
    156       listen server 128)
    157       rejected ready)
    158   in onResult_ socket failed opened)