(: Aiche Tee Tee Pee :)
Perhaps the first webserver in Tree Calculus? Sure, it's married to a Haskell IO runtime... but we're managing all of the actual webserver semantics in tricu! This includes a demo Arboricx application server that is capable of storing and serving bundles.
This commit is contained in:
155
lib/arboricx/arboricx.tri
Normal file
155
lib/arboricx/arboricx.tri
Normal file
@@ -0,0 +1,155 @@
|
||||
!import "manifest.tri" !Local
|
||||
|
||||
-- Read and validate a full Arboricx bundle.
|
||||
-- Returns (pair validManifest afterContainer).
|
||||
-- The manifest core fields are validated against expected values.
|
||||
readArboricxBundle = (bs :
|
||||
bindResult (readArboricxRequiredSections bs)
|
||||
(sections afterContainer :
|
||||
matchPair
|
||||
(manifestBytes _ :
|
||||
bindResult (readManifest manifestBytes)
|
||||
(parsedManifest afterManifest :
|
||||
matchPair
|
||||
(coreManifest metadataWithExtensions :
|
||||
bindResult (validateManifestCore coreManifest afterManifest)
|
||||
(validCore _ : ok (pair validCore metadataWithExtensions) afterContainer))
|
||||
parsedManifest))
|
||||
sections))
|
||||
|
||||
-- Select an export from a validated bundle and reconstruct its root tree.
|
||||
-- Returns ok executable afterContainer, or propagates parse/selection/node errors.
|
||||
readArboricxExecutableByName = (nameBytes bs :
|
||||
bindResult (readArboricxBundle bs)
|
||||
(bundleResult afterBundle :
|
||||
matchPair
|
||||
(validCore _ :
|
||||
bindResult (selectExport (manifestExports validCore) nameBytes)
|
||||
(selectedExport _ :
|
||||
readArboricxTreeFromIndex (exportRoot selectedExport) bs))
|
||||
bundleResult))
|
||||
|
||||
readArboricxExecutable = (bs :
|
||||
readArboricxExecutableByName [] bs)
|
||||
|
||||
applyArgs = (f args :
|
||||
foldl
|
||||
(acc arg : acc arg)
|
||||
f
|
||||
args)
|
||||
|
||||
runArboricxByName = (nameBytes bs arg :
|
||||
bindResult (readArboricxExecutableByName nameBytes bs)
|
||||
(executable rest : ok (executable arg) rest))
|
||||
|
||||
runArboricx = (bs arg :
|
||||
runArboricxByName [] bs arg)
|
||||
|
||||
runArboricxArgsByName = (nameBytes bs args :
|
||||
bindResult (readArboricxExecutableByName nameBytes bs)
|
||||
(executable rest : ok (applyArgs executable args) rest))
|
||||
|
||||
runArboricxArgs = (bs args :
|
||||
runArboricxArgsByName [] bs args)
|
||||
|
||||
errHostCodecFailed = 14
|
||||
|
||||
hostTreeTag = 0
|
||||
hostStringTag = 1
|
||||
hostNumberTag = 2
|
||||
hostBoolTag = 3
|
||||
hostListTag = 4
|
||||
hostBytesTag = 5
|
||||
|
||||
hostTree = (value : pair hostTreeTag value)
|
||||
hostString = (bytes : pair hostStringTag bytes)
|
||||
hostNumber = (n : pair hostNumberTag n)
|
||||
hostBool = (b : pair hostBoolTag b)
|
||||
hostList = (xs : pair hostListTag xs)
|
||||
hostBytes = (bytes : pair hostBytesTag bytes)
|
||||
|
||||
hostValueTag = (hostValue : pairFirst hostValue)
|
||||
hostValuePayload = (hostValue : pairSecond hostValue)
|
||||
|
||||
hostBool? = (value : or? (equal? value false) (equal? value true))
|
||||
|
||||
hostNumber? = y (self value :
|
||||
triage
|
||||
true
|
||||
(_ : false)
|
||||
(bit rest :
|
||||
and?
|
||||
(or? (equal? bit false) (equal? bit true))
|
||||
(self rest))
|
||||
value)
|
||||
|
||||
hostList? = y (self value :
|
||||
triage
|
||||
true
|
||||
(_ : false)
|
||||
(_ rest : self rest)
|
||||
value)
|
||||
|
||||
hostString? = y (self value :
|
||||
matchList
|
||||
true
|
||||
(byte rest : and? (hostNumber? byte) (self rest))
|
||||
value)
|
||||
|
||||
hostBytes? = hostString?
|
||||
|
||||
wrapHostValue = (validator wrapper resultValue rest :
|
||||
matchBool
|
||||
(ok (wrapper resultValue) rest)
|
||||
(err errHostCodecFailed resultValue)
|
||||
(validator resultValue))
|
||||
|
||||
wrapHostValueByTag = (tag value rest :
|
||||
matchBool
|
||||
(ok (hostTree value) rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostString? hostString value rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostNumber? hostNumber value rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostBool? hostBool value rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostList? hostList value rest)
|
||||
(matchBool
|
||||
(wrapHostValue hostBytes? hostBytes value rest)
|
||||
(err errHostCodecFailed value)
|
||||
(equal? tag hostBytesTag))
|
||||
(equal? tag hostListTag))
|
||||
(equal? tag hostBoolTag))
|
||||
(equal? tag hostNumberTag))
|
||||
(equal? tag hostStringTag))
|
||||
(equal? tag hostTreeTag))
|
||||
|
||||
runArboricxByNameToTyped = (tag nameBytes bs args :
|
||||
bindResult (runArboricxArgsByName nameBytes bs args)
|
||||
(value rest : wrapHostValueByTag tag value rest))
|
||||
|
||||
runArboricxByNameToTree = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostTreeTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToString = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostStringTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToNumber = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostNumberTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToBool = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostBoolTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToList = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostListTag nameBytes bs args)
|
||||
|
||||
runArboricxByNameToBytes = (nameBytes bs args :
|
||||
runArboricxByNameToTyped hostBytesTag nameBytes bs args)
|
||||
|
||||
runArboricxToTree = (bs args : runArboricxByNameToTyped hostTreeTag [] bs args)
|
||||
runArboricxToString = (bs args : runArboricxByNameToTyped hostStringTag [] bs args)
|
||||
runArboricxToNumber = (bs args : runArboricxByNameToTyped hostNumberTag [] bs args)
|
||||
runArboricxToBool = (bs args : runArboricxByNameToTyped hostBoolTag [] bs args)
|
||||
runArboricxToList = (bs args : runArboricxByNameToTyped hostListTag [] bs args)
|
||||
runArboricxToBytes = (bs args : runArboricxByNameToTyped hostBytesTag [] bs args)
|
||||
432
lib/arboricx/common.tri
Normal file
432
lib/arboricx/common.tri
Normal file
@@ -0,0 +1,432 @@
|
||||
!import "../base.tri" !Local
|
||||
!import "../list.tri" !Local
|
||||
!import "../bytes.tri" !Local
|
||||
!import "../binary.tri" !Local
|
||||
|
||||
arboricxMagic = [(65) (82) (66) (79) (82) (73) (67) (88)]
|
||||
arboricxMajorVersion = [(0) (1)]
|
||||
arboricxMinorVersion = [(0) (0)]
|
||||
arboricxManifestSectionId = [(0) (0) (0) (1)]
|
||||
arboricxNodesSectionId = [(0) (0) (0) (2)]
|
||||
|
||||
-- Manifest magic and version constants
|
||||
arboricxManifestMagic = [(65) (82) (66) (77) (78) (70) (83) (84)]
|
||||
arboricxManifestMajorVersion = [(0) (1)]
|
||||
arboricxManifestMinorVersion = [(0) (0)]
|
||||
|
||||
errMissingSection = 4
|
||||
errUnsupportedVersion = 5
|
||||
errDuplicateSection = 6
|
||||
errDuplicateNode = 7
|
||||
errInvalidNodePayload = 8
|
||||
errMissingNode = 9
|
||||
errInvalidManifestMagic = 10
|
||||
errUnsupportedManifestVersion = 11
|
||||
errTrailingManifestBytes = 12
|
||||
errManifestValidationFailed = 13
|
||||
|
||||
nodePayloadLeafTag = 0
|
||||
nodePayloadStemTag = 1
|
||||
nodePayloadForkTag = 2
|
||||
|
||||
readArboricxMagic = (bs : expectBytes arboricxMagic bs)
|
||||
|
||||
readArboricxHeader = (bs :
|
||||
bindResult (readArboricxMagic bs)
|
||||
(_ afterMagic :
|
||||
bindResult (readBytes 2 afterMagic)
|
||||
(majorVersion afterMajor :
|
||||
bindResult (readBytes 2 afterMajor)
|
||||
(minorVersion afterMinor :
|
||||
bindResult (readBytes 4 afterMinor)
|
||||
(sectionCount afterSectionCount :
|
||||
bindResult (readBytes 8 afterSectionCount)
|
||||
(flags afterFlags :
|
||||
bindResult (readBytes 8 afterFlags)
|
||||
(dirOffset afterDirOffset :
|
||||
ok
|
||||
(pair majorVersion
|
||||
(pair minorVersion
|
||||
(pair sectionCount
|
||||
(pair flags dirOffset))))
|
||||
afterDirOffset)))))))
|
||||
|
||||
readSectionRecord = (bs :
|
||||
bindResult (readBytes 4 bs)
|
||||
(sectionId afterSectionId :
|
||||
bindResult (readBytes 2 afterSectionId)
|
||||
(sectionVersion afterSectionVersion :
|
||||
bindResult (readBytes 2 afterSectionVersion)
|
||||
(sectionFlags afterSectionFlags :
|
||||
bindResult (readBytes 2 afterSectionFlags)
|
||||
(compression afterCompression :
|
||||
bindResult (readBytes 2 afterCompression)
|
||||
(reserved1 afterReserved1 :
|
||||
bindResult (readBytes 8 afterReserved1)
|
||||
(offset afterOffset :
|
||||
bindResult (readBytes 8 afterOffset)
|
||||
(length afterLength :
|
||||
bindResult (readBytes 4 afterLength)
|
||||
(reserved2 afterReserved2 :
|
||||
ok
|
||||
(pair sectionId
|
||||
(pair sectionVersion
|
||||
(pair sectionFlags
|
||||
(pair compression
|
||||
(pair reserved1
|
||||
(pair offset
|
||||
(pair length reserved2)))))))
|
||||
afterReserved2)))))))))
|
||||
|
||||
readSectionDirectory_ = y (self bs sectionCount i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readSectionRecord bs)
|
||||
(sectionRecord afterSectionRecord :
|
||||
self afterSectionRecord sectionCount (succ i) (pair sectionRecord acc)))
|
||||
(equal? i sectionCount))
|
||||
|
||||
readSectionDirectory = (sectionCount bs : readSectionDirectory_ bs sectionCount 0 t)
|
||||
|
||||
sectionRecordId = (sectionRecord :
|
||||
matchPair
|
||||
(sectionId _ : sectionId)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordVersion = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(sectionVersion _ : sectionVersion)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordFlags = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(sectionFlags _ : sectionFlags)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordCompression = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(compression _ : compression)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordReserved1 = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(reserved1 _ : reserved1)
|
||||
payload4)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordOffset = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(_ payload5 :
|
||||
matchPair
|
||||
(offset _ : offset)
|
||||
payload5)
|
||||
payload4)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordLength = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(_ payload5 :
|
||||
matchPair
|
||||
(_ payload6 :
|
||||
matchPair
|
||||
(length _ : length)
|
||||
payload6)
|
||||
payload5)
|
||||
payload4)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
sectionRecordReserved2 = (sectionRecord :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ payload4 :
|
||||
matchPair
|
||||
(_ payload5 :
|
||||
matchPair
|
||||
(_ payload6 :
|
||||
matchPair
|
||||
(_ reserved2 : reserved2)
|
||||
payload6)
|
||||
payload5)
|
||||
payload4)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
sectionRecord)
|
||||
|
||||
lookupSectionRecord_ = y (self directory sectionId :
|
||||
matchList
|
||||
nothing
|
||||
(sectionRecord rest :
|
||||
matchBool
|
||||
(just sectionRecord)
|
||||
(self rest sectionId)
|
||||
(bytesEq? sectionId (sectionRecordId sectionRecord)))
|
||||
directory)
|
||||
|
||||
lookupSectionRecord = (sectionId directory : lookupSectionRecord_ directory sectionId)
|
||||
|
||||
sectionDirectoryHasId?_ = y (self directory sectionId :
|
||||
matchList
|
||||
false
|
||||
(sectionRecord rest :
|
||||
or?
|
||||
(bytesEq? sectionId (sectionRecordId sectionRecord))
|
||||
(self rest sectionId))
|
||||
directory)
|
||||
|
||||
sectionDirectoryHasId? = (sectionId directory : sectionDirectoryHasId?_ directory sectionId)
|
||||
|
||||
sectionDirectoryHasDuplicateIds? = y (self directory :
|
||||
matchList
|
||||
false
|
||||
(sectionRecord rest :
|
||||
or?
|
||||
(sectionDirectoryHasId?_ rest (sectionRecordId sectionRecord))
|
||||
(self rest))
|
||||
directory)
|
||||
|
||||
validateSectionDirectory = (directory rest :
|
||||
matchBool
|
||||
(err errDuplicateSection rest)
|
||||
(ok directory rest)
|
||||
(sectionDirectoryHasDuplicateIds? directory))
|
||||
|
||||
byteSlice = (offset length bytes : bytesTake length (bytesDrop offset bytes))
|
||||
|
||||
natMake = (bit rest :
|
||||
matchBool
|
||||
0
|
||||
(pair bit rest)
|
||||
(and? (equal? bit 0) (equal? rest 0)))
|
||||
|
||||
natAdd = y (self a b :
|
||||
triage
|
||||
b
|
||||
(_ : b)
|
||||
(aBit aRest :
|
||||
triage
|
||||
a
|
||||
(_ : a)
|
||||
(bBit bRest :
|
||||
matchBool
|
||||
(natMake 0 (succ (self aRest bRest)))
|
||||
(natMake (matchBool (matchBool 0 1 bBit) (matchBool 1 0 bBit) aBit)
|
||||
(self aRest bRest))
|
||||
(and? (equal? aBit 1) (equal? bBit 1)))
|
||||
b)
|
||||
a)
|
||||
|
||||
natDouble = (n : matchBool 0 (pair 0 n) (equal? n 0))
|
||||
|
||||
natTimes256 = (n :
|
||||
natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble
|
||||
(natDouble n))))))))
|
||||
|
||||
byteNatShiftAppend_ = y (self byte acc i :
|
||||
matchBool
|
||||
acc
|
||||
(triage
|
||||
(natMake 0 (self 0 acc (succ i)))
|
||||
(_ : acc)
|
||||
(bit rest : natMake bit (self rest acc (succ i)))
|
||||
byte)
|
||||
(equal? i 8))
|
||||
|
||||
byteNatShiftAppend = (byte acc : byteNatShiftAppend_ byte acc 0)
|
||||
|
||||
beBytesToNat = (bytes :
|
||||
foldl
|
||||
(acc byte : byteNatShiftAppend byte acc)
|
||||
0
|
||||
bytes)
|
||||
|
||||
u32BEBytesToNat = beBytesToNat
|
||||
u64BEBytesToNat = beBytesToNat
|
||||
|
||||
arboricxHeaderMajorVersion = (header :
|
||||
matchPair
|
||||
(majorVersion _ : majorVersion)
|
||||
header)
|
||||
|
||||
arboricxHeaderMinorVersion = (header :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(minorVersion _ : minorVersion)
|
||||
payload)
|
||||
header)
|
||||
|
||||
arboricxHeaderSectionCount = (header :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(sectionCount _ : sectionCount)
|
||||
payload2)
|
||||
payload)
|
||||
header)
|
||||
|
||||
arboricxHeaderFlags = (header :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(flags _ : flags)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
header)
|
||||
|
||||
arboricxHeaderDirOffset = (header :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(_ payload2 :
|
||||
matchPair
|
||||
(_ payload3 :
|
||||
matchPair
|
||||
(_ dirOffset : dirOffset)
|
||||
payload3)
|
||||
payload2)
|
||||
payload)
|
||||
header)
|
||||
|
||||
validateArboricxHeader = (header rest :
|
||||
matchBool
|
||||
(ok header rest)
|
||||
(err errUnsupportedVersion rest)
|
||||
(and?
|
||||
(bytesEq? arboricxMajorVersion (arboricxHeaderMajorVersion header))
|
||||
(bytesEq? arboricxMinorVersion (arboricxHeaderMinorVersion header))))
|
||||
|
||||
readArboricxContainer = (bs :
|
||||
bindResult (readArboricxHeader bs)
|
||||
(header afterHeader :
|
||||
bindResult (validateArboricxHeader header afterHeader)
|
||||
(validHeader afterValidHeader :
|
||||
bindResult (readSectionDirectory
|
||||
(u32BEBytesToNat (arboricxHeaderSectionCount validHeader))
|
||||
(bytesDrop (u64BEBytesToNat (arboricxHeaderDirOffset validHeader)) bs))
|
||||
(directory afterDirectory :
|
||||
bindResult (validateSectionDirectory directory afterDirectory)
|
||||
(validDirectory afterValidDirectory :
|
||||
ok (pair validHeader validDirectory) afterValidDirectory)))))
|
||||
|
||||
sectionRecordOffsetNat = (sectionRecord :
|
||||
u64BEBytesToNat (sectionRecordOffset sectionRecord))
|
||||
|
||||
sectionRecordLengthNat = (sectionRecord :
|
||||
u64BEBytesToNat (sectionRecordLength sectionRecord))
|
||||
|
||||
extractSectionBytes = (sectionRecord containerBytes :
|
||||
byteSlice
|
||||
(sectionRecordOffsetNat sectionRecord)
|
||||
(sectionRecordLengthNat sectionRecord)
|
||||
containerBytes)
|
||||
|
||||
extractSectionBytesResult = (sectionRecord containerBytes rest :
|
||||
(sectionBytes :
|
||||
matchBool
|
||||
(ok sectionBytes rest)
|
||||
(err errUnexpectedEof rest)
|
||||
(equal? (bytesLength sectionBytes) (sectionRecordLengthNat sectionRecord)))
|
||||
(extractSectionBytes sectionRecord containerBytes))
|
||||
|
||||
lookupSectionBytes = (sectionId directory containerBytes :
|
||||
triage
|
||||
nothing
|
||||
(sectionRecord : just (extractSectionBytes sectionRecord containerBytes))
|
||||
(_ _ : nothing)
|
||||
(lookupSectionRecord sectionId directory))
|
||||
|
||||
sectionBytesOrErr = (sectionId directory containerBytes rest :
|
||||
triage
|
||||
(err errMissingSection rest)
|
||||
(sectionRecord : extractSectionBytesResult sectionRecord containerBytes rest)
|
||||
(_ _ : err errMissingSection rest)
|
||||
(lookupSectionRecord sectionId directory))
|
||||
|
||||
readArboricxSectionBytes = (sectionId bs :
|
||||
bindResult (readArboricxContainer bs)
|
||||
(container afterContainer :
|
||||
matchPair
|
||||
(_ directory : sectionBytesOrErr sectionId directory bs afterContainer)
|
||||
container))
|
||||
|
||||
readArboricxRequiredSections = (bs :
|
||||
bindResult (readArboricxContainer bs)
|
||||
(container afterContainer :
|
||||
matchPair
|
||||
(_ directory :
|
||||
bindResult (sectionBytesOrErr arboricxManifestSectionId directory bs afterContainer)
|
||||
(manifestBytes _ :
|
||||
bindResult (sectionBytesOrErr arboricxNodesSectionId directory bs afterContainer)
|
||||
(nodesBytes _ :
|
||||
ok (pair manifestBytes nodesBytes) afterContainer)))
|
||||
container))
|
||||
6
lib/arboricx/dispatch.tri
Normal file
6
lib/arboricx/dispatch.tri
Normal file
@@ -0,0 +1,6 @@
|
||||
!import "arboricx.tri" !Local
|
||||
|
||||
-- Multi-purpose kernel dispatch.
|
||||
-- runArboricxTyped tag bundleBytes args
|
||||
runArboricxTyped = (tag bs args :
|
||||
runArboricxByNameToTyped tag [] bs args)
|
||||
343
lib/arboricx/manifest.tri
Normal file
343
lib/arboricx/manifest.tri
Normal file
@@ -0,0 +1,343 @@
|
||||
!import "nodes.tri" !Local
|
||||
|
||||
readManifestMagic = (bs :
|
||||
expectBytes arboricxManifestMagic bs)
|
||||
|
||||
-- Read a u32 BE length, then that many raw bytes.
|
||||
-- Returns the payload bytes and remaining input.
|
||||
readLengthPrefixedString = (bs :
|
||||
bindResult (readBytes 4 bs)
|
||||
(lengthBytes afterLengthBytes :
|
||||
bindResult (readBytes (u32BEBytesToNat lengthBytes) afterLengthBytes)
|
||||
(payload afterPayload :
|
||||
ok payload afterPayload)))
|
||||
|
||||
-- Helper: read a single capability string (length-prefixed string)
|
||||
readCapability = (bs :
|
||||
readLengthPrefixedString bs)
|
||||
|
||||
-- Helper worker: read N capability strings (counts up from 0)
|
||||
readCapabilities_ = y (self bs count i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readCapability bs)
|
||||
(cap afterCap :
|
||||
self afterCap count (succ i) (pair cap acc)))
|
||||
(equal? i count))
|
||||
|
||||
-- Helper: read N capabilities
|
||||
readCapabilities = (count bs :
|
||||
readCapabilities_ bs count 0 t)
|
||||
|
||||
-- Helper: read a single root entry (4-byte u32 BE index + length-prefixed role)
|
||||
readRootEntry = (bs :
|
||||
bindResult (readBytes 4 bs)
|
||||
(indexRaw afterIndex :
|
||||
bindResult (readLengthPrefixedString afterIndex)
|
||||
(role afterRole :
|
||||
ok (pair indexRaw role) afterRole)))
|
||||
|
||||
-- Helper worker: read N root entries (counts up from 0)
|
||||
readRoots_ = y (self bs count i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readRootEntry bs)
|
||||
(root afterRoot :
|
||||
self afterRoot count (succ i) (pair root acc)))
|
||||
(equal? i count))
|
||||
|
||||
-- Helper: read N roots
|
||||
readRoots = (count bs :
|
||||
readRoots_ bs count 0 t)
|
||||
|
||||
-- Helper: read a single export entry
|
||||
readExportEntry = (bs :
|
||||
bindResult (readLengthPrefixedString bs)
|
||||
(name afterName :
|
||||
bindResult (readBytes 4 afterName)
|
||||
(rootIndexRaw afterRootIndex :
|
||||
bindResult (readLengthPrefixedString afterRootIndex)
|
||||
(kind afterKind :
|
||||
bindResult (readLengthPrefixedString afterKind)
|
||||
(abi afterAbi :
|
||||
ok (pair name (pair rootIndexRaw (pair kind abi))) afterAbi)))))
|
||||
|
||||
-- Helper worker: read N export entries (counts up from 0)
|
||||
readExports_ = y (self bs count i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readExportEntry bs)
|
||||
(exp afterExp :
|
||||
self afterExp count (succ i) (pair exp acc)))
|
||||
(equal? i count))
|
||||
|
||||
-- Helper: read N exports
|
||||
readExports = (count bs :
|
||||
readExports_ bs count 0 t)
|
||||
|
||||
-- Main core manifest parser.
|
||||
-- Reads: magic, version, core strings, capabilities, closure, roots, exports.
|
||||
readManifestCore = (bs :
|
||||
bindResult (readManifestMagic bs)
|
||||
(_ afterMagic :
|
||||
bindResult (readBytes 2 afterMagic)
|
||||
(majorVersion afterMajor :
|
||||
bindResult (readBytes 2 afterMajor)
|
||||
(minorVersion afterMinor :
|
||||
bindResult (readLengthPrefixedString afterMinor)
|
||||
(schema afterSchema :
|
||||
bindResult (readLengthPrefixedString afterSchema)
|
||||
(bundleType afterBundleType :
|
||||
bindResult (readLengthPrefixedString afterBundleType)
|
||||
(treeCalculus afterTreeCalculus :
|
||||
bindResult (readLengthPrefixedString afterTreeCalculus)
|
||||
(treeHashAlgorithm afterTreeHashAlgorithm :
|
||||
bindResult (readLengthPrefixedString afterTreeHashAlgorithm)
|
||||
(treeHashDomain afterTreeHashDomain :
|
||||
bindResult (readLengthPrefixedString afterTreeHashDomain)
|
||||
(treeNodePayload afterTreeNodePayload :
|
||||
bindResult (readLengthPrefixedString afterTreeNodePayload)
|
||||
(runtimeSemantics afterRuntimeSemantics :
|
||||
bindResult (readLengthPrefixedString afterRuntimeSemantics)
|
||||
(runtimeEvaluation afterRuntimeEvaluation :
|
||||
bindResult (readLengthPrefixedString afterRuntimeEvaluation)
|
||||
(runtimeAbi afterRuntimeAbi :
|
||||
bindResult (readBytes 4 afterRuntimeAbi)
|
||||
(capCountRaw afterCapCountRaw :
|
||||
bindResult (readCapabilities (u32BEBytesToNat capCountRaw) afterCapCountRaw)
|
||||
(capabilities afterCapabilities :
|
||||
bindResult (readBytes 1 afterCapabilities)
|
||||
(closureByte afterClosureByte :
|
||||
bindResult (readBytes 4 afterClosureByte)
|
||||
(rootCountRaw afterRootCountRaw :
|
||||
bindResult (readRoots (u32BEBytesToNat rootCountRaw) afterRootCountRaw)
|
||||
(roots afterRoots :
|
||||
bindResult (readBytes 4 afterRoots)
|
||||
(exportCountRaw afterExportCountRaw :
|
||||
bindResult (readExports (u32BEBytesToNat exportCountRaw) afterExportCountRaw)
|
||||
(exports afterExports :
|
||||
ok
|
||||
(pair schema
|
||||
(pair bundleType
|
||||
(pair treeCalculus
|
||||
(pair treeHashAlgorithm
|
||||
(pair treeHashDomain
|
||||
(pair treeNodePayload
|
||||
(pair runtimeSemantics
|
||||
(pair runtimeEvaluation
|
||||
(pair runtimeAbi
|
||||
(pair capabilities
|
||||
(pair closureByte (pair roots exports)))))))))))) afterExports))))))))))))))))))))
|
||||
|
||||
-- Metadata tag constants (u16 values)
|
||||
tagPackage = [(0) (1)]
|
||||
tagVersion = [(0) (2)]
|
||||
tagDescription = [(0) (3)]
|
||||
tagLicense = [(0) (4)]
|
||||
tagCreatedBy = [(0) (5)]
|
||||
|
||||
-- Read a single TLV entry: u16 tag + u32 length + value bytes.
|
||||
-- Returns the pair (tag, value) and remaining input.
|
||||
readTLV = (bs :
|
||||
bindResult (readBytes 2 bs)
|
||||
(tag afterTag :
|
||||
bindResult (readBytes 4 afterTag)
|
||||
(tlvLenRaw afterTlvLenRaw :
|
||||
bindResult (readBytes (u32BEBytesToNat tlvLenRaw) afterTlvLenRaw)
|
||||
(tlvValue afterTlvValue :
|
||||
ok (pair tag tlvValue) afterTlvValue))))
|
||||
|
||||
-- Worker: read N TLV entries (counts up from 0)
|
||||
readTLVs_ = y (self bs count i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readTLV bs)
|
||||
(tlv afterTlv :
|
||||
self afterTlv count (succ i) (pair tlv acc)))
|
||||
(equal? i count))
|
||||
|
||||
-- Read a count followed by that many TLV entries.
|
||||
readTLVList = (count bs :
|
||||
readTLVs_ bs count 0 t)
|
||||
|
||||
-- Skip N extension TLV entries (counts up from 0)
|
||||
skipTLVs_ = y (self bs count i :
|
||||
matchBool
|
||||
(ok unit bs)
|
||||
(bindResult (readTLV bs)
|
||||
(_ afterTlv :
|
||||
self afterTlv count (succ i)))
|
||||
(equal? i count))
|
||||
|
||||
-- Full manifest parser: core fields + metadata TLV list + extension TLV list.
|
||||
readManifest = (bs :
|
||||
bindResult (readManifestCore bs)
|
||||
(coreManifest afterCore :
|
||||
bindResult (readBytes 4 afterCore)
|
||||
(metaCountRaw afterMetaCountRaw :
|
||||
bindResult (readTLVList (u32BEBytesToNat metaCountRaw) afterMetaCountRaw)
|
||||
(metadataFields afterMetadataFields :
|
||||
bindResult (readBytes 4 afterMetadataFields)
|
||||
(extCountRaw afterExtCountRaw :
|
||||
bindResult (skipTLVs_ afterExtCountRaw (u32BEBytesToNat extCountRaw) 0)
|
||||
(afterExtensions _ :
|
||||
ok
|
||||
(pair coreManifest (pair metadataFields afterExtensions))
|
||||
afterExtensions))))))
|
||||
|
||||
-- Lookup a metadata value by tag from a TLV list.
|
||||
-- Returns nothing if not found, just value if found.
|
||||
lookupMetadata_ = y (self tlvs tag :
|
||||
matchList
|
||||
nothing
|
||||
(tlv rest :
|
||||
matchBool
|
||||
(just (matchPair (_ value : value) tlv))
|
||||
(self rest tag)
|
||||
(bytesEq? (matchPair (tlvTag _ : tlvTag) tlv) tag))
|
||||
tlvs)
|
||||
|
||||
lookupMetadata = (tlvs tag :
|
||||
lookupMetadata_ tlvs tag)
|
||||
|
||||
-- Get export name from an export entry (pair name (pair rootIndex (pair kind abi)))
|
||||
exportName = (exp :
|
||||
matchPair
|
||||
(name _ : name)
|
||||
exp)
|
||||
|
||||
exportRoot = (exp :
|
||||
matchPair
|
||||
(_ payload :
|
||||
matchPair
|
||||
(root _ : root)
|
||||
payload)
|
||||
exp)
|
||||
|
||||
-- Check if an export name matches a given byte string.
|
||||
exportNameEq? = (nameBytes exp :
|
||||
bytesEq? nameBytes (exportName exp))
|
||||
|
||||
-- Find first export matching a name, or nothing.
|
||||
findExportByName_ = y (self exports name :
|
||||
matchList
|
||||
nothing
|
||||
(exp rest :
|
||||
matchBool
|
||||
(just exp)
|
||||
(self rest name)
|
||||
(exportNameEq? name exp))
|
||||
exports)
|
||||
|
||||
findExportByName = (exports name :
|
||||
findExportByName_ exports name)
|
||||
|
||||
-- Get list of all export names from a list of exports.
|
||||
getExportNames_ = y (self acc exports :
|
||||
matchList
|
||||
(reverse acc)
|
||||
(exp rest :
|
||||
self (pair (exportName exp) acc) rest)
|
||||
exports)
|
||||
|
||||
getExportNames = (exports :
|
||||
getExportNames_ t exports)
|
||||
|
||||
mainExportName = "main"
|
||||
|
||||
maybeExportToResult = (maybeExport :
|
||||
triage
|
||||
(err errMissingSection t)
|
||||
(export : ok export t)
|
||||
(_ _ : err errMissingSection t)
|
||||
maybeExport)
|
||||
|
||||
selectSingleExport = (exports :
|
||||
matchList
|
||||
(err errMissingSection t)
|
||||
(export rest :
|
||||
matchBool
|
||||
(ok export t)
|
||||
(err errMissingSection t)
|
||||
(emptyList? rest))
|
||||
exports)
|
||||
|
||||
selectDefaultExport = (exports :
|
||||
triage
|
||||
(selectSingleExport exports)
|
||||
(export : ok export t)
|
||||
(_ _ : err errMissingSection t)
|
||||
(findExportByName exports mainExportName))
|
||||
|
||||
-- Select an export: explicit name if provided, otherwise "main", otherwise
|
||||
-- the sole export if the bundle has exactly one export.
|
||||
selectExport = (exports nameBytes :
|
||||
matchBool
|
||||
(selectDefaultExport exports)
|
||||
(maybeExportToResult (findExportByName exports nameBytes))
|
||||
(emptyList? nameBytes))
|
||||
|
||||
selectExportOpt = (exports optNameBytes :
|
||||
selectExport exports optNameBytes)
|
||||
|
||||
-- Expected core string values (raw UTF-8 bytes, not decoded to Unicode characters).
|
||||
expectedSchema = "arboricx.bundle.manifest.v1"
|
||||
expectedBundleType = "tree-calculus-executable-object"
|
||||
expectedTreeCalculus = "tree-calculus.v1"
|
||||
expectedTreeHashAlgorithm = "indexed"
|
||||
expectedTreeHashDomain = "arboricx.indexed.node.v1"
|
||||
expectedTreeNodePayload = "arboricx.indexed.payload.v1"
|
||||
expectedRuntimeSemantics = "tree-calculus.v1"
|
||||
expectedRuntimeEvaluation = "normal-order"
|
||||
expectedRuntimeAbi = "arboricx.abi.tree.v1"
|
||||
|
||||
-- Manifest core field accessors.
|
||||
-- readManifestCore returns: (pair schema (pair bundleType (... (pair closureByte (pair roots exports)))))
|
||||
pairFirst = (p : matchPair (a _ : a) p)
|
||||
pairSecond = (p : matchPair (_ b : b) p)
|
||||
|
||||
manifestSchema = (core : pairFirst core)
|
||||
manifestBundleType = (core : pairFirst (pairSecond core))
|
||||
manifestTreeCalculus = (core : pairFirst (pairSecond (pairSecond core)))
|
||||
manifestTreeHashAlgorithm = (core : pairFirst (pairSecond (pairSecond (pairSecond core))))
|
||||
manifestTreeHashDomain = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond core)))))
|
||||
manifestTreeNodePayload = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))
|
||||
manifestRuntimeSemantics = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core)))))))
|
||||
manifestRuntimeEvaluation = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))))
|
||||
manifestRuntimeAbi = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core)))))))))
|
||||
manifestCapabilities = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))))))
|
||||
manifestClosureByte = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core)))))))))))
|
||||
manifestRoots = (core : pairFirst (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))))))))
|
||||
manifestExports = (core : pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond (pairSecond core))))))))))))
|
||||
|
||||
-- Helper: compare a manifest field against an expected byte string.
|
||||
manifestFieldMatch? = (actual expected : bytesEq? actual expected)
|
||||
|
||||
-- Validate core manifest fields against expected values.
|
||||
validateManifestCore = (core rest :
|
||||
matchBool
|
||||
(ok core rest)
|
||||
(err errManifestValidationFailed rest)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestSchema core) expectedSchema)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestBundleType core) expectedBundleType)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestTreeCalculus core) expectedTreeCalculus)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestTreeHashAlgorithm core) expectedTreeHashAlgorithm)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestTreeHashDomain core) expectedTreeHashDomain)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestTreeNodePayload core) expectedTreeNodePayload)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestRuntimeSemantics core) expectedRuntimeSemantics)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestRuntimeEvaluation core) expectedRuntimeEvaluation)
|
||||
(and?
|
||||
(manifestFieldMatch? (manifestRuntimeAbi core) expectedRuntimeAbi)
|
||||
(and?
|
||||
(bytesEq? (manifestClosureByte core) [(0)])
|
||||
(and?
|
||||
(not? (emptyList? (manifestRoots core)))
|
||||
(not? (emptyList? (manifestExports core)))))))))))))))
|
||||
208
lib/arboricx/nodes.tri
Normal file
208
lib/arboricx/nodes.tri
Normal file
@@ -0,0 +1,208 @@
|
||||
!import "common.tri" !Local
|
||||
|
||||
-- Indexed Arboricx node section reader.
|
||||
--
|
||||
-- Node records in the indexed format are just length-prefixed payloads:
|
||||
-- u32 payloadLength || payload
|
||||
-- A payload is one of:
|
||||
-- 0x00
|
||||
-- 0x01 || childIndex:u32be
|
||||
-- 0x02 || leftIndex:u32be || rightIndex:u32be
|
||||
-- Child indices must point strictly backward in the node array.
|
||||
|
||||
readNodeRecord = (bs :
|
||||
bindResult (readBytes 4 bs)
|
||||
(payloadLength afterPayloadLength :
|
||||
bindResult (readBytes (u32BEBytesToNat payloadLength) afterPayloadLength)
|
||||
(payload afterPayload :
|
||||
ok payload afterPayload)))
|
||||
|
||||
nodePayloadKind = (nodePayload : bytesHead nodePayload)
|
||||
|
||||
nodePayloadHasTag? = (tag nodePayload :
|
||||
triage
|
||||
false
|
||||
(actualTag : equal? actualTag tag)
|
||||
(_ _ : false)
|
||||
(nodePayloadKind nodePayload))
|
||||
|
||||
nodePayloadLeaf? = (nodePayload :
|
||||
bytesEq? [(0)] nodePayload)
|
||||
|
||||
nodePayloadStem? = (nodePayload :
|
||||
and?
|
||||
(nodePayloadHasTag? nodePayloadStemTag nodePayload)
|
||||
(equal? (bytesLength nodePayload) 5))
|
||||
|
||||
nodePayloadFork? = (nodePayload :
|
||||
and?
|
||||
(nodePayloadHasTag? nodePayloadForkTag nodePayload)
|
||||
(equal? (bytesLength nodePayload) 9))
|
||||
|
||||
nodePayloadValid? = (nodePayload :
|
||||
or?
|
||||
(nodePayloadLeaf? nodePayload)
|
||||
(or?
|
||||
(nodePayloadStem? nodePayload)
|
||||
(nodePayloadFork? nodePayload)))
|
||||
|
||||
nodePayloadStemChildIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 1 nodePayload)))
|
||||
|
||||
nodePayloadForkLeftIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 1 nodePayload)))
|
||||
|
||||
nodePayloadForkRightIndex = (nodePayload :
|
||||
u32BEBytesToNat (bytesTake 4 (bytesDrop 5 nodePayload)))
|
||||
|
||||
nodeRecordsHaveInvalidPayload? = y (self nodeRecords :
|
||||
matchList
|
||||
false
|
||||
(nodePayload rest :
|
||||
or?
|
||||
(not? (nodePayloadValid? nodePayload))
|
||||
(self rest))
|
||||
nodeRecords)
|
||||
|
||||
nodePayloadChildIndices = (nodePayload :
|
||||
matchBool
|
||||
t
|
||||
(matchBool
|
||||
(pair (nodePayloadStemChildIndex nodePayload) t)
|
||||
(pair (nodePayloadForkLeftIndex nodePayload)
|
||||
(pair (nodePayloadForkRightIndex nodePayload) t))
|
||||
(nodePayloadStem? nodePayload))
|
||||
(nodePayloadLeaf? 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
|
||||
false
|
||||
(matchList
|
||||
false
|
||||
(_ rest :
|
||||
matchBool
|
||||
true
|
||||
(self n rest (succ i) limit)
|
||||
(equal? i n))
|
||||
records)
|
||||
(equal? i limit))
|
||||
|
||||
nodeChildIndicesInPrefix? = y (self childIndices records limit :
|
||||
matchList
|
||||
true
|
||||
(childIndex rest :
|
||||
matchBool
|
||||
(self rest records limit)
|
||||
false
|
||||
(nodeIndexInPrefix? childIndex records 0 limit))
|
||||
childIndices)
|
||||
|
||||
nodePayloadIndicesValid? = (nodePayload i records :
|
||||
nodeChildIndicesInPrefix?
|
||||
(nodePayloadChildIndices nodePayload)
|
||||
records
|
||||
i)
|
||||
|
||||
nodeRecordsValidIndicesFrom? = y (self allRecords remainingRecords i :
|
||||
matchList
|
||||
true
|
||||
(nodePayload rest :
|
||||
matchBool
|
||||
(self allRecords rest (succ i))
|
||||
false
|
||||
(nodePayloadIndicesValid? nodePayload i allRecords))
|
||||
remainingRecords)
|
||||
|
||||
nodeRecordsValidIndices? = (nodeRecords i :
|
||||
nodeRecordsValidIndicesFrom? nodeRecords nodeRecords i)
|
||||
|
||||
validateNodeRecords = (nodeRecords rest :
|
||||
matchBool
|
||||
(err errInvalidNodePayload rest)
|
||||
(matchBool
|
||||
(ok nodeRecords rest)
|
||||
(err errMissingNode rest)
|
||||
(nodeRecordsValidIndices? nodeRecords 0))
|
||||
(nodeRecordsHaveInvalidPayload? nodeRecords))
|
||||
|
||||
readNodeRecords_ = y (self bs nodeCount i acc :
|
||||
matchBool
|
||||
(ok (reverse acc) bs)
|
||||
(bindResult (readNodeRecord bs)
|
||||
(nodeRecord afterNodeRecord :
|
||||
self afterNodeRecord nodeCount (succ i) (pair nodeRecord acc)))
|
||||
(equal? i nodeCount))
|
||||
|
||||
readNodeRecords = (nodeCount bs :
|
||||
readNodeRecords_ bs nodeCount 0 t)
|
||||
|
||||
readNodesSection = (bs :
|
||||
bindResult (readBytes 8 bs)
|
||||
(nodeCount afterNodeCount :
|
||||
bindResult (readNodeRecords (u64BEBytesToNat nodeCount) afterNodeCount)
|
||||
(nodeRecords afterNodeRecords :
|
||||
bindResult (validateNodeRecords nodeRecords afterNodeRecords)
|
||||
(validNodeRecords afterValidNodeRecords :
|
||||
ok (pair nodeCount validNodeRecords) afterValidNodeRecords))))
|
||||
|
||||
readNodesSectionComplete = (bs :
|
||||
bindResult (readNodesSection bs)
|
||||
(nodesSection afterNodesSection :
|
||||
matchBool
|
||||
(ok nodesSection afterNodesSection)
|
||||
(err errUnexpectedBytes afterNodesSection)
|
||||
(bytesNil? afterNodesSection)))
|
||||
|
||||
readArboricxNodesSection = (bs :
|
||||
bindResult (readArboricxContainer bs)
|
||||
(container afterContainer :
|
||||
matchPair
|
||||
(_ directory :
|
||||
bindResult (sectionBytesOrErr arboricxNodesSectionId directory bs afterContainer)
|
||||
(nodesBytes _ :
|
||||
bindResult (readNodesSectionComplete nodesBytes)
|
||||
(nodesSection _ : ok nodesSection afterContainer)))
|
||||
container))
|
||||
|
||||
nodesSectionCount = (nodesSection :
|
||||
matchPair
|
||||
(nodeCount _ : nodeCount)
|
||||
nodesSection)
|
||||
|
||||
nodesSectionRecords = (nodesSection :
|
||||
matchPair
|
||||
(_ 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))
|
||||
|
||||
nodeIndexToTree = y (self nodeIndex nodeRecords :
|
||||
(nodePayload :
|
||||
matchBool
|
||||
(nodePayloadToTreeWith self nodeRecords nodePayload)
|
||||
(err errMissingNode t)
|
||||
(not? (equal? nodePayload t)))
|
||||
(nth nodeIndex nodeRecords))
|
||||
|
||||
readArboricxTreeFromIndex = (rootIndexBytes bs :
|
||||
bindResult (readArboricxNodesSection bs)
|
||||
(nodesSection afterContainer :
|
||||
bindResult (nodeIndexToTree (u32BEBytesToNat rootIndexBytes) (nodesSectionRecords nodesSection))
|
||||
(tree _ : ok tree afterContainer)))
|
||||
|
||||
readArboricxExecutableFromIndex = readArboricxTreeFromIndex
|
||||
143
lib/arboricx/server.tri
Normal file
143
lib/arboricx/server.tri
Normal file
@@ -0,0 +1,143 @@
|
||||
!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
|
||||
|
||||
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"))))
|
||||
|
||||
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
|
||||
(take 3 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)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Registry routes
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
healthRoute = (method target :
|
||||
matchBool
|
||||
(pure (okResponse "OK\n"))
|
||||
(pure notFoundResponse)
|
||||
(and? (equal? method "GET") (equal? target "/_arboricx/health")))
|
||||
|
||||
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")))
|
||||
|
||||
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)))
|
||||
|
||||
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)))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Server entrypoint
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
arboricxHandler = (root client peer :
|
||||
httpHandlerIO (arboricxRouter root) client peer)
|
||||
|
||||
arboricxServer = (root addr port :
|
||||
onResult_ (listenSocket addr port 128)
|
||||
(errMsg : pure (err errMsg t))
|
||||
(server :
|
||||
serveForever server (arboricxHandler root)))
|
||||
Reference in New Issue
Block a user