tricu

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

75f284aec3ff84d0a392fdf8e144512304f3adfda91c96b27748c6160a1ff7b5.tri (6377B)

      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 arboricxRouter _ "GET" "/" _ _ = pure (htmlResponse htmlLandingPage)
    135 arboricxRouter _ "GET" ^healthPath _ _ = healthRoute "GET" healthPath
    136 arboricxRouter root "GET" target _ _ = getBundleRoute root "GET" target
    137 arboricxRouter root "POST" target _ body = putBundleRoute root "POST" target body
    138 arboricxRouter _ _ _ _ _ = pure notFoundResponse
    139 
    140 arboricxHandler root client peer = httpHandlerIO (arboricxRouter root) client peer
    141 
    142 -- Close a newly acquired socket on ordinary bind/listen failures. As elsewhere,
    143 -- finally does not catch terminal abortIO or host exceptions; successful serving
    144 -- delegates scheduling/accept policy to serveForever, without a shutdown hook.
    145 arboricxServer root addr port = (let
    146   failed message = pure (err message t)
    147   opened server = (let
    148     rejected message = finally (failed message) (closeSocket_ server)
    149     ready _ = serveForever server (arboricxHandler root)
    150     in onResult_ (do onOk_
    151       bindSocket server addr port
    152       listen server 128)
    153       rejected ready)
    154   in onResult_ socket failed opened)