(: 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.

lib/arboricx/arboricx.tri

@@ -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)