207 lines
6.6 KiB
Plaintext
207 lines
6.6 KiB
Plaintext
!import "prelude" !Local
|
|
!import "io" !Local
|
|
!import "http" !Local
|
|
!import "socket" !Local
|
|
!import "patterns" !Local
|
|
!import "arboricx" !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))
|