224 lines
6.8 KiB
Plaintext
224 lines
6.8 KiB
Plaintext
!import "../io.tri" !Local
|
|
!import "../http.tri" !Local
|
|
!import "../socket.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 :
|
|
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)))))
|
|
|
|
putBundleWithHash = (root bundleBytes time hash :
|
|
putBundleWrite
|
|
root
|
|
bundleBytes
|
|
hash
|
|
(hashShard hash)
|
|
(bundleTmpPath root hash time)
|
|
(bundleObjectPath root hash))
|
|
|
|
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))))
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- 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/"
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- 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
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
healthRoute = (method target :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : pure (okResponse "OK\n"))
|
|
(_ : pure notFoundResponse)
|
|
(equal? target "/_arboricx/health"))
|
|
(_ : pure notFoundResponse)
|
|
(equal? method "GET"))
|
|
|
|
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"))
|
|
|
|
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"))
|
|
|
|
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"))
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- 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)))
|