James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fully normalized top-level definitions

Browse Source
This commit is contained in:
James Eversole
2026-05-21 11:38:17 -05:00
parent bf30d5945e
commit 4bf2ce56dd
11 changed files with 612 additions and 544 deletions
Download Patch File Download Diff File Expand all files Collapse all files

151
lib/arboricx/server.tri
View File

@@ -9,23 +9,40 @@
pathJoin = a b : append a (append "/" b)
objectDir = root shard : pathJoin (pathJoin root "objects") shard
objectDir = root shard :
pathJoin (pathJoin root "objects") shard
hashShard = (hash :
matchList
t
(h0 r0 :
matchList
(pair h0 t)
(h1 r1 :
matchList
(pair h0 (pair h1 t))
(h2 _ :
pair h0 (pair h1 (pair h2 t)))
r1)
r0)
hash)
bundleObjectPath = (root hash :
((shard : pathJoin (objectDir root shard) (append hash ".arboricx"))
(take 3 hash)))
--bundleTmpPath = (root hash time :
-- pathJoin (pathJoin root "tmp") (append hash (append "." (append (showNumber time) ".tmp"))))
pathJoin
(objectDir root (hashShard hash))
(append hash ".arboricx"))
bundleTmpPath = (root hash time :
pathJoin (pathJoin root "tmp") (append hash ".tmp"))
pathJoin
(pathJoin root "tmp")
(append hash ".tmp"))
-- ---------------------------------------------------------------------------
-- Store initialization
-- ---------------------------------------------------------------------------
ensureDir = path : void (createDirectory path)
ensureDir = path :
void (createDirectory path)
ensureStore = (root :
foldl
@@ -59,7 +76,7 @@ putBundleWithHash = (root bundleBytes time hash :
root
bundleBytes
hash
(take 3 hash)
(hashShard hash)
(bundleTmpPath root hash time)
(bundleObjectPath root hash))
@@ -85,56 +102,106 @@ getBundleByHash = (root hash :
(errMsg : pure (err errMsg t))
(bytes : pure (ok bytes t)))
-- ---------------------------------------------------------------------------
-- Route prefix helper
-- ---------------------------------------------------------------------------
stripPrefix_ = (self input prefix :
lazyList
(_ :
lazyList
(_ : just t)
(_ _ : nothing)
prefix)
(ih ir :
lazyList
(_ : just input)
(ph pr :
lazyBool
(_ : self ir pr)
(_ : nothing)
(equal? ih ph))
prefix)
input)
stripPrefix = (prefix input :
y stripPrefix_ input prefix)
bundleHashPrefix = "/_arboricx/bundle/hash/"
-- ---------------------------------------------------------------------------
-- Registry routes
-- ---------------------------------------------------------------------------
healthRoute = (method target :
matchBool
(pure (okResponse "OK\n"))
(pure notFoundResponse)
(and? (equal? method "GET") (equal? target "/_arboricx/health")))
lazyBool
(_ :
lazyBool
(_ : pure (okResponse "OK\n"))
(_ : pure notFoundResponse)
(equal? target "/_arboricx/health"))
(_ : pure notFoundResponse)
(equal? method "GET"))
putBundleRoute = (root method target body :
matchBool
(bind (putBundle root body) (result :
matchResult
(err _ : pure (badRequestResponse (append "Upload failed: " err)))
(hash _ : pure (createdResponse hash))
result))
(pure notFoundResponse)
(and? (equal? method "POST") (equal? target "/_arboricx/bundles")))
lazyBool
(_ :
lazyBool
(_ :
bind (putBundle root body) (result :
matchResult
(err _ : pure (badRequestResponse (append "Upload failed: " err)))
(hash _ : pure (createdResponse hash))
result))
(_ : pure notFoundResponse)
(equal? target "/_arboricx/bundles"))
(_ : pure notFoundResponse)
(equal? method "POST"))
getBundleRoute = (root method target :
matchBool
((hash :
bind (getBundleByHash root hash) (result :
matchResult
(errMsg _ : pure (errorResponse 404 errMsg))
(bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
result))
(drop 23 target))
(pure notFoundResponse)
(and? (equal? method "GET") (startsWith? "/_arboricx/bundle/hash/" target)))
lazyBool
(_ :
lazyMaybe
(_ : pure notFoundResponse)
(hash :
bind (getBundleByHash root hash) (result :
matchResult
(errMsg _ : pure (errorResponse 404 errMsg))
(bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
result))
(stripPrefix bundleHashPrefix target))
(_ : pure notFoundResponse)
(equal? method "GET"))
arboricxRouter = (root method target headers body :
matchBool
(getBundleRoute root method target)
(matchBool
(putBundleRoute root method target body)
(matchBool
(healthRoute method target)
(pure notFoundResponse)
(and? (equal? method "GET") (equal? target "/_arboricx/health")))
(and? (equal? method "POST") (equal? target "/_arboricx/bundles")))
(and? (equal? method "GET") (startsWith? "/_arboricx/bundle/hash/" target)))
lazyBool
(_ :
lazyMaybe
(_ : healthRoute method target)
(hash :
bind (getBundleByHash root hash) (result :
matchResult
(errMsg _ : pure (errorResponse 404 errMsg))
(bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
result))
(stripPrefix bundleHashPrefix target))
(_ :
lazyBool
(_ : putBundleRoute root method target body)
(_ : pure notFoundResponse)
(equal? method "POST"))
(equal? method "GET"))
-- ---------------------------------------------------------------------------
-- Server entrypoint
-- ---------------------------------------------------------------------------
arboricxHandler = (root client peer :
httpHandlerIO (arboricxRouter root) client peer)
httpHandlerIO
(method target headers body :
arboricxRouter root method target headers body)
client
peer)
arboricxServer = (root addr port :
onResult_ (listenSocket addr port 128)