Ergonomic language features and lib cleanup
+ let bindings + where bindings + do notation I explored enough of the alternative language design space and decided that we should commit fully to Lambda style. That means no more highly tacit/concatenative point-free/partial programs as default. We'll keep taking advantage of those capabilities when it makes sense, but the library will continue to see massive overhauls.
This commit is contained in:
@@ -1,18 +1,19 @@
|
||||
!import "../io.tri" !Local
|
||||
!import "../http.tri" !Local
|
||||
!import "../socket.tri" !Local
|
||||
!import "../patterns.tri" !Local
|
||||
!import "arboricx.tri" !Local
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Store layout helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
pathJoin = a b : append a (append "/" b)
|
||||
pathJoin a b = append a (append "/" b)
|
||||
|
||||
objectDir = root shard :
|
||||
objectDir root shard =
|
||||
pathJoin (pathJoin root "objects") shard
|
||||
|
||||
hashShard = (hash :
|
||||
hashShard hash =
|
||||
matchList
|
||||
t
|
||||
(h0 r0 :
|
||||
@@ -25,26 +26,26 @@ hashShard = (hash :
|
||||
pair h0 (pair h1 (pair h2 t)))
|
||||
r1)
|
||||
r0)
|
||||
hash)
|
||||
hash
|
||||
|
||||
bundleObjectPath = (root hash :
|
||||
bundleObjectPath root hash =
|
||||
pathJoin
|
||||
(objectDir root (hashShard hash))
|
||||
(append hash ".arboricx"))
|
||||
(append hash ".arboricx")
|
||||
|
||||
bundleTmpPath = (root hash time :
|
||||
bundleTmpPath root hash time =
|
||||
pathJoin
|
||||
(pathJoin root "tmp")
|
||||
(append hash ".tmp"))
|
||||
(append hash ".tmp")
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Store initialization
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
ensureDir = path :
|
||||
ensureDir path =
|
||||
void (createDirectory path)
|
||||
|
||||
ensureStore = (root :
|
||||
ensureStore root =
|
||||
foldl
|
||||
thenIO
|
||||
(pure (ok t t))
|
||||
@@ -54,59 +55,46 @@ ensureStore = (root :
|
||||
(ensureDir (pathJoin root "aliases"))
|
||||
(ensureDir (pathJoin (pathJoin root "aliases") "names"))
|
||||
(ensureDir (pathJoin (pathJoin root "aliases") "packages"))
|
||||
(ensureDir (pathJoin root "manifests"))])
|
||||
(ensureDir (pathJoin root "manifests"))]
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle object write
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
putBundleWrite = (root bundleBytes hash shard tmpPath finalPath :
|
||||
onResult_ (createDirectory (objectDir root shard))
|
||||
(e : pure (err (append "createDirectory: " e) t))
|
||||
(_ :
|
||||
onResult_ (writeBytes tmpPath bundleBytes)
|
||||
(e : pure (err (append "writeBytes: " e) t))
|
||||
(_ :
|
||||
onResult_ (renameFile tmpPath finalPath)
|
||||
(e : pure (err (append "renameFile: " e) t))
|
||||
(_ : pure (ok hash t)))))
|
||||
putBundleWrite root bundleBytes hash shard tmpPath finalPath =
|
||||
do onOk_
|
||||
_ <- mapErrIO "createDirectory: " (createDirectory (objectDir root shard))
|
||||
_ <- mapErrIO "writeBytes: " (writeBytes tmpPath bundleBytes)
|
||||
_ <- mapErrIO "renameFile: " (renameFile tmpPath finalPath)
|
||||
pure (ok hash t)
|
||||
|
||||
putBundleWithHash = (root bundleBytes time hash :
|
||||
putBundleWrite
|
||||
root
|
||||
bundleBytes
|
||||
hash
|
||||
(hashShard hash)
|
||||
(bundleTmpPath root hash time)
|
||||
(bundleObjectPath root hash))
|
||||
putBundleWithHash root bundleBytes time hash =
|
||||
let shard = hashShard hash in
|
||||
let tmpPath = bundleTmpPath root hash time in
|
||||
let finalPath = bundleObjectPath root hash in
|
||||
putBundleWrite root bundleBytes hash shard tmpPath finalPath
|
||||
|
||||
putBundle = (root bundleBytes :
|
||||
onResult_ currentTime
|
||||
(e : pure (err (append "currentTime: " e) t))
|
||||
(time :
|
||||
onResult_ (sha256Hex bundleBytes)
|
||||
(e : pure (err (append "sha256Hex: " e) t))
|
||||
(hash :
|
||||
bind (putBundleWithHash root bundleBytes time hash) (r :
|
||||
matchResult
|
||||
(e _ : pure (err (append "withHash: " e) t))
|
||||
(v _ : pure (ok v t))
|
||||
r))))
|
||||
putBundle root bundleBytes =
|
||||
do onOk_
|
||||
time <- mapErrIO "currentTime: " currentTime
|
||||
hash <- mapErrIO "sha256Hex: " (sha256Hex bundleBytes)
|
||||
savedHash <- mapErrIO "withHash: " (putBundleWithHash root bundleBytes time hash)
|
||||
pure (ok savedHash t)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle object fetch
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
getBundleByHash = (root hash :
|
||||
getBundleByHash root hash =
|
||||
onResult_ (readFile (bundleObjectPath root hash))
|
||||
(errMsg : pure (err errMsg t))
|
||||
(bytes : pure (ok bytes t)))
|
||||
(bytes : pure (ok bytes t))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Route prefix helper
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
stripPrefix_ = (self input prefix :
|
||||
stripPrefix_ self input prefix =
|
||||
lazyList
|
||||
(_ :
|
||||
lazyList
|
||||
@@ -122,12 +110,15 @@ stripPrefix_ = (self input prefix :
|
||||
(_ : nothing)
|
||||
(equal? ih ph))
|
||||
prefix)
|
||||
input)
|
||||
input
|
||||
|
||||
stripPrefix = (prefix input :
|
||||
y stripPrefix_ input prefix)
|
||||
stripPrefix prefix input =
|
||||
y stripPrefix_ input prefix
|
||||
|
||||
bundleHashPrefix = "/_arboricx/bundle/hash/"
|
||||
bundlePath = "/_arboricx/bundle"
|
||||
healthPath = "/_arboricx/health"
|
||||
bundleContentType = "application/vnd.arboricx.bundle"
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Landing page
|
||||
@@ -142,82 +133,73 @@ htmlLandingPage = "<!DOCTYPE html><html><head><meta name='viewport' content='wid
|
||||
-- Registry routes
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
healthRoute = (method target :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : pure (okResponse "OK\n"))
|
||||
(_ : pure notFoundResponse)
|
||||
(equal? target "/_arboricx/health"))
|
||||
(_ : pure notFoundResponse)
|
||||
(equal? method "GET"))
|
||||
bundleResponse bytes = response 200 bundleContentType bytes
|
||||
|
||||
putBundleRoute = (root method target body :
|
||||
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/bundle"))
|
||||
(_ : pure notFoundResponse)
|
||||
(equal? method "POST"))
|
||||
serveBundleHash root hash =
|
||||
onResult_ (getBundleByHash root hash)
|
||||
(errMsg : pure (errorResponse 404 errMsg))
|
||||
(bytes : pure (bundleResponse bytes))
|
||||
|
||||
getBundleRoute = (root method 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"))
|
||||
healthRoute method target =
|
||||
cond
|
||||
[(guard (_ : equal? method "GET") (_ : getHealth))
|
||||
(guard (_ : true) (_ : pure notFoundResponse))]
|
||||
where getHealth =
|
||||
cond
|
||||
[(guard (_ : equal? target healthPath) (_ : pure (okResponse "OK\n")))
|
||||
(guard (_ : true) (_ : pure notFoundResponse))]
|
||||
|
||||
arboricxRouter = (root method target headers body :
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : pure (htmlResponse htmlLandingPage))
|
||||
(_ :
|
||||
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))
|
||||
(equal? target "/"))
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : putBundleRoute root method target body)
|
||||
(_ : pure notFoundResponse)
|
||||
(equal? method "POST"))
|
||||
(equal? method "GET"))
|
||||
putBundleRoute root method target body =
|
||||
cond
|
||||
[(guard (_ : equal? method "POST") (_ : postBundle))
|
||||
(guard (_ : true) (_ : pure notFoundResponse))]
|
||||
where postBundle =
|
||||
cond
|
||||
[(guard (_ : equal? target bundlePath) (_ : handleUpload))
|
||||
(guard (_ : true) (_ : pure notFoundResponse))]
|
||||
where handleUpload =
|
||||
onResult_ (putBundle root body)
|
||||
(err : pure (badRequestResponse (append "Upload failed: " err)))
|
||||
(hash : pure (createdResponse hash))
|
||||
|
||||
getBundleRoute root method target =
|
||||
cond
|
||||
[(guard (_ : equal? method "GET") (_ : getBundle))
|
||||
(guard (_ : true) (_ : pure notFoundResponse))]
|
||||
where getBundle =
|
||||
lazyMaybe
|
||||
(_ : pure notFoundResponse)
|
||||
(hash : serveBundleHash root hash)
|
||||
(stripPrefix bundleHashPrefix target)
|
||||
|
||||
arboricxRouter root method target headers body =
|
||||
cond
|
||||
[(guard (_ : equal? method "GET") (_ : getRoutes))
|
||||
(guard (_ : equal? method "POST") (_ : putBundleRoute root method target body))
|
||||
(guard (_ : true) (_ : pure notFoundResponse))]
|
||||
where getRoutes =
|
||||
cond
|
||||
[(guard (_ : equal? target "/") (_ : pure (htmlResponse htmlLandingPage)))
|
||||
(guard (_ : true) (_ : getBundleOrHealth))]
|
||||
where getBundleOrHealth =
|
||||
lazyMaybe
|
||||
(_ : healthRoute method target)
|
||||
(hash : serveBundleHash root hash)
|
||||
(stripPrefix bundleHashPrefix target)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Server entrypoint
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
arboricxHandler = (root client peer :
|
||||
arboricxHandler root = (client peer :
|
||||
httpHandlerIO
|
||||
(method target headers body :
|
||||
arboricxRouter root method target headers body)
|
||||
client
|
||||
peer)
|
||||
|
||||
arboricxServer = (root addr port :
|
||||
arboricxServer root addr port =
|
||||
onResult_ (listenSocket addr port 128)
|
||||
(errMsg : pure (err errMsg t))
|
||||
(server :
|
||||
serveForever server (arboricxHandler root)))
|
||||
serveForever server (arboricxHandler root))
|
||||
|
||||
Reference in New Issue
Block a user