!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 = "Arboricx ServerArboricx Server
Bundle registry
Made with Love (and trees, lots of trees)
"
-- ---------------------------------------------------------------------------
-- 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))