James Eversole
2e2db07bd6
+ 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.
206 lines
6.6 KiB
Plaintext
206 lines
6.6 KiB
Plaintext
!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)
|
|
|
|
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 =
|
|
pathJoin
|
|
(objectDir root (hashShard hash))
|
|
(append hash ".arboricx")
|
|
|
|
bundleTmpPath root hash time =
|
|
pathJoin
|
|
(pathJoin root "tmp")
|
|
(append hash ".tmp")
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Store initialization
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
ensureDir path =
|
|
void (createDirectory path)
|
|
|
|
ensureStore root =
|
|
foldl
|
|
thenIO
|
|
(pure (ok t t))
|
|
[(ensureDir root)
|
|
(ensureDir (pathJoin root "tmp"))
|
|
(ensureDir (pathJoin root "objects"))
|
|
(ensureDir (pathJoin root "aliases"))
|
|
(ensureDir (pathJoin (pathJoin root "aliases") "names"))
|
|
(ensureDir (pathJoin (pathJoin root "aliases") "packages"))
|
|
(ensureDir (pathJoin root "manifests"))]
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Bundle object write
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
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 =
|
|
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 =
|
|
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 =
|
|
onResult_ (readFile (bundleObjectPath 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/"
|
|
bundlePath = "/_arboricx/bundle"
|
|
healthPath = "/_arboricx/health"
|
|
bundleContentType = "application/vnd.arboricx.bundle"
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Landing page
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- TODO: Let's replace in-line HTML with the ability to read and serve files
|
|
-- from a public/ folder.
|
|
|
|
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>"
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Registry routes
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
bundleResponse bytes = response 200 bundleContentType bytes
|
|
|
|
serveBundleHash root hash =
|
|
onResult_ (getBundleByHash root hash)
|
|
(errMsg : pure (errorResponse 404 errMsg))
|
|
(bytes : pure (bundleResponse bytes))
|
|
|
|
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))]
|
|
|
|
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 :
|
|
httpHandlerIO
|
|
(method target headers body :
|
|
arboricxRouter root method target headers body)
|
|
client
|
|
peer)
|
|
|
|
arboricxServer root addr port =
|
|
onResult_ (listenSocket addr port 128)
|
|
(errMsg : pure (err errMsg t))
|
|
(server :
|
|
serveForever server (arboricxHandler root))
|