Fully normalized top-level definitions
This commit is contained in:
@@ -1,7 +1,6 @@
|
||||
!import "../base.tri" !Local
|
||||
!import "../list.tri" !Local
|
||||
!import "../bytes.tri" !Local
|
||||
!import "../binary.tri" !Local
|
||||
!import "../prelude.tri" !Local
|
||||
!import "../bytes.tri" !Local
|
||||
!import "../binary.tri" !Local
|
||||
|
||||
arboricxMagic = [(65) (82) (66) (79) (82) (73) (67) (88)]
|
||||
arboricxMajorVersion = [(0) (1)]
|
||||
|
||||
@@ -46,14 +46,72 @@ nodePayloadValid? = (nodePayload :
|
||||
(nodePayloadStem? nodePayload)
|
||||
(nodePayloadFork? nodePayload)))
|
||||
|
||||
nodeU32FromBytes4 = (b0 b1 b2 b3 :
|
||||
u32BEBytesToNat
|
||||
(pair b0
|
||||
(pair b1
|
||||
(pair b2
|
||||
(pair b3 t)))))
|
||||
|
||||
withNodePayloadStemIndex = (nodePayload shortK indexK :
|
||||
matchList
|
||||
(shortK t)
|
||||
(tag r0 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(b0 r1 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(b1 r2 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(b2 r3 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(b3 _ :
|
||||
indexK (nodeU32FromBytes4 b0 b1 b2 b3))
|
||||
r3) r2) r1) r0) nodePayload)
|
||||
|
||||
withNodePayloadForkIndices = (nodePayload shortK indicesK :
|
||||
matchList
|
||||
(shortK t)
|
||||
(tag r0 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(l0 r1 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(l1 r2 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(l2 r3 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(l3 r4 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(r0b r5 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(r1b r6 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(r2b r7 :
|
||||
matchList
|
||||
(shortK t)
|
||||
(r3b _ :
|
||||
indicesK
|
||||
(nodeU32FromBytes4 l0 l1 l2 l3)
|
||||
(nodeU32FromBytes4 r0b r1b r2b r3b)) r7) r6) r5) r4) r3) r2) r1) r0) nodePayload)
|
||||
|
||||
nodePayloadStemChildIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 1 nodePayload)))
|
||||
withNodePayloadStemIndex nodePayload (_ : 0) (index : index))
|
||||
|
||||
nodePayloadForkLeftIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 1 nodePayload)))
|
||||
withNodePayloadForkIndices nodePayload (_ : 0) (left right : left))
|
||||
|
||||
nodePayloadForkRightIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 5 nodePayload)))
|
||||
withNodePayloadForkIndices nodePayload (_ : 0) (left right : right))
|
||||
|
||||
nodeRecordsHaveInvalidPayload? = y (self nodeRecords :
|
||||
matchList
|
||||
@@ -65,31 +123,44 @@ nodeRecordsHaveInvalidPayload? = y (self nodeRecords :
|
||||
nodeRecords)
|
||||
|
||||
nodePayloadChildIndices = (nodePayload :
|
||||
matchBool
|
||||
matchList
|
||||
t
|
||||
(matchBool
|
||||
(pair (nodePayloadStemChildIndex nodePayload) t)
|
||||
(pair (nodePayloadForkLeftIndex nodePayload)
|
||||
(pair (nodePayloadForkRightIndex nodePayload) t))
|
||||
(nodePayloadStem? nodePayload))
|
||||
(nodePayloadLeaf? nodePayload))
|
||||
(tag rest :
|
||||
lazyBool
|
||||
(_ :
|
||||
withNodePayloadStemIndex
|
||||
nodePayload
|
||||
(_ : t)
|
||||
(childIndex : pair childIndex t))
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ :
|
||||
withNodePayloadForkIndices
|
||||
nodePayload
|
||||
(_ : t)
|
||||
(leftIndex rightIndex :
|
||||
pair leftIndex (pair rightIndex t)))
|
||||
(_ : t)
|
||||
(equal? tag nodePayloadForkTag))
|
||||
(equal? tag nodePayloadStemTag))
|
||||
nodePayload)
|
||||
|
||||
-- True iff index n names an element before limit in records.
|
||||
-- For topologically sorted indexed bundles, every child of record i must
|
||||
-- satisfy childIndex < i, so searching only the prefix [0, i) validates both
|
||||
-- bounds and acyclicity.
|
||||
nodeIndexInPrefix? = y (self n records i limit :
|
||||
matchBool
|
||||
nodeIndexInPrefix? = y (self records n i limit :
|
||||
matchList
|
||||
false
|
||||
(matchList
|
||||
false
|
||||
(_ rest :
|
||||
matchBool
|
||||
(_ rest :
|
||||
matchBool
|
||||
false
|
||||
(matchBool
|
||||
true
|
||||
(self n rest (succ i) limit)
|
||||
(self rest n (succ i) limit)
|
||||
(equal? i n))
|
||||
records)
|
||||
(equal? i limit))
|
||||
(equal? i limit))
|
||||
records)
|
||||
|
||||
nodeChildIndicesInPrefix? = y (self childIndices records limit :
|
||||
matchList
|
||||
@@ -98,7 +169,7 @@ nodeChildIndicesInPrefix? = y (self childIndices records limit :
|
||||
matchBool
|
||||
(self rest records limit)
|
||||
false
|
||||
(nodeIndexInPrefix? childIndex records 0 limit))
|
||||
(nodeIndexInPrefix? records childIndex 0 limit))
|
||||
childIndices)
|
||||
|
||||
nodePayloadIndicesValid? = (nodePayload i records :
|
||||
@@ -178,31 +249,124 @@ nodesSectionRecords = (nodesSection :
|
||||
(_ nodeRecords : nodeRecords)
|
||||
nodesSection)
|
||||
|
||||
nodePayloadToTreeWith = (self nodeRecords nodePayload :
|
||||
matchBool
|
||||
(ok t t)
|
||||
(matchBool
|
||||
(bindResult (self (nodePayloadStemChildIndex nodePayload) nodeRecords)
|
||||
(child _ : ok (t child) t))
|
||||
(bindResult (self (nodePayloadForkLeftIndex nodePayload) nodeRecords)
|
||||
(left _ :
|
||||
bindResult (self (nodePayloadForkRightIndex nodePayload) nodeRecords)
|
||||
(right _ : ok (pair left right) t)))
|
||||
(nodePayloadStem? nodePayload))
|
||||
(nodePayloadLeaf? nodePayload))
|
||||
nodeBuiltTreeIndex = (entry :
|
||||
matchPair
|
||||
(index _ : index)
|
||||
entry)
|
||||
|
||||
nodeIndexToTree = y (self nodeIndex nodeRecords :
|
||||
(nodePayload :
|
||||
matchBool
|
||||
(nodePayloadToTreeWith self nodeRecords nodePayload)
|
||||
(err errMissingNode t)
|
||||
(not? (equal? nodePayload t)))
|
||||
(nth nodeIndex nodeRecords))
|
||||
nodeBuiltTreeValue = (entry :
|
||||
matchPair
|
||||
(_ tree : tree)
|
||||
entry)
|
||||
|
||||
nodeTreeByIndex_ = (self builtTrees targetIndex :
|
||||
lazyList
|
||||
(_ : err errMissingNode t)
|
||||
(entry rest :
|
||||
lazyBool
|
||||
(_ : ok (nodeBuiltTreeValue entry) t)
|
||||
(_ : self rest targetIndex)
|
||||
(equal? (nodeBuiltTreeIndex entry) targetIndex))
|
||||
builtTrees)
|
||||
|
||||
nodeTreeByIndex = (builtTrees targetIndex :
|
||||
y nodeTreeByIndex_ builtTrees targetIndex)
|
||||
|
||||
nodePayloadToTreeFromBuilt = (builtTrees nodePayload :
|
||||
matchList
|
||||
(err errInvalidNodePayload t)
|
||||
(tag rest :
|
||||
lazyBool
|
||||
(_ : ok t t)
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ :
|
||||
withNodePayloadStemIndex
|
||||
nodePayload
|
||||
(_ : err errInvalidNodePayload t)
|
||||
(childIndex :
|
||||
lazyResult
|
||||
(code after : err code after)
|
||||
(child _ : ok (t child) t)
|
||||
(nodeTreeByIndex builtTrees childIndex)))
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ :
|
||||
withNodePayloadForkIndices
|
||||
nodePayload
|
||||
(_ : err errInvalidNodePayload t)
|
||||
(leftIndex rightIndex :
|
||||
lazyResult
|
||||
(code after : err code after)
|
||||
(left _ :
|
||||
lazyResult
|
||||
(code after : err code after)
|
||||
(right _ : ok (pair left right) t)
|
||||
(nodeTreeByIndex builtTrees rightIndex))
|
||||
(nodeTreeByIndex builtTrees leftIndex)))
|
||||
(_ : err errInvalidNodePayload t)
|
||||
(equal? tag nodePayloadForkTag))
|
||||
(equal? tag nodePayloadStemTag))
|
||||
(equal? tag 0))
|
||||
nodePayload)
|
||||
|
||||
nodeBuildState = (targetIndex i builtTrees :
|
||||
pair targetIndex (pair i builtTrees))
|
||||
|
||||
nodeBuildStateTargetIndex = (state :
|
||||
matchPair
|
||||
(targetIndex _ : targetIndex)
|
||||
state)
|
||||
|
||||
nodeBuildStateI = (state :
|
||||
matchPair
|
||||
(_ rest :
|
||||
matchPair
|
||||
(i _ : i)
|
||||
rest)
|
||||
state)
|
||||
|
||||
nodeBuildStateBuiltTrees = (state :
|
||||
matchPair
|
||||
(_ rest :
|
||||
matchPair
|
||||
(_ builtTrees : builtTrees)
|
||||
rest)
|
||||
state)
|
||||
|
||||
nodeIndexToTree_ = (self remainingRecords state :
|
||||
((nodeIndex :
|
||||
((i :
|
||||
((builtTrees :
|
||||
lazyList
|
||||
(_ : err errMissingNode t)
|
||||
(nodePayload rest :
|
||||
lazyResult
|
||||
(code after : err code after)
|
||||
(tree _ :
|
||||
lazyBool
|
||||
(_ : ok tree t)
|
||||
(_ :
|
||||
self
|
||||
rest
|
||||
(nodeBuildState
|
||||
nodeIndex
|
||||
(succ i)
|
||||
(pair (pair i tree) builtTrees)))
|
||||
(equal? i nodeIndex))
|
||||
(nodePayloadToTreeFromBuilt builtTrees nodePayload))
|
||||
remainingRecords)
|
||||
(nodeBuildStateBuiltTrees state)))
|
||||
(nodeBuildStateI state)))
|
||||
(nodeBuildStateTargetIndex state)))
|
||||
|
||||
nodeIndexToTree = (nodeRecords nodeIndex :
|
||||
y nodeIndexToTree_ nodeRecords (nodeBuildState nodeIndex 0 t))
|
||||
|
||||
readArboricxTreeFromIndex = (rootIndexBytes bs :
|
||||
bindResult (readArboricxNodesSection bs)
|
||||
(nodesSection afterContainer :
|
||||
bindResult (nodeIndexToTree (u32BEBytesToNat rootIndexBytes) (nodesSectionRecords nodesSection))
|
||||
bindResult (nodeIndexToTree (nodesSectionRecords nodesSection) (u32BEBytesToNat rootIndexBytes))
|
||||
(tree _ : ok tree afterContainer)))
|
||||
|
||||
readArboricxExecutableFromIndex = readArboricxTreeFromIndex
|
||||
|
||||
@@ -9,23 +9,40 @@
|
||||
|
||||
pathJoin = a b : append a (append "/" b)
|
||||
|
||||
objectDir = root shard : pathJoin (pathJoin root "objects") shard
|
||||
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 :
|
||||
((shard : pathJoin (objectDir root shard) (append hash ".arboricx"))
|
||||
(take 3 hash)))
|
||||
|
||||
--bundleTmpPath = (root hash time :
|
||||
-- pathJoin (pathJoin root "tmp") (append hash (append "." (append (showNumber time) ".tmp"))))
|
||||
pathJoin
|
||||
(objectDir root (hashShard hash))
|
||||
(append hash ".arboricx"))
|
||||
|
||||
bundleTmpPath = (root hash time :
|
||||
pathJoin (pathJoin root "tmp") (append hash ".tmp"))
|
||||
pathJoin
|
||||
(pathJoin root "tmp")
|
||||
(append hash ".tmp"))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Store initialization
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
ensureDir = path : void (createDirectory path)
|
||||
ensureDir = path :
|
||||
void (createDirectory path)
|
||||
|
||||
ensureStore = (root :
|
||||
foldl
|
||||
@@ -59,7 +76,7 @@ putBundleWithHash = (root bundleBytes time hash :
|
||||
root
|
||||
bundleBytes
|
||||
hash
|
||||
(take 3 hash)
|
||||
(hashShard hash)
|
||||
(bundleTmpPath root hash time)
|
||||
(bundleObjectPath root hash))
|
||||
|
||||
@@ -85,56 +102,106 @@ getBundleByHash = (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/"
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Registry routes
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
healthRoute = (method target :
|
||||
matchBool
|
||||
(pure (okResponse "OK\n"))
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "GET") (equal? target "/_arboricx/health")))
|
||||
lazyBool
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : pure (okResponse "OK\n"))
|
||||
(_ : pure notFoundResponse)
|
||||
(equal? target "/_arboricx/health"))
|
||||
(_ : pure notFoundResponse)
|
||||
(equal? method "GET"))
|
||||
|
||||
putBundleRoute = (root method target body :
|
||||
matchBool
|
||||
(bind (putBundle root body) (result :
|
||||
matchResult
|
||||
(err _ : pure (badRequestResponse (append "Upload failed: " err)))
|
||||
(hash _ : pure (createdResponse hash))
|
||||
result))
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "POST") (equal? target "/_arboricx/bundles")))
|
||||
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/bundles"))
|
||||
(_ : pure notFoundResponse)
|
||||
(equal? method "POST"))
|
||||
|
||||
getBundleRoute = (root method target :
|
||||
matchBool
|
||||
((hash :
|
||||
bind (getBundleByHash root hash) (result :
|
||||
matchResult
|
||||
(errMsg _ : pure (errorResponse 404 errMsg))
|
||||
(bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
|
||||
result))
|
||||
(drop 23 target))
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "GET") (startsWith? "/_arboricx/bundle/hash/" 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 :
|
||||
matchBool
|
||||
(getBundleRoute root method target)
|
||||
(matchBool
|
||||
(putBundleRoute root method target body)
|
||||
(matchBool
|
||||
(healthRoute method target)
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "GET") (equal? target "/_arboricx/health")))
|
||||
(and? (equal? method "POST") (equal? target "/_arboricx/bundles")))
|
||||
(and? (equal? method "GET") (startsWith? "/_arboricx/bundle/hash/" target)))
|
||||
lazyBool
|
||||
(_ :
|
||||
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))
|
||||
(_ :
|
||||
lazyBool
|
||||
(_ : putBundleRoute root method target body)
|
||||
(_ : pure notFoundResponse)
|
||||
(equal? method "POST"))
|
||||
(equal? method "GET"))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Server entrypoint
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
arboricxHandler = (root client peer :
|
||||
httpHandlerIO (arboricxRouter 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)
|
||||
|
||||
Reference in New Issue
Block a user