tricu

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

e577638282739414d645feea13edb8a30615af7f2da6838e7a7d9aa6ea475f98.tri (8319B)

      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 = case (bundleHexByte? byte) of
     45   ^true = bundleHashBytes rest (Nat.subtract remaining 1)
     46   _ = false
     47 
     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 = (do onOk_
     72   hash <- mapErrIO "sha256Hex: " (sha256Hex bytes)
     73   case (checkContract bundleHashC hash) of
     74     ((t t), (value, _)) = (do onOk_
     75       ensureDir (objectDir root (hashShard value))
     76       mapErrIO "atomicWriteBytes: " (atomicWriteBytes (bundleObjectPath root value) bytes)
     77       pure (ok value t))
     78     (t, (diagnostic, _)) = pure (err (append "sha256Hex: " diagnostic) t)
     79     _ = pure (err "sha256Hex: Invalid hash contract result" t))
     80 
     81 -- Translate contract failures before IO, preserving HTTP status/message roles.
     82 getBundleByHash root hash = case (checkContract bundleHashC hash) of
     83   ((t t), (value, _)) = (do bind
     84     reply <- readFile (bundleObjectPath root value)
     85     case reply of
     86       ((t t), (bytes, _)) = pure (ok bytes t)
     87       (t, (message, _)) = pure (err 404 message)
     88       _ = pure (err 404 "Invalid read result"))
     89   (t, (diagnostic, _)) = pure (err 400 diagnostic)
     90   _ = pure (err 400 "Invalid hash contract result")
     91 
     92 -- A proper list prefix; return its exact suffix, without normalizing the tail.
     93 stripPrefix [] input = just input
     94 stripPrefix [wanted | prefix] [byte | rest] = case byte of
     95   ^wanted = stripPrefix prefix rest
     96   _ = nothing
     97 
     98 stripPrefix _ _ = nothing
     99 
    100 bundleHashPrefix = "/_arboricx/bundle/hash/"
    101 bundlePath = "/_arboricx/bundle"
    102 healthPath = "/_arboricx/health"
    103 bundleContentType = "application/vnd.arboricx.bundle"
    104 
    105 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>"
    106 
    107 bundleResponse bytes = response 200 bundleContentType bytes
    108 
    109 serveBundleHash root hash = (do bind
    110   reply <- getBundleByHash root hash
    111   case reply of
    112     ((t t), (bytes, _)) = pure (bundleResponse bytes)
    113     (t, (status, message)) = pure (errorResponse status message)
    114     _ = pure (errorResponse 500 "Invalid bundle result"))
    115 
    116 healthRoute "GET" ^healthPath = pure (okResponse "OK\n")
    117 healthRoute _ _ = pure notFoundResponse
    118 
    119 putBundleRoute root "POST" ^bundlePath body = (do bind
    120   reply <- putBundle root body
    121   case reply of
    122     ((t t), (hash, _)) = pure (createdResponse hash)
    123     (t, (message, _)) = pure (badRequestResponse (append "Upload failed: " message))
    124     _ = pure (errorResponse 500 "Invalid upload result"))
    125 
    126 putBundleRoute _ _ _ _ = pure notFoundResponse
    127 
    128 getBundleRoute root "GET" target = case (stripPrefix bundleHashPrefix target) of
    129   (t hash) = serveBundleHash root hash
    130   _ = pure notFoundResponse
    131 
    132 getBundleRoute _ _ _ = pure notFoundResponse
    133 
    134 -- Read-only exact-version index. Administrative publication happens locally;
    135 -- this route never resolves dependencies or executes fetched code. HTTP input
    136 -- bytes are canonical naturals. Scan at most 128 bytes per path component.
    137 packagePrefix = "/_arboricx/package/"
    138 packageAlphaNum? byte = (or? (Nat.inRange byte 48 57)
    139   (or? (Nat.inRange byte 65 90) (Nat.inRange byte 97 122)))
    140 packageByte? byte = (or? (packageAlphaNum? byte)
    141   (or? (equal? byte 46) (or? (equal? byte 95) (equal? byte 45))))
    142 packageVersion [] reversed _ = just (reverse reversed)
    143 packageVersion _ _ 0 = nothing
    144 packageVersion [byte | rest] reversed remaining = case (packageByte? byte) of
    145   ^true = packageVersion rest (pair byte reversed) (Nat.subtract remaining 1)
    146   _ = nothing
    147 
    148 packageVersion _ _ _ = nothing
    149 packageName [47 | [first | rest]] reversed _ = case (packageAlphaNum? first) of
    150   ^true = case (packageVersion rest [first] 127) of
    151     (t version) = just (pair (reverse reversed) version)
    152     _ = nothing
    153   _ = nothing
    154 
    155 packageName _ _ 0 = nothing
    156 packageName [byte | rest] reversed remaining = case (packageByte? byte) of
    157   ^true = packageName rest (pair byte reversed) (Nat.subtract remaining 1)
    158   _ = nothing
    159 
    160 packageName _ _ _ = nothing
    161 packageTarget [first | rest] = case (packageAlphaNum? first) of
    162   ^true = packageName rest [first] 127
    163   _ = nothing
    164 
    165 packageTarget _ = nothing
    166 
    167 servePackage root target = case (packageTarget target) of
    168   (t (name, version)) = (do bind
    169     reply <- readFile (pathJoin (pathJoin (pathJoin root "packages") name) version)
    170     case reply of
    171       ((t t), (bytes, _)) = pure (response 200 "application/vnd.arboricx.package-release" bytes)
    172       _ = pure (errorResponse 404 "Package release not found"))
    173   _ = pure (badRequestResponse "Invalid package name/version")
    174 
    175 getRegistryRoute root target = case (stripPrefix packagePrefix target) of
    176   (t suffix) = servePackage root suffix
    177   _ = getBundleRoute root "GET" target
    178 
    179 arboricxRouter _ "GET" "/" _ _ = pure (htmlResponse htmlLandingPage)
    180 arboricxRouter _ "GET" ^healthPath _ _ = healthRoute "GET" healthPath
    181 arboricxRouter root "GET" target _ _ = getRegistryRoute root target
    182 arboricxRouter root "POST" target _ body = putBundleRoute root "POST" target body
    183 arboricxRouter _ _ _ _ _ = pure notFoundResponse
    184 
    185 arboricxHandler root client peer = httpHandlerIO (arboricxRouter root) client peer
    186 
    187 -- Close a newly acquired socket on ordinary bind/listen failures. As elsewhere,
    188 -- finally does not catch terminal abortIO or host exceptions; successful serving
    189 -- delegates scheduling/accept policy to serveForever, without a shutdown hook.
    190 arboricxServer root addr port = (let
    191   failed message = pure (err message t)
    192   opened server = (let
    193     rejected message = finally (failed message) (closeSocket_ server)
    194     ready _ = serveForever server (arboricxHandler root)
    195     in onResult_ (do onOk_
    196       bindSocket server addr port
    197       listen server 128)
    198       rejected ready)
    199   in onResult_ socket failed opened)