commit 71fbeaf66914bc57c8bf80fb585c18db4d4c8722
parent a57689e0d9819550bc31c3c2b3f4ddb87445339a
Author: James Eversole <james@eversole.co>
Date: Wed, 20 May 2026 15:52:03 -0500
(: Aiche Tee Tee Pee :)
Diffstat:
31 files changed, 2984 insertions(+), 1531 deletions(-)
diff --git a/.gitea/workflows/test-and-build.yml b/.gitea/workflows/test-and-build.yml
@@ -1,65 +0,0 @@
-name: Test, Build, and Release
-
-on:
- push:
- tags:
- - '*'
-
-jobs:
- test:
- container:
- image: docker.matri.cx/nix-runner:v0.1.0
- credentials:
- username: ${{ secrets.REGISTRY_USERNAME }}
- password: ${{ secrets.REGISTRY_PASSWORD }}
- steps:
- - uses: actions/checkout@v3
- with:
- fetch-depth: 0
-
- - name: Set up cache for Cabal
- uses: actions/cache@v4
- with:
- path: |
- ~/.cache/cabal
- ~/.config/cabal
- ~/.local/state/cabal
- key: cabal-${{ hashFiles('tricu.cabal') }}
- restore-keys: |
- cabal-
-
- - name: Initialize Cabal and update package list
- run: |
- nix develop --command cabal update
-
- - name: Run test suite
- run: |
- nix develop --command cabal test
-
- build:
- needs: test
- container:
- image: docker.matri.cx/nix-runner:v0.1.0
- credentials:
- username: ${{ secrets.REGISTRY_USERNAME }}
- password: ${{ secrets.REGISTRY_PASSWORD }}
- steps:
- - uses: actions/checkout@v3
- with:
- fetch-depth: 0
-
- - name: Build and shrink binary
- run: |
- nix build
- cp -L ./result/bin/tricu ./tricu
- chmod 755 ./tricu
- nix develop --command upx ./tricu
-
- - name: Release binary
- uses: akkuman/gitea-release-action@v1
- with:
- files: |-
- ./tricu
- token: '${{ secrets.RELEASE_TOKEN }}'
- body: '${{ gitea.event.head_commit.message }}'
- prerelease: true
diff --git a/AGENTS.md b/AGENTS.md
@@ -2,10 +2,6 @@
> For AI agents and contributors working in this repository.
-## 0. Test Driven Development
-
-Write and discuss tests with the user before working on implementation code. Do not modify existing tests without explicit permission.
-
## 1. Build & Test
```bash
diff --git a/bench/Bench.hs b/bench/Bench.hs
@@ -33,7 +33,7 @@ main = do
!listLib <- loadLib "lib/list.tri"
-- Stress benchmark environment: Arboricx parser + size + toSource
- !arboricxLib <- loadLib "lib/arboricx-dispatch.tri"
+ !arboricxLib <- loadLib "lib/arboricx/dispatch.tri"
!sizeEnv <- evaluateFileWithContext arboricxLib "demos/size.tri"
!toSourceEnv <- evaluateFileWithContext sizeEnv "demos/toSource.tri"
diff --git a/demos/interactionTrees/arboricx-server.tri b/demos/interactionTrees/arboricx-server.tri
@@ -0,0 +1,21 @@
+!import "../../lib/io.tri" !Local
+!import "../../lib/arboricx/server.tri" !Local
+
+-- Arboricx HTTP registry server demo.
+-- Run with --allow-write ./store --allow-read ./store
+--
+-- Endpoints:
+-- GET /_arboricx/health -> "OK"
+-- POST /_arboricx/bundles -> upload bundle, returns hash
+-- GET /_arboricx/bundle/hash/:h -> download bundle by hash
+--
+-- Example usage:
+-- curl http://localhost:9050/_arboricx/health
+-- curl -X POST --data-binary @mybundle.arboricx http://localhost:9050/_arboricx/bundles
+-- curl http://localhost:9050/_arboricx/bundle/hash/<hash>
+
+main = io (thenIO
+ (putStrLn "Starting Arboricx server on 127.0.0.1:9050")
+ (thenIO
+ (void (ensureStore "/tmp/store"))
+ (arboricxServer "/tmp/store" "127.0.0.1" 9050)))
diff --git a/demos/interactionTrees/echo-server.tri b/demos/interactionTrees/echoServer.tri
diff --git a/demos/interactionTrees/httpServer.tri b/demos/interactionTrees/httpServer.tri
@@ -0,0 +1,16 @@
+!import "../lib/prelude.tri" !Local
+!import "../lib/io.tri" !Local
+!import "../lib/socket.tri" !Local
+!import "../lib/http.tri" !Local
+
+myRouter = (method path headers body :
+ matchBool
+ (okResponse (append "Hello from " (append path "\n")))
+ (methodNotAllowedResponse)
+ (strEq? method "GET"))
+
+main = io (
+ onOk_ socket (server :
+ onOk_ (bindSocket server "127.0.0.1" 9050) (_ :
+ onOk_ (listen server 5) (_ :
+ serveForever server (httpHandler myRouter)))))
diff --git a/demos/runArboricxBundle.tri b/demos/runArboricxBundle.tri
@@ -1,6 +1,6 @@
!import "../lib/prelude.tri" !Local
!import "../lib/io.tri" !Local
-!import "../lib/arboricx.tri" !Local
+!import "../lib/arboricx/arboricx.tri" !Local
-- Read an Arboricx bundle from disk and execute it.
-- This demo loads test/fixtures/id.arboricx and applies the
diff --git a/docs/self-hosted-arboricx-host.md b/docs/self-hosted-arboricx-host.md
@@ -327,7 +327,7 @@ err code rest
The error code is a Tree Calculus number. Error constants are defined in:
- `lib/binary.tri`
-- `lib/arboricx-common.tri`
+- `lib/arboricx/common.tri`
- `lib/arboricx.tri` for Host ABI codec errors, currently `errHostCodecFailed = 14`
Typed runners return `errHostCodecFailed` if the application result cannot be interpreted as the requested type.
diff --git a/flake.nix b/flake.nix
@@ -262,14 +262,8 @@
config = {
Cmd = [
"/bin/tricu"
- "server"
- "-h" "0.0.0.0"
- "-p" "8787"
];
WorkingDir = "/app";
- ExposedPorts = {
- "8787/tcp" = {};
- };
extraCommands = ''
'';
};
diff --git a/lib/arboricx-common.tri b/lib/arboricx-common.tri
@@ -1,432 +0,0 @@
-!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))
diff --git a/lib/arboricx-manifest.tri b/lib/arboricx-manifest.tri
@@ -1,343 +0,0 @@
-!import "arboricx-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)))))))))))))))
diff --git a/lib/arboricx-nodes.tri b/lib/arboricx-nodes.tri
@@ -1,208 +0,0 @@
-!import "arboricx-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 : byteEq? 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
diff --git a/lib/arboricx.tri b/lib/arboricx.tri
@@ -1,155 +0,0 @@
-!import "arboricx-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)
diff --git a/lib/arboricx/arboricx.tri b/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)
diff --git a/lib/arboricx/common.tri b/lib/arboricx/common.tri
@@ -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))
diff --git a/lib/arboricx-dispatch.tri b/lib/arboricx/dispatch.tri
diff --git a/lib/arboricx/manifest.tri b/lib/arboricx/manifest.tri
@@ -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)))))))))))))))
diff --git a/lib/arboricx/nodes.tri b/lib/arboricx/nodes.tri
@@ -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
diff --git a/lib/arboricx/server.tri b/lib/arboricx/server.tri
@@ -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)))
diff --git a/lib/base.tri b/lib/base.tri
@@ -121,6 +121,18 @@ maybe? = matchMaybe false (_ : true)
-- Basic arithmetic
-- ---------------------------------------------------------------------------
+ifLazy = (cond thenK elseK :
+ matchBool
+ (thenK t)
+ (elseK t)
+ cond)
+
+andLazy? = (a bK :
+ ifLazy
+ a
+ bK
+ (_ : false))
+
pred = y (self : triage
0
(_ : 0)
@@ -146,19 +158,35 @@ add = y (self x y :
x)
sub = y (self a b :
- matchBool
- a
- (self (pred a) (pred b))
- (isZero? b))
-
-lt? = a b : not? (isZero? (sub b a))
-lte? = a b : isZero? (sub a b)
+ ifLazy
+ (isZero? b)
+ (_ : a)
+ (_ : self (pred a) (pred b)))
+
+lte? = y (self a b :
+ ifLazy
+ (isZero? a)
+ (_ : true)
+ (_ :
+ ifLazy
+ (isZero? b)
+ (_ : false)
+ (_ : self (pred a) (pred b))))
+
+gte? = a b :
+ lte? b a
+
+lt? = a b :
+ and? (lte? a b) (not? (equal? a b))
+
+gt? = a b :
+ lt? b a
mul = y (self a b :
- matchBool
- 0
- (add a (self a (pred b)))
- (isZero? b))
+ ifLazy
+ (isZero? b)
+ (_ : 0)
+ (_ : add a (self a (pred b))))
-- ---------------------------------------------------------------------------
-- Result combinators
diff --git a/lib/binary.tri b/lib/binary.tri
@@ -38,7 +38,7 @@ expectBytes_ = y (self expected bs original :
matchBool
(self expectedRest rest original)
(err errUnexpectedBytes original)
- (byteEq? actual expectedByte))
+ (equal? actual expectedByte))
(readU8 bs))
expected)
@@ -51,7 +51,7 @@ expectU8 = (expected bs :
matchBool
(ok unit rest)
(err errUnexpectedByte bs)
- (byteEq? actual expected))
+ (equal? actual expected))
(readU8 bs))
read2 = (bs : readBytes 2 bs)
diff --git a/lib/bytes.tri b/lib/bytes.tri
@@ -7,7 +7,6 @@ bytesHead = matchList nothing (h _ : just h)
bytesTail = matchList nothing (_ r : just r)
-byteEq? = equal?
bytesLength = length
bytesAppend = append
bytesTake = take
diff --git a/lib/http.tri b/lib/http.tri
@@ -0,0 +1,755 @@
+!import "prelude.tri" !Local
+!import "io.tri" !Local
+!import "socket.tri" !Local
+
+-- ---------------------------------------------------------------------------
+-- 1. Constants
+-- ---------------------------------------------------------------------------
+
+maxHeaderBytes = 65536
+maxBodyBytes = 1048576
+maxUriBytes = 8192
+
+crlf = pair 13 (pair 10 t)
+crlfcrlf = pair 13 (pair 10 (pair 13 (pair 10 t)))
+
+-- ---------------------------------------------------------------------------
+-- 2. Lazy eliminators
+-- ---------------------------------------------------------------------------
+
+lazyBool = (thenK elseK cond :
+ ((chosen : chosen t)
+ (matchBool
+ thenK
+ elseK
+ cond)))
+
+lazyList = (nilK consK xs :
+ ((chosen : chosen t)
+ (matchList
+ nilK
+ (h r : (_ : consK h r))
+ xs)))
+
+lazyMaybe = (noneK someK m :
+ ((chosen : chosen t)
+ (matchMaybe
+ noneK
+ (x : (_ : someK x))
+ m)))
+
+lazyResult = (errK okK result :
+ ((chosen : chosen t)
+ (matchResult
+ (code rest : (_ : errK code rest))
+ (value rest : (_ : okK value rest))
+ result)))
+
+-- ---------------------------------------------------------------------------
+-- 3. Small byte/list helpers
+-- ---------------------------------------------------------------------------
+
+chomp = (xs :
+ lazyList
+ (_ : t)
+ (h r :
+ lazyBool
+ (_ : reverse r)
+ (_ : xs)
+ (equal? h 13))
+ (reverse xs))
+
+-- ---------------------------------------------------------------------------
+-- 4. Response construction
+-- ---------------------------------------------------------------------------
+
+statusPhrase = (code :
+ lazyBool
+ (_ : "OK")
+ (_ :
+ lazyBool
+ (_ : "Created")
+ (_ :
+ lazyBool
+ (_ : "No Content")
+ (_ :
+ lazyBool
+ (_ : "Bad Request")
+ (_ :
+ lazyBool
+ (_ : "Not Found")
+ (_ :
+ lazyBool
+ (_ : "Method Not Allowed")
+ (_ :
+ lazyBool
+ (_ : "Request Header Fields Too Large")
+ (_ :
+ lazyBool
+ (_ : "Not Implemented")
+ (_ :
+ lazyBool
+ (_ : "HTTP Version Not Supported")
+ (_ : "Internal Server Error")
+ (equal? code 505))
+ (equal? code 501))
+ (equal? code 431))
+ (equal? code 405))
+ (equal? code 404))
+ (equal? code 400))
+ (equal? code 204))
+ (equal? code 201))
+ (equal? code 200))
+
+statusLine = (code phrase :
+ append "HTTP/1.1 " (append (showNumber code) (append " " (append phrase "\r\n"))))
+
+headerLine = (key value :
+ append key (append ": " (append value "\r\n")))
+
+buildResponse = (status headers body :
+ append
+ (statusLine status (statusPhrase status))
+ (append
+ (foldl (acc h : append acc (headerLine (fst h) (snd h))) "" headers)
+ (append "\r\n" body)))
+
+response = (status contentType body :
+ buildResponse status
+ [(pair "Content-Type" contentType)
+ (pair "Content-Length" (showNumber (length body)))
+ (pair "Connection" "close")]
+ body)
+
+emptyResponse = (status :
+ buildResponse status
+ [(pair "Content-Length" "0")
+ (pair "Connection" "close")]
+ "")
+
+okResponse = (body :
+ response 200 "text/plain; charset=utf-8" body)
+
+textResponse = (body :
+ response 200 "text/plain; charset=utf-8" body)
+
+jsonResponse = (body :
+ response 200 "application/json" body)
+
+createdResponse = (body :
+ response 201 "text/plain; charset=utf-8" body)
+
+notFoundResponse = (
+ response 404 "text/plain; charset=utf-8" "Not found\n")
+
+badRequestResponse = (msg :
+ response 400 "text/plain; charset=utf-8" msg)
+
+errorResponse = (status msg :
+ response status "text/plain; charset=utf-8" msg)
+
+headersOnly_ = (y (self bs s1 s2 s3 acc :
+ lazyList
+ (_ : reverse acc)
+ (h r :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : reverse (pair 10 (pair 13 (pair 10 (pair 13 acc)))))
+ (_ : self r true false false (pair h acc))
+ (equal? h 10))
+ (_ : self r false false false (pair h acc))
+ s3)
+ (_ : self r false true false (pair h acc))
+ (and? s2 (equal? h 13)))
+ (_ :
+ lazyBool
+ (_ : self r false false true (pair h acc))
+ (_ : self r false false false (pair h acc))
+ (and? s1 (equal? h 10)))
+ (equal? h 13))
+ bs))
+
+headersOnly = (response :
+ headersOnly_ response false false false t)
+
+responseForMethod = (method resp :
+ lazyBool
+ (_ : headersOnly resp)
+ (_ : resp)
+ (equal? method "HEAD"))
+
+-- ---------------------------------------------------------------------------
+-- 5. Header receive / framing
+-- ---------------------------------------------------------------------------
+
+recvUntilMax_ = (y (self sock pattern maxBytes acc accLen :
+ onResult_ (recv sock 4096)
+ (err :
+ pure (err 400 acc))
+ (chunk :
+ lazyBool
+ (_ : pure (err 400 acc))
+ (_ :
+ ((chunkLen :
+ ((nextLen :
+ ((next :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : pure (ok next t))
+ (_ : self sock pattern maxBytes next nextLen)
+ (contains? pattern next))
+ (_ : pure (err 431 next))
+ (lte? nextLen maxBytes))
+ (append acc chunk)))
+ (add accLen chunkLen)))
+ (length chunk)))
+ (emptyList? chunk))))
+
+recvUntilMax = (sock pattern maxBytes :
+ recvUntilMax_ sock pattern maxBytes t 0)
+
+recvUntil = (sock pattern :
+ recvUntilMax sock pattern maxHeaderBytes)
+
+recvHeaders = (sock :
+ recvUntilMax sock crlfcrlf maxHeaderBytes)
+
+-- ---------------------------------------------------------------------------
+-- 6. Request line parsing
+-- ---------------------------------------------------------------------------
+
+readLineBytes_ = (y (self bs acc :
+ lazyList
+ (_ : pair (reverse acc) t)
+ (h r :
+ lazyBool
+ (_ : pair (reverse acc) r)
+ (_ :
+ lazyBool
+ (_ : self r acc)
+ (_ : self r (pair h acc))
+ (equal? h 13))
+ (equal? h 10))
+ bs))
+
+readLineBytes = (bs :
+ ((result :
+ pair (chomp (fst result)) (snd result))
+ (readLineBytes_ bs t)))
+
+parseThreeWords_ = (y (self bs phase acc w1 w2 :
+ lazyList
+ (_ :
+ lazyBool
+ (_ : ok (pair w1 (pair w2 (reverse acc))) t)
+ (_ : err 400 "Bad Request\n")
+ (equal? phase 2))
+ (h r :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : self r 1 t (reverse acc) w2)
+ (_ :
+ lazyBool
+ (_ : self r 2 t w1 (reverse acc))
+ (_ : err 400 "Bad Request\n")
+ (equal? phase 1))
+ (equal? phase 0))
+ (_ : self r phase (pair h acc) w1 w2)
+ (equal? h 32))
+ bs))
+
+parseThreeWords = (bs :
+ parseThreeWords_ bs 0 t t t)
+
+parseRequestLine = (bs :
+ ((lineRest :
+ lazyResult
+ (code bad : err 400 "Bad Request\n")
+ (req ignored : ok req (snd lineRest))
+ (parseThreeWords (fst lineRest)))
+ (readLineBytes bs)))
+
+-- ---------------------------------------------------------------------------
+-- 7. Header parsing
+-- ---------------------------------------------------------------------------
+
+
+-- ASCII byte helpers below are structural on the Tree Calculus numeral
+-- spine. Do not replace them with lte?/sub based checks: these names are
+-- normalized at import time under abstract byte inputs.
+boolNot? = (b :
+ matchBool false true b)
+
+boolOr? = (a b :
+ matchBool true b a)
+
+boolAnd? = (a b :
+ matchBool b false a)
+
+low5NonZero? = (b0 b1 b2 b3 b4 :
+ boolOr?
+ (bit1? b0)
+ (boolOr?
+ (bit1? b1)
+ (boolOr?
+ (bit1? b2)
+ (boolOr?
+ (bit1? b3)
+ (bit1? b4)))))
+
+low5TooHighForUpper? = (b0 b1 b2 b3 b4 :
+ boolAnd?
+ (bit1? b4)
+ (boolAnd?
+ (bit1? b3)
+ (boolOr?
+ (bit1? b2)
+ (boolAnd?
+ (bit1? b1)
+ (bit1? b0)))))
+
+upperLow5? = (b0 b1 b2 b3 b4 :
+ boolAnd?
+ (low5NonZero? b0 b1 b2 b3 b4)
+ (boolNot?
+ (low5TooHighForUpper? b0 b1 b2 b3 b4)))
+
+lowerAsciiBits = (b0 b1 b2 b3 b4 :
+ pair b0
+ (pair b1
+ (pair b2
+ (pair b3
+ (pair b4
+ (pair true
+ (pair true 0)))))))
+
+toLowerAsciiByte = (c :
+ triage
+ c
+ (_ : c)
+ (b0 r0 :
+ triage
+ c
+ (_ : c)
+ (b1 r1 :
+ triage
+ c
+ (_ : c)
+ (b2 r2 :
+ triage
+ c
+ (_ : c)
+ (b3 r3 :
+ triage
+ c
+ (_ : c)
+ (b4 r4 :
+ triage
+ c
+ (_ : c)
+ (b5 r5 :
+ triage
+ c
+ (_ : c)
+ (b6 r6 :
+ matchBool
+ (lowerAsciiBits b0 b1 b2 b3 b4)
+ c
+ (boolAnd?
+ (isZero? r6)
+ (boolAnd?
+ (bit1? b6)
+ (boolAnd?
+ (bit0? b5)
+ (upperLow5? b0 b1 b2 b3 b4)))))
+ r5)
+ r4)
+ r3)
+ r2)
+ r1)
+ r0)
+ c)
+
+finishHeaderLine = (self r headers key value seenColon :
+ matchBool
+ (matchBool
+ (err 400 "Bad Request\n")
+ (ok (reverse headers) r)
+ seenColon)
+ (matchBool
+ (self r
+ (pair (pair (reverse key) (reverse value)) headers)
+ t
+ t
+ false
+ true)
+ (err 400 "Bad Request\n")
+ seenColon)
+ (emptyList? key))
+
+finishHeaderEOF = (headers key value seenColon :
+ matchBool
+ (ok (reverse headers) t)
+ (matchBool
+ (ok (reverse (pair (pair (reverse key) (reverse value)) headers)) t)
+ (err 400 "Bad Request\n")
+ seenColon)
+ (emptyList? key))
+
+parseHeaders_ = (self bs headers key value seenColon trimValue :
+ matchList
+ (finishHeaderEOF headers key value seenColon)
+ (h r :
+ matchBool
+ (finishHeaderLine self r headers key value seenColon)
+ (matchBool
+ (self r headers key value seenColon trimValue)
+ (matchBool
+ (matchBool
+ (self r headers key value true true)
+ (self r headers key (pair h value) true false)
+ (boolAnd? trimValue (equal? h 32)))
+ (matchBool
+ (self r headers key value true true)
+ (self r headers (pair (toLowerAsciiByte h) key) value false true)
+ (equal? h 58))
+ seenColon)
+ (equal? h 13))
+ (equal? h 10))
+ bs)
+
+parseHeaders = (bs :
+ y parseHeaders_ bs t t t false true)
+
+-- ---------------------------------------------------------------------------
+-- 8. Content-Length parsing
+-- ---------------------------------------------------------------------------
+
+bit0? = (x :
+ isZero? x)
+
+bit1? = (x :
+ triage
+ false
+ (a : isZero? a)
+ (_ _ : false)
+ x)
+
+low3 = (b0 b1 b2 :
+ matchBool
+ (matchBool
+ (matchBool 7 6 (bit1? b0))
+ (matchBool 5 4 (bit1? b0))
+ (bit1? b1))
+ (matchBool
+ (matchBool 3 2 (bit1? b0))
+ (matchBool 1 0 (bit1? b0))
+ (bit1? b1))
+ (bit1? b2))
+
+decimalDigit = (c :
+ triage
+ nothing
+ (_ : nothing)
+ (b0 r0 :
+ triage
+ nothing
+ (_ : nothing)
+ (b1 r1 :
+ triage
+ nothing
+ (_ : nothing)
+ (b2 r2 :
+ triage
+ nothing
+ (_ : nothing)
+ (b3 r3 :
+ triage
+ nothing
+ (_ : nothing)
+ (b4 r4 :
+ triage
+ nothing
+ (_ : nothing)
+ (b5 r5 :
+ matchBool
+ (matchBool
+ (matchBool
+ (matchBool
+ (matchBool
+ (just (low3 b0 b1 b2))
+ (matchBool
+ (matchBool
+ (just (matchBool 9 8 (bit1? b0)))
+ nothing
+ (bit0? b2))
+ nothing
+ (bit0? b1))
+ (bit0? b3))
+ nothing
+ (bit1? b5))
+ nothing
+ (bit1? b4))
+ nothing
+ (isZero? r5))
+ nothing
+ true)
+ r4)
+ r3)
+ r2)
+ r1)
+ r0)
+ c)
+
+readDecimal_ = (self bytes acc :
+ matchList
+ (just acc)
+ (h r :
+ matchMaybe
+ nothing
+ (d : self r (add (mul acc 10) d))
+ (decimalDigit h))
+ bytes)
+
+readDecimal = (bytes :
+ matchBool
+ nothing
+ (y readDecimal_ bytes 0)
+ (emptyList? bytes))
+
+parseContentLengthValue = (raw :
+ matchMaybe
+ (err 400 "Bad Request\n")
+ (n : ok (just n) t)
+ (readDecimal raw))
+
+contentLength_ = (self headers :
+ matchList
+ (ok nothing t)
+ (h r :
+ matchBool
+ (parseContentLengthValue (snd h))
+ (self r)
+ (equal? "content-length" (fst h)))
+ headers)
+
+contentLength = (headers :
+ y contentLength_ headers)
+
+-- ---------------------------------------------------------------------------
+-- 9. Body reading
+-- ---------------------------------------------------------------------------
+
+consumeAvailable_ = (y (self bytes remaining acc :
+ lazyList
+ (_ : pair (reverse acc) (pair remaining t))
+ (h r :
+ lazyBool
+ (_ : pair (reverse acc) (pair 0 r))
+ (_ : self r (pred remaining) (pair h acc))
+ (isZero? remaining))
+ bytes))
+
+consumeAvailable = (bytes n :
+ consumeAvailable_ bytes n t)
+
+readBodyN_ = (y (self sock remaining acc :
+ lazyBool
+ (_ : pure (ok acc t))
+ (_ :
+ onResult_ (recv sock remaining)
+ (err :
+ pure (err 400 acc))
+ (chunk :
+ ((got :
+ lazyBool
+ (_ : pure (err 400 acc))
+ (_ : self sock (sub remaining got) (append acc chunk))
+ (equal? got 0))
+ (length chunk))))
+ (isZero? remaining)))
+
+readBodyN = (sock n acc :
+ readBodyN_ sock n acc)
+
+readBody = (sock headers initialBytes :
+ matchResult
+ (status msg :
+ pure (err status "Bad Request\n"))
+ (maybeLen rest :
+ lazyMaybe
+ (_ : pure (ok t initialBytes))
+ (n :
+ ((consumed :
+ ((body0 :
+ ((remaining :
+ lazyBool
+ (_ : pure (ok body0 t))
+ (_ :
+ onOk (readBodyN sock remaining body0)
+ (body rest : pure (ok body t)))
+ (isZero? remaining))
+ (fst (snd consumed))))
+ (fst consumed)))
+ (consumeAvailable initialBytes n)))
+ maybeLen)
+ (contentLength headers))
+
+-- ---------------------------------------------------------------------------
+-- 10. Request validation
+-- ---------------------------------------------------------------------------
+
+validMethod? = (method :
+ lazyBool
+ (_ : true)
+ (_ :
+ lazyBool
+ (_ : true)
+ (_ :
+ lazyBool
+ (_ : true)
+ (_ : false)
+ (equal? method "HEAD"))
+ (equal? method "POST"))
+ (equal? method "GET"))
+
+validVersion? = (version :
+ lazyBool
+ (_ : true)
+ (_ : equal? version "HTTP/1.0")
+ (equal? version "HTTP/1.1"))
+
+validTarget? = (target :
+ startsWith? "/" target)
+
+validateRequest = (method target version headers :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ :
+ lazyBool
+ (_ : ok t t)
+ (_ : err 400 "Bad Request\n")
+ (validTarget? target))
+ (_ : err 505 "HTTP Version Not Supported\n")
+ (validVersion? version))
+ (_ : err 400 "Bad Request\n")
+ (validMethod? method))
+
+-- ---------------------------------------------------------------------------
+-- 11. Handler pipeline
+-- ---------------------------------------------------------------------------
+
+routerMethod = (method :
+ lazyBool
+ (_ : "GET")
+ (_ : method)
+ (equal? method "HEAD"))
+
+respondAndClose = (sock resp :
+ onOk_ (finally (send sock resp) (closeSocket_ sock)) (_ :
+ pure (ok t t)))
+
+handleReadableRequest = (router client method target headers rest3 :
+ onResult_ (readBody client headers rest3)
+ (status :
+ respondAndClose client
+ (responseForMethod method
+ (badRequestResponse "Bad Request\n")))
+ (body :
+ respondAndClose client
+ (responseForMethod method
+ (router (routerMethod method) target headers body))))
+
+handleParsedHeaders = (router client method target version rest2 :
+ matchResult
+ (code bad :
+ respondAndClose client (badRequestResponse "Bad Request\n"))
+ (headers rest3 :
+ matchResult
+ (status msg :
+ respondAndClose client
+ (responseForMethod method (errorResponse status msg)))
+ (ignored rest :
+ handleReadableRequest router client method target headers rest3)
+ (validateRequest method target version headers))
+ (parseHeaders rest2))
+
+handleParsedRequest = (router client req rest2 :
+ ((method :
+ ((target :
+ ((version :
+ handleParsedHeaders router client method target version rest2)
+ (snd (snd req))))
+ (fst (snd req))))
+ (fst req)))
+
+httpHandler = (router client peer :
+ onResult_ (recvHeaders client)
+ (status :
+ respondAndClose client
+ (badRequestResponse "Bad Request\n"))
+ (raw :
+ matchResult
+ (code bad :
+ respondAndClose client (badRequestResponse "Bad Request\n"))
+ (req rest2 :
+ handleParsedRequest router client req rest2)
+ (parseRequestLine raw)))
+
+-- ---------------------------------------------------------------------------
+-- 12. IO-aware handler pipeline
+-- ---------------------------------------------------------------------------
+
+handleReadableRequestIO = (routerIO client method target headers rest3 :
+ onResult_ (readBody client headers rest3)
+ (status :
+ respondAndClose client
+ (responseForMethod method
+ (badRequestResponse "Bad Request\n")))
+ (body :
+ bind (routerIO (routerMethod method) target headers body) (resp :
+ respondAndClose client (responseForMethod method resp))))
+
+handleParsedHeadersIO = (routerIO client method target version rest2 :
+ matchResult
+ (code bad :
+ respondAndClose client (badRequestResponse "Bad Request\n"))
+ (headers rest3 :
+ matchResult
+ (status msg :
+ respondAndClose client
+ (responseForMethod method (errorResponse status msg)))
+ (ignored rest :
+ handleReadableRequestIO routerIO client method target headers rest3)
+ (validateRequest method target version headers))
+ (parseHeaders rest2))
+
+handleParsedRequestIO = (routerIO client req rest2 :
+ ((method :
+ ((target :
+ ((version :
+ handleParsedHeadersIO routerIO client method target version rest2)
+ (snd (snd req))))
+ (fst (snd req))))
+ (fst req)))
+
+httpHandlerIO = (routerIO client peer :
+ onResult_ (recvHeaders client)
+ (status :
+ respondAndClose client
+ (badRequestResponse "Bad Request\n"))
+ (raw :
+ matchResult
+ (code bad :
+ respondAndClose client (badRequestResponse "Bad Request\n"))
+ (req rest2 :
+ handleParsedRequestIO routerIO client req rest2)
+ (parseRequestLine raw)))
diff --git a/lib/io.tri b/lib/io.tri
@@ -20,6 +20,15 @@ writeFile = p c : pair 21 (pair p c)
putBytes = bs : pair 12 bs
writeBytes = p c : pair 22 (pair p c)
+listDirectory = p : pair 23 p
+renameFile = old new : pair 24 (pair old new)
+createDirectory = p : pair 25 p
+deleteFile = p : pair 26 p
+fileExists = p : pair 27 p
+
+sha256Hex = bs : pair 28 bs
+currentTime = pair 29 t
+
ask = pair 30 t
local = f action : pair 31 (pair f action)
@@ -102,6 +111,14 @@ onReadFile = path : onResult (readFile path)
onWriteFile = path contents : onResult (writeFile path contents)
+onListDirectory = path : onResult (listDirectory path)
+onRenameFile = old new : onResult (renameFile old new)
+onCreateDirectory = path : onResult (createDirectory path)
+onDeleteFile = path : onResult (deleteFile path)
+onFileExists = path : onResult (fileExists path)
+onSha256Hex = bs : onResult (sha256Hex bs)
+onCurrentTime = onResult currentTime
+
-- ---------------------------------------------------------------------------
-- Convenience helpers for the common cases
-- ---------------------------------------------------------------------------
diff --git a/lib/list.tri b/lib/list.tri
@@ -162,19 +162,22 @@ strAppend = append
strEq? = equal?
strEmpty? = emptyList?
-startsWith? = y (self prefix str :
- matchList
- true
- (ph pr :
+startsWith? = (prefix input :
+ ((go :
+ go prefix input)
+ (y (self p s :
matchList
- false
- (sh sr :
- matchBool
- (self pr sr)
+ true
+ (ph pr :
+ matchList
false
- (equal? ph sh))
- str)
- prefix)
+ (sh sr :
+ matchBool
+ (self pr sr)
+ false
+ (equal? ph sh))
+ s)
+ p))))
endsWith? = prefix str : startsWith? (reverse prefix) (reverse str)
diff --git a/lib/socket.tri b/lib/socket.tri
@@ -2,9 +2,8 @@
!import "io.tri" !Local
-- Socket primitives for the IO driver.
--- All actions return a Result tree (see lib/base.tri):
--- ok value -- pair true (pair value t)
--- err msg -- pair false (pair msg t)
+-- ok value t -- pair true (pair value t)
+-- err msg t -- pair false (pair msg t)
socket = pair 70 t
closeSocket = sock : pair 71 sock
@@ -16,7 +15,7 @@ recv = sock maxBytes : pair 76 (pair sock maxBytes)
send = sock bytes : pair 77 (pair sock bytes)
getSocketName = sock : pair 78 sock
--- Result-aware wrappers over raw socket actions.
+-- Result-aware wrappers over raw socket actions
onSocket = onResult socket
onBindSocket = sock addr port : onResult (bindSocket sock addr port)
onListen = sock backlog : onResult (listen sock backlog)
@@ -26,15 +25,15 @@ onRecv = sock maxBytes : onResult (recv sock maxBytes)
onSend = sock bytes : onResult (send sock bytes)
onGetSocketName = sock : onResult (getSocketName sock)
--- Result-aware wrappers that drop the useless 'rest' parameter.
-onSocket_ = onResult_ socket
-onBindSocket_ = sock addr port : onResult_ (bindSocket sock addr port)
-onListen_ = sock backlog : onResult_ (listen sock backlog)
-onAccept_ = sock : onResult_ (accept sock)
-onConnect_ = sock addr port : onResult_ (connect sock addr port)
-onRecv_ = sock maxBytes : onResult_ (recv sock maxBytes)
-onSend_ = sock bytes : onResult_ (send sock bytes)
-onGetSocketName_ = sock : onResult_ (getSocketName sock)
+-- Result-aware wrappers that drop the 'rest' parameter
+onSocket_ = onResult_ socket
+onBindSocket_ = sock addr port : onResult_ (bindSocket sock addr port)
+onListen_ = sock backlog : onResult_ (listen sock backlog)
+onAccept_ = sock : onResult_ (accept sock)
+onConnect_ = sock addr port : onResult_ (connect sock addr port)
+onRecv_ = sock maxBytes : onResult_ (recv sock maxBytes)
+onSend_ = sock bytes : onResult_ (send sock bytes)
+onGetSocketName_ = sock : onResult_ (getSocketName sock)
-- Close a socket, ignoring errors.
closeSocket_ = sock : void (closeSocket sock)
@@ -45,7 +44,7 @@ listenSocket = addr port backlog :
onOk_ socket (server :
onOk_ (bindSocket server addr port) (_ :
onOk_ (listen server backlog) (_ :
- pure (ok server))))
+ pure (ok server t))))
-- Accept a connection with explicit error and ok branches.
-- okHandler receives (clientSocket, peerAddr).
diff --git a/src/IODriver.hs b/src/IODriver.hs
@@ -8,15 +8,22 @@ module IODriver
, runIOWith
) where
-import Research (T(..), apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes)
+import Research (T(..), apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes, ofList)
import qualified Data.ByteString as BS
import System.IO (putStr, getLine)
import qualified System.IO as IO
import Control.Exception (try, catch, IOException, SomeException)
import System.IO.Error (isDoesNotExistError, isPermissionError, isAlreadyExistsError)
-import Data.List (isPrefixOf)
-import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories)
-import System.Directory (canonicalizePath, doesPathExist, getCurrentDirectory)
+import Data.List (isPrefixOf, isInfixOf)
+import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories, takeDirectory)
+import System.Directory (canonicalizePath, doesPathExist, getCurrentDirectory, listDirectory, createDirectory, renameFile, removeFile, doesDirectoryExist)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Crypto.Hash (hash, SHA256, Digest)
+import Data.ByteArray (convert)
+import Data.ByteString.Base16 (encode)
+import Data.Text.Encoding (decodeUtf8)
+import qualified Data.Text as T
+import Data.Char (toLower)
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import qualified Data.Sequence as Seq
@@ -202,6 +209,13 @@ data Action
| AReadFile T
| AWriteFile T T
| AWriteBytes T T
+ | AListDirectory T
+ | ARenameFile T T
+ | ACreateDirectory T
+ | ADeleteFile T
+ | AFileExists T
+ | ASha256Hex T
+ | ACurrentTime
| AAsk
| ALocal T T
| AGet
@@ -239,6 +253,17 @@ tagReadFile = 20
tagWriteFile = 21
tagWriteBytes = 22
+tagListDirectory, tagRenameFile, tagCreateDirectory, tagDeleteFile, tagFileExists :: Integer
+tagListDirectory = 23
+tagRenameFile = 24
+tagCreateDirectory = 25
+tagDeleteFile = 26
+tagFileExists = 27
+
+tagSha256Hex, tagCurrentTime :: Integer
+tagSha256Hex = 28
+tagCurrentTime = 29
+
tagAsk, tagLocal :: Integer
tagAsk = 30
tagLocal = 31
@@ -319,6 +344,29 @@ decodeAction tree =
Fork path contents -> Right (AWriteBytes path contents)
_ -> Left "Invalid WriteBytes: expected pair path contents"
+ Right n | n == tagListDirectory ->
+ Right (AListDirectory payload)
+
+ Right n | n == tagRenameFile ->
+ case payload of
+ Fork old new -> Right (ARenameFile old new)
+ _ -> Left "Invalid RenameFile: expected pair oldPath newPath"
+
+ Right n | n == tagCreateDirectory ->
+ Right (ACreateDirectory payload)
+
+ Right n | n == tagDeleteFile ->
+ Right (ADeleteFile payload)
+
+ Right n | n == tagFileExists ->
+ Right (AFileExists payload)
+
+ Right n | n == tagSha256Hex ->
+ Right (ASha256Hex payload)
+
+ Right n | n == tagCurrentTime ->
+ Right ACurrentTime
+
Right n | n == tagAsk ->
Right AAsk
@@ -481,6 +529,64 @@ stepMachine sockVar machine =
Left _ -> finishValue machine (errResult "invalid bytes")
Left _ -> finishValue machine (errResult "invalid string")
+ AListDirectory pathTree ->
+ case decodeString pathTree "ListDirectory" of
+ Right p -> do
+ mDeny <- checkReadPerm p
+ case mDeny of
+ Just denied -> finishValue machine denied
+ Nothing -> pure (AsyncAction (tryListDirectory p) machine)
+ Left _ -> finishValue machine (errResult "invalid string")
+
+ ARenameFile oldTree newTree ->
+ case decodeString oldTree "RenameFile" of
+ Right old ->
+ case decodeString newTree "RenameFile" of
+ Right new -> do
+ mDenyOld <- checkWritePerm old
+ mDenyNew <- checkWritePerm new
+ case (mDenyOld, mDenyNew) of
+ (Just denied, _) -> finishValue machine denied
+ (_, Just denied) -> finishValue machine denied
+ (Nothing, Nothing) -> pure (AsyncAction (tryRenameFile old new) machine)
+ Left _ -> finishValue machine (errResult "invalid string")
+ Left _ -> finishValue machine (errResult "invalid string")
+
+ ACreateDirectory pathTree ->
+ case decodeString pathTree "CreateDirectory" of
+ Right p -> do
+ mDeny <- checkWritePerm p
+ case mDeny of
+ Just denied -> finishValue machine denied
+ Nothing -> pure (AsyncAction (tryCreateDirectory p) machine)
+ Left _ -> finishValue machine (errResult "invalid string")
+
+ ADeleteFile pathTree ->
+ case decodeString pathTree "DeleteFile" of
+ Right p -> do
+ mDeny <- checkWritePerm p
+ case mDeny of
+ Just denied -> finishValue machine denied
+ Nothing -> pure (AsyncAction (tryDeleteFile p) machine)
+ Left _ -> finishValue machine (errResult "invalid string")
+
+ AFileExists pathTree ->
+ case decodeString pathTree "FileExists" of
+ Right p -> do
+ mDeny <- checkReadPerm p
+ case mDeny of
+ Just denied -> finishValue machine denied
+ Nothing -> pure (AsyncAction (tryFileExists p) machine)
+ Left _ -> finishValue machine (errResult "invalid string")
+
+ ASha256Hex bytesTree ->
+ case decodeBytes bytesTree "Sha256Hex" of
+ Right bs -> pure (AsyncAction (pure $ trySha256Hex bs) machine)
+ Left _ -> finishValue machine (errResult "invalid bytes")
+
+ ACurrentTime ->
+ pure (AsyncAction (tryCurrentTime) machine)
+
AAsk ->
finishValue machine (rtEnv (machineRuntime machine))
@@ -818,6 +924,107 @@ stepMachine sockVar machine =
Right () -> return $ okResult Leaf
Left e -> return $ errResult (ioErrorString e)
+ tryListDirectory path = do
+ exists <- doesPathExist path
+ if not exists
+ then return $ errResult "does not exist"
+ else do
+ isDir <- doesDirectoryExist path
+ if not isDir
+ then return $ errResult "not a directory"
+ else do
+ result <- try (listDirectory path) :: IO (Either IOException [FilePath])
+ case result of
+ Right entries ->
+ let filtered = filter (`notElem` [".", ".."]) entries
+ in return $ okResult (ofList (map ofString filtered))
+ Left e -> return $ errResult (ioErrorString e)
+
+ tryRenameFile old new = do
+ oldExists <- doesPathExist old
+ if not oldExists
+ then return $ errResult "does not exist"
+ else do
+ result <- try (renameFile old new) :: IO (Either IOException ())
+ case result of
+ Right () -> return $ okResult Leaf
+ Left e
+ | isDoesNotExistError e -> return $ errResult "does not exist"
+ | isPermissionError e -> return $ errResult "permission denied"
+ | "cross-device" `isInfixOf` map toLower (show e) || "exdev" `isInfixOf` map toLower (show e) ->
+ return $ errResult "cross-device rename"
+ | otherwise -> return $ errResult (ioErrorString e)
+
+ tryCreateDirectory path = do
+ exists <- doesPathExist path
+ if exists
+ then do
+ isDir <- doesDirectoryExist path
+ if isDir
+ then return $ okResult Leaf
+ else return $ errResult "already exists"
+ else do
+ let parent = takeDirectory path
+ parentExists <- doesPathExist parent
+ if parentExists
+ then do
+ parentIsDir <- doesDirectoryExist parent
+ if parentIsDir
+ then do
+ result <- try (createDirectory path) :: IO (Either IOException ())
+ case result of
+ Right () -> return $ okResult Leaf
+ Left e
+ | isDoesNotExistError e -> return $ errResult "does not exist"
+ | isPermissionError e -> return $ errResult "permission denied"
+ | isAlreadyExistsError e -> return $ errResult "already exists"
+ | otherwise -> return $ errResult (ioErrorString e)
+ else return $ errResult "not a directory"
+ else do
+ result <- try (createDirectory path) :: IO (Either IOException ())
+ case result of
+ Right () -> return $ okResult Leaf
+ Left e
+ | isDoesNotExistError e -> return $ errResult "does not exist"
+ | isPermissionError e -> return $ errResult "permission denied"
+ | isAlreadyExistsError e -> return $ errResult "already exists"
+ | otherwise -> return $ errResult (ioErrorString e)
+
+ tryDeleteFile path = do
+ exists <- doesPathExist path
+ if not exists
+ then return $ okResult Leaf
+ else do
+ isDir <- doesDirectoryExist path
+ if isDir
+ then return $ errResult "is a directory"
+ else do
+ result <- try (removeFile path) :: IO (Either IOException ())
+ case result of
+ Right () -> return $ okResult Leaf
+ Left e
+ | isDoesNotExistError e -> return $ okResult Leaf
+ | isPermissionError e -> return $ errResult "permission denied"
+ | otherwise -> return $ errResult (ioErrorString e)
+
+ tryFileExists path = do
+ result <- try (doesPathExist path) :: IO (Either IOException Bool)
+ case result of
+ Right exists -> return $ okResult (if exists then Stem Leaf else Leaf)
+ Left e
+ | isPermissionError e -> return $ errResult "permission denied"
+ | otherwise -> return $ errResult (ioErrorString e)
+
+ trySha256Hex bs =
+ let digest = hash bs :: Digest SHA256
+ hexBs = encode (convert digest)
+ hexStr = T.unpack (decodeUtf8 hexBs)
+ in okResult (ofString hexStr)
+
+ tryCurrentTime = do
+ now <- getPOSIXTime
+ return $ okResult (ofNumber (floor now))
+
decodeString t ctx =
case toString t of
Right s -> Right s
diff --git a/src/Main.hs b/src/Main.hs
@@ -2,7 +2,6 @@ module Main where
import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget)
import System.Exit (die)
-import Server (runServerWithPath)
import Eval (evalTricu, evalTricuWithStore, mainResult, result)
import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
import IODriver (IOPermissions(..), runIO)
@@ -61,11 +60,6 @@ data TricuArgs
, exportDb :: Maybe FilePath
, dag :: Bool
}
- | ArboricxServe
- { serveHost :: String
- , servePort :: Int
- , serveDb :: Maybe FilePath
- }
deriving (Show)
-- ---------------------------------------------------------------------------
@@ -209,28 +203,6 @@ exportParser = ArboricxExport
<> help "Export as a topologically-sorted DAG node table instead of a bundle"
)
-serveParser :: Parser TricuArgs
-serveParser = ArboricxServe
- <$> option str
- ( long "host"
- <> metavar "HOST"
- <> value "127.0.0.1"
- <> help "Host to bind the server to"
- )
- <*> option auto
- ( long "port"
- <> short 'p'
- <> metavar "PORT"
- <> value 8787
- <> help "HTTP port to listen on"
- )
- <*> optional (option str
- ( long "db"
- <> short 'd'
- <> metavar "PATH"
- <> help "Content store database path"
- ))
-
versionStr :: String
versionStr = "tricu " ++ showVersion version
@@ -253,8 +225,6 @@ arboricxParser = subparser $ mconcat
(progDesc "Import an Arboricx bundle into the content store"))
, command "export" (info (exportParser <**> helper)
(progDesc "Export one or more terms from the content store"))
- , command "serve" (info (serveParser <**> helper)
- (progDesc "Start a read-only HTTP server for Arboricx bundles"))
]
-- ---------------------------------------------------------------------------
@@ -274,7 +244,7 @@ main = do
ArboricxCompile {} -> runCompile args
ArboricxImport {} -> runImport args
ArboricxExport {} -> runExport args
- ArboricxServe {} -> runServe args
+
-- ---------------------------------------------------------------------------
-- Command runners
@@ -395,16 +365,6 @@ runExportDag opts = do
[] -> die "tricu arboricx export --dag: exactly one --target is required"
_ -> die "tricu arboricx export --dag: exactly one --target is required"
-runServe :: TricuArgs -> IO ()
-runServe opts = do
- let hostStr = serveHost opts
- portNum = servePort opts
- putStrLn $ "Starting Arboricx bundle server on " ++ hostStr ++ ":" ++ show portNum
- putStrLn $ " GET /bundle/hash/:hash -- primary endpoint"
- putStrLn $ " GET /bundle/name/:name -- convenience endpoint"
- putStrLn $ " Content-Type: application/vnd.arboricx.bundle"
- runServerWithPath (serveDb opts) hostStr portNum
-
-- ---------------------------------------------------------------------------
-- Helpers
-- ---------------------------------------------------------------------------
diff --git a/src/Server.hs b/src/Server.hs
@@ -1,210 +0,0 @@
-module Server
- ( runServer
- , runServerWithPath
- ) where
-
-import ContentStore (initContentStore, initContentStoreWithPath, nameToTerm, hashToTerm, listStoredTerms,
- parseNameList, StoredTerm(..), termHash, loadTree)
-import Database.SQLite.Simple (Connection, close)
-import Wire (buildBundle, encodeBundle)
-
-import Control.Monad (when, void)
-import Data.Maybe (catMaybes)
-
-import Network.HTTP.Types (Header, Status, status200, status400, status404, status405, hContentType)
-import Network.Wai
-import Network.Wai.Handler.Warp (defaultSettings, runSettings, setHost, setPort)
-
-import Data.String (fromString)
-import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8)
-import Data.Char (isHexDigit, toLower)
-import Data.ByteString (ByteString)
-import Data.ByteString.Char8 (unpack)
-import Data.ByteString.Lazy (fromStrict)
-import qualified Data.Text as T
-
--- | Start an HTTP server that serves Arboricx bundles from the
--- local content store.
-runServer :: String -> Int -> IO ()
-runServer = runServerWithPath Nothing
-
--- | Start an HTTP server with an explicit database path.
-runServerWithPath :: Maybe FilePath -> String -> Int -> IO ()
-runServerWithPath mDbPath hostStr port =
- runSettings settings (app mkConn)
- where
- mkConn = initContentStoreWithPath mDbPath
- settings = setPort port $ setHost (fromString hostStr) defaultSettings
-
--- | WAI application backed by the content store.
-app :: IO Connection -> Application
-app mkConn request respond = case (requestMethod request, pathInfo request) of
- ("GET", ["health"]) ->
- respond $ healthResponse
-
- ("GET", ["bundle", "roots"]) ->
- rootsHandler mkConn request respond
-
- ("GET", ["bundle", "name", nameText]) -> do
- body <- nameHandler mkConn nameText
- respond body
-
- ("GET", ["bundle", "hash", hashText]) -> do
- body <- hashHandler mkConn hashText
- respond body
-
- ("GET", ["terms"]) -> do
- body <- termsResponse mkConn
- respond body
-
- ("POST", _) ->
- respond $ responseLBS status405 [] "Method not allowed"
-
- ("PUT", _) ->
- respond $ responseLBS status405 [] "Method not allowed"
-
- ("DELETE", _) ->
- respond $ responseLBS status405 [] "Method not allowed"
-
- _ ->
- respond $ responseLBS status404 [] "not found"
-
-healthResponse :: Response
-healthResponse = responseLBS status200 [] "ok"
-
--- | GET /bundle/roots?n=root&n=helper&h=abc123...
-rootsHandler :: IO Connection -> Request -> (Response -> IO a) -> IO a
-rootsHandler mkConn request respond = do
- conn <- mkConn
- let qs = queryString request
- nParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "n"]
- hParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "h"]
- -- Resolve 'n' params to (name, hash) pairs
- nResults <- mapM (\nVal -> do
- stored <- nameToTerm conn (decodeUtf8 nVal)
- case stored of
- Nothing -> return Nothing
- Just t -> return $ Just (decodeUtf8 nVal, termHash t)) nParams
- let namedHashesFromN = catMaybes nResults
- -- Validate 'h' params and build (name, hash) pairs
- namedHashesFromH <- mapM (\hVal -> do
- let raw = T.pack (dropWhile (=='#') (T.unpack (decodeUtf8 hVal)))
- if T.all isHexDigit raw && T.length raw >= 16
- then do
- stored <- hashToTerm conn raw
- let names = maybe "root" firstOrRoot (termNames <$> stored)
- return $ Just (names, raw)
- else return Nothing)
- hParams
- let allNamedHashes = namedHashesFromN ++ catMaybes namedHashesFromH
- -- Require at least one root
- when (null allNamedHashes) $ do
- let resp = responseLBS status400 [] "400 Bad Request: at least one n= or h= parameter required"
- close conn
- void $ respond resp
- -- Build and return the bundle
- bundleData <- buildAndEncodeBundle conn allNamedHashes
- let firstHash = snd (head allNamedHashes)
- cd = T.pack "attachment; filename=roots.bundle"
- close conn
- respond $ responseLBS status200
- (bundleHeaders firstHash cd)
- (fromStrict bundleData)
-
--- | GET /bundle/name/:name
-nameHandler :: IO Connection -> Text -> IO Response
-nameHandler mkConn nameText = do
- conn <- mkConn
- stored <- nameToTerm conn nameText
- case stored of
- Nothing -> do
- close conn
- return $ textResponse status404 ("not found: " <> nameText)
- Just term' -> do
- let th = termHash term'
- namedHashes = [(firstOrRoot (termNames term'), th)]
- bundleData <- buildAndEncodeBundle conn namedHashes
- let cd = T.pack $ "attachment; filename=" ++ safeFileName (T.unpack nameText) ++ ".bundle"
- close conn
- return $ responseLBS status200 (bundleHeaders th cd) (fromStrict bundleData)
-
--- | GET /bundle/hash/:hash
-hashHandler :: IO Connection -> Text -> IO Response
-hashHandler mkConn hashText =
- let raw = T.pack (dropWhile (== '#') (T.unpack hashText))
- in if not (T.all isHexDigit raw) || T.length raw < 16
- then return $ responseLBS status400 [] "400 Bad Request: invalid hash"
- else do
- conn <- mkConn
- stored <- hashToTerm conn raw
- case stored of
- Nothing -> do
- close conn
- return $ textResponse status404 ("not found: " <> hashText)
- Just term' -> do
- let th = termHash term'
- namedHashes' = [(firstOrRoot (termNames term'), th)]
- bundleData <- buildAndEncodeBundle conn namedHashes'
- close conn
- return $ responseLBS status200
- (bundleHeaders th "attachment; filename=hash.bundle")
- (fromStrict bundleData)
-
--- | Helper: load terms by hash and build an indexed bundle.
-buildAndEncodeBundle :: Connection -> [(Text, Text)] -> IO ByteString
-buildAndEncodeBundle conn namedHashes = do
- terms <- mapM (\(_, h) -> do
- maybeTree <- loadTree conn h
- case maybeTree of
- Nothing -> error $ "Server: hash not found in store: " ++ T.unpack h
- Just tree -> return tree) namedHashes
- let namedTerms = zip (map fst namedHashes) terms
- bundle = buildBundle namedTerms
- return $ encodeBundle bundle
-
--- | GET /terms
-termsResponse :: IO Connection -> IO Response
-termsResponse mkConn = do
- conn <- mkConn
- terms <- listStoredTerms conn
- close conn
- let lines' = [ names <> " " <> hash <> " " <> T.pack (show created)
- | term <- terms
- , let names = termNames term
- , let hash = termHash term
- , let created = termCreatedAt term ]
- return $ responseLBS status200
- [ (hContentType, encodeUtf8 "text/plain; charset=utf-8")
- ]
- (fromStrict $ encodeUtf8 $ T.unlines lines')
-
-textResponse :: Status -> Text -> Response
-textResponse status body =
- responseLBS status
- [ (hContentType, encodeUtf8 "text/plain; charset=utf-8") ]
- (fromStrict $ encodeUtf8 body)
-
-bundleHeaders :: Text -> Text -> [Header]
-bundleHeaders root cd =
- [ (hContentType, encodeUtf8 "application/vnd.arboricx.bundle")
- , ("X-Arboricx-Root-Hash", encodeUtf8 root)
- , ("Content-Disposition", encodeUtf8 cd)
- ]
-
-firstOrRoot :: Text -> Text
-firstOrRoot names =
- case parseNameList names of
- [] -> "root"
- (x:_) -> x
-
-safeFileName :: String -> String
-safeFileName = map go
- where
- go c
- | c >= 'a' && c <= 'z' = c
- | c >= 'A' && c <= 'Z' = c
- | c >= '0' && c <= '9' = c
- | c == '-' = c
- | c == '_' = c
- | otherwise = '_'
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -15,7 +15,7 @@ import qualified Network.Socket as NS
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import System.IO.Temp (withSystemTempDirectory)
-import System.Directory (createDirectory)
+import System.Directory (createDirectory, doesFileExist, doesDirectoryExist)
import Data.Bits (xor)
import Data.Char (digitToInt)
import Data.List (isInfixOf)
@@ -57,6 +57,7 @@ tests = testGroup "Tricu Tests"
, tricuReaderTests
, byteListUtilities
, binaryParserTests
+ , httpParsingTests
, ioDriverTests
]
@@ -864,15 +865,15 @@ providedLibraries = testGroup "Library Tests"
env = evalTricu library (parseTricu input)
result env @?= ofString "hello world"
- , testCase "strEq? equal strings" $ do
+ , testCase "equal? equal strings" $ do
library <- evaluateFile "./lib/list.tri"
- let input = "strEq? \"abc\" \"abc\""
+ let input = "equal? \"abc\" \"abc\""
env = evalTricu library (parseTricu input)
result env @?= trueT
- , testCase "strEq? different strings" $ do
+ , testCase "equal? different strings" $ do
library <- evaluateFile "./lib/list.tri"
- let input = "strEq? \"abc\" \"def\""
+ let input = "equal? \"abc\" \"def\""
env = evalTricu library (parseTricu input)
result env @?= falseT
@@ -1677,7 +1678,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
[ testCase "Tricu reader parses indexed bundle (id fixture)" $ do
bundleBytes <- BS.readFile "./test/fixtures/id.arboricx"
let bundleT = ofBytes bundleBytes
- readerEnv <- evaluateFile "./lib/arboricx.tri"
+ readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
let env = Map.insert "testBundle" bundleT readerEnv
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
tag = result (evalTricu env tagExpr)
@@ -1688,7 +1689,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
, testCase "Tricu reader parses indexed bundle (append fixture)" $ do
bundleBytes <- BS.readFile "./test/fixtures/append.arboricx"
let bundleT = ofBytes bundleBytes
- readerEnv <- evaluateFile "./lib/arboricx.tri"
+ readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
let env = Map.insert "testBundle" bundleT readerEnv
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
tag = result (evalTricu env tagExpr)
@@ -1698,7 +1699,7 @@ tricuReaderTests = testGroup "Tricu Reader Tests"
forM_ ["true", "false"] $ \name -> do
bundleBytes <- BS.readFile ("./test/fixtures/" ++ name ++ ".arboricx")
let bundleT = ofBytes bundleBytes
- readerEnv <- evaluateFile "./lib/arboricx.tri"
+ readerEnv <- evaluateFile "./lib/arboricx/arboricx.tri"
let env = Map.insert "testBundle" bundleT readerEnv
tagExpr = parseTricu "pairFirst (runArboricx testBundle t)"
tag = result (evalTricu env tagExpr)
@@ -1960,13 +1961,13 @@ byteListUtilities = testGroup "Byte List Utility Tests"
result env @?= pairT (bytesT [1,2]) (bytesT [])
, testCase "byteEq: equal bytes are equal" $ do
- let input = "byteEq? 1 1"
+ let input = "equal? 1 1"
library <- evaluateFile "./lib/bytes.tri"
let env = evalTricu library (parseTricu input)
result env @?= trueT
, testCase "byteEq: unequal bytes are not equal" $ do
- let input = "byteEq? 1 2"
+ let input = "equal? 1 2"
library <- evaluateFile "./lib/bytes.tri"
let env = evalTricu library (parseTricu input)
result env @?= falseT
@@ -2939,9 +2940,607 @@ ioDriverTests = testGroup "IO driver tests"
final @?= ofNumber 99
contents <- readFile releasePath
contents @?= "released"
+
+ -- Directory and file management primitives
+ , testGroup "listDirectory"
+ [ testCase "listDirectory returns entry names" $
+ withSystemTempDirectory "tricu-listdir" $ \dir -> do
+ writeFile (dir ++ "/a.txt") "a"
+ writeFile (dir ++ "/b.txt") "b"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onListDirectory \"" ++ dir ++ "\""
+ , " (err rest : pure false)"
+ , " (entries rest :"
+ , " pure (pair (lExist? \"a.txt\" entries) (lExist? \"b.txt\" entries))))"
+ ]
+ final @?= Fork (Stem Leaf) (Stem Leaf)
+
+ , testCase "listDirectory missing path returns does not exist" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onListDirectory \"/nonexistent/path/12345\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "does not exist"
+
+ , testCase "listDirectory on file returns not a directory" $
+ withSystemTempDirectory "tricu-listdir-file" $ \dir -> do
+ let path = dir ++ "/file.txt"
+ writeFile path "x"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onListDirectory \"" ++ path ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "not a directory"
+
+ , testCase "listDirectory denied path returns permission denied" $
+ withSystemTempDirectory "tricu-listdir-denied" $ \dir -> do
+ let allowedDir = dir ++ "/allowed"
+ deniedDir = dir ++ "/denied"
+ createDirectory allowedDir
+ createDirectory deniedDir
+ let perms = defaultPerms { allowRead = [allowedDir] }
+ final <- runIOSourceWithPerms perms $
+ unlines
+ [ "main = io (listDirectory \"" ++ deniedDir ++ "\")"
+ ]
+ final @?= ioErrResult "permission denied"
+ ]
+
+ , testCase "listDirectory excludes dot entries" $
+ withSystemTempDirectory "tricu-listdir-dot" $ \dir -> do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onListDirectory \"" ++ dir ++ "\""
+ , " (err rest : pure false)"
+ , " (entries rest :"
+ , " pure (pair (lExist? \".\" entries) (lExist? \"..\" entries))))"
+ ]
+ final @?= Fork Leaf Leaf
+
+ , testGroup "renameFile"
+ [ testCase "renameFile moves file atomically" $
+ withSystemTempDirectory "tricu-rename" $ \dir -> do
+ let oldPath = dir ++ "/old.txt"
+ newPath = dir ++ "/new.txt"
+ writeFile oldPath "contents"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onRenameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "ok"
+ newExists <- doesFileExist newPath
+ oldExists <- doesFileExist oldPath
+ newExists @?= True
+ oldExists @?= False
+
+ , testCase "renameFile missing source returns does not exist" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onRenameFile \"/nonexistent/old.txt\" \"/nonexistent/new.txt\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "does not exist"
+
+ , testCase "renameFile denied destination returns permission denied" $
+ withSystemTempDirectory "tricu-rename-denied" $ \dir -> do
+ let allowedDir = dir ++ "/allowed"
+ deniedDir = dir ++ "/denied"
+ createDirectory allowedDir
+ createDirectory deniedDir
+ let oldPath = allowedDir ++ "/old.txt"
+ newPath = deniedDir ++ "/new.txt"
+ writeFile oldPath "contents"
+ let perms = defaultPerms { allowWrite = [allowedDir] }
+ final <- runIOSourceWithPerms perms $
+ unlines
+ [ "main = io (renameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\")"
+ ]
+ final @?= ioErrResult "permission denied"
+
+ , testCase "renameFile replaces existing destination atomically" $
+ withSystemTempDirectory "tricu-rename-replace" $ \dir -> do
+ let oldPath = dir ++ "/old.txt"
+ newPath = dir ++ "/new.txt"
+ writeFile oldPath "new"
+ writeFile newPath "old"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onRenameFile \"" ++ oldPath ++ "\" \"" ++ newPath ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "ok"
+ readFile newPath >>= (@?= "new")
+ oldExists <- doesFileExist oldPath
+ oldExists @?= False
+ ]
+
+ , testGroup "createDirectory"
+ [ testCase "createDirectory creates new directory" $
+ withSystemTempDirectory "tricu-mkdir" $ \dir -> do
+ let newDir = dir ++ "/subdir"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onCreateDirectory \"" ++ newDir ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "ok"
+ exists <- doesDirectoryExist newDir
+ exists @?= True
+
+ , testCase "createDirectory is idempotent for existing directory" $
+ withSystemTempDirectory "tricu-mkdir-idempotent" $ \dir -> do
+ let existingDir = dir ++ "/exists"
+ createDirectory existingDir
+ final <- runIOSource $
+ unlines
+ [ "main = io (onCreateDirectory \"" ++ existingDir ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "ok"
+
+ , testCase "createDirectory on existing file returns already exists" $
+ withSystemTempDirectory "tricu-mkdir-file" $ \dir -> do
+ let path = dir ++ "/file.txt"
+ writeFile path "x"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onCreateDirectory \"" ++ path ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "already exists"
+
+ , testCase "createDirectory missing parent returns does not exist" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onCreateDirectory \"/nonexistent/path/12345/sub\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "does not exist"
+
+ , testCase "createDirectory denied path returns permission denied" $
+ withSystemTempDirectory "tricu-mkdir-denied" $ \dir -> do
+ let allowedDir = dir ++ "/allowed"
+ deniedDir = dir ++ "/denied"
+ createDirectory allowedDir
+ createDirectory deniedDir
+ let perms = defaultPerms { allowWrite = [allowedDir] }
+ final <- runIOSourceWithPerms perms $
+ unlines
+ [ "main = io (createDirectory \"" ++ deniedDir ++ "/new\")"
+ ]
+ final @?= ioErrResult "permission denied"
+ , testCase "createDirectory with file parent returns not a directory or does not exist" $
+ withSystemTempDirectory "tricu-mkdir-file-parent" $ \dir -> do
+ let parentFile = dir ++ "/file"
+ child = parentFile ++ "/sub"
+ writeFile parentFile "x"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onCreateDirectory \"" ++ child ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "not a directory"
+ ]
+
+ , testGroup "deleteFile"
+ [ testCase "deleteFile removes file" $
+ withSystemTempDirectory "tricu-delete" $ \dir -> do
+ let path = dir ++ "/del.txt"
+ writeFile path "x"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onDeleteFile \"" ++ path ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "ok"
+ exists <- doesFileExist path
+ exists @?= False
+
+ , testCase "deleteFile is idempotent for missing file" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onDeleteFile \"/nonexistent/path/12345.txt\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "ok"
+
+ , testCase "deleteFile on directory returns is a directory" $
+ withSystemTempDirectory "tricu-delete-dir" $ \dir -> do
+ let subDir = dir ++ "/subdir"
+ createDirectory subDir
+ final <- runIOSource $
+ unlines
+ [ "main = io (onDeleteFile \"" ++ subDir ++ "\""
+ , " (err rest : pure err)"
+ , " (_ rest : pure \"ok\"))"
+ ]
+ final @?= ofString "is a directory"
+
+ , testCase "deleteFile denied path returns permission denied" $
+ withSystemTempDirectory "tricu-delete-denied" $ \dir -> do
+ let allowedDir = dir ++ "/allowed"
+ deniedDir = dir ++ "/denied"
+ createDirectory allowedDir
+ createDirectory deniedDir
+ let path = deniedDir ++ "/file.txt"
+ writeFile path "x"
+ let perms = defaultPerms { allowWrite = [allowedDir] }
+ final <- runIOSourceWithPerms perms $
+ unlines
+ [ "main = io (deleteFile \"" ++ path ++ "\")"
+ ]
+ final @?= ioErrResult "permission denied"
+ ]
+
+ , testGroup "fileExists"
+ [ testCase "fileExists true for existing file" $
+ withSystemTempDirectory "tricu-exists" $ \dir -> do
+ let path = dir ++ "/file.txt"
+ writeFile path "x"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onFileExists \"" ++ path ++ "\""
+ , " (err rest : pure err)"
+ , " (exists rest : pure exists))"
+ ]
+ final @?= Stem Leaf
+
+ , testCase "fileExists false for missing path" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onFileExists \"/nonexistent/path/12345.txt\""
+ , " (err rest : pure err)"
+ , " (exists rest : pure exists))"
+ ]
+ final @?= Leaf
+
+ , testCase "fileExists denied path returns permission denied" $
+ withSystemTempDirectory "tricu-exists-denied" $ \dir -> do
+ let allowedDir = dir ++ "/allowed"
+ deniedDir = dir ++ "/denied"
+ createDirectory allowedDir
+ createDirectory deniedDir
+ let path = deniedDir ++ "/file.txt"
+ writeFile path "x"
+ let perms = defaultPerms { allowRead = [allowedDir] }
+ final <- runIOSourceWithPerms perms $
+ unlines
+ [ "main = io (fileExists \"" ++ path ++ "\")"
+ ]
+ final @?= ioErrResult "permission denied"
+ ]
+
+ , testGroup "sha256Hex"
+ [ testCase "sha256Hex returns lowercase hex digest" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onSha256Hex [(104) (105)]"
+ , " (err rest : pure err)"
+ , " (hex rest : pure hex))"
+ ]
+ final @?= ofString "8f434346648f6b96df89dda901c5176b10a6d83961dd3c1ac88b59b2dc327aa4"
+
+ , testCase "sha256Hex empty bytes returns empty digest" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onSha256Hex []"
+ , " (err rest : pure err)"
+ , " (hex rest : pure hex))"
+ ]
+ final @?= ofString "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
+
+ , testCase "sha256Hex hashes raw bytes" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onSha256Hex [(0) (255) (1)]"
+ , " (err rest : pure err)"
+ , " (hex rest : pure hex))"
+ ]
+ final @?= ofString "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123"
+ ]
+
+ , testGroup "currentTime"
+ [ testCase "currentTime returns a positive integer" $ do
+ final <- runIOSource $
+ unlines
+ [ "main = io (onCurrentTime"
+ , " (err rest : pure 0)"
+ , " (v rest : pure v))"
+ ]
+ case toNumber final of
+ Right n | n > 1600000000 -> return () -- after ~Sep 2020
+ Right n -> assertFailure $ "Expected recent timestamp, got: " ++ show n
+ Left err -> assertFailure $ "Expected number, got error: " ++ err
+ ]
]
]
+httpParsingTests :: TestTree
+httpParsingTests = testGroup "HTTP Parsing Tests"
+ [
+ -- chomp / request-line reader
+ testCase "chomp strips trailing CR" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "chomp [(104) (105) (13)]"
+ env = evalTricu lib (parseTricu input)
+ result env @?= bytesT [104, 105]
+
+ , testCase "chomp leaves line without CR" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "chomp [(104) (105)]"
+ env = evalTricu lib (parseTricu input)
+ result env @?= bytesT [104, 105]
+
+ , testCase "chomp empty list" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "chomp []"
+ env = evalTricu lib (parseTricu input)
+ result env @?= bytesT []
+
+ , testCase "readLineBytes with CRLF" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "readLineBytes [(104) (105) (13) (10) (120)]"
+ env = evalTricu lib (parseTricu input)
+ result env @?= pairT (bytesT [104, 105]) (bytesT [120])
+
+ , testCase "readLineBytes with bare LF" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "readLineBytes [(104) (105) (10) (120)]"
+ env = evalTricu lib (parseTricu input)
+ result env @?= pairT (bytesT [104, 105]) (bytesT [120])
+
+ , testCase "readLineBytes empty line" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "readLineBytes [(13) (10) (120)]"
+ env = evalTricu lib (parseTricu input)
+ result env @?= pairT (bytesT []) (bytesT [120])
+
+ , testCase "readLineBytes EOF mid-line returns line" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "readLineBytes [(104) (105)]"
+ env = evalTricu lib (parseTricu input)
+ result env @?= pairT (bytesT [104, 105]) (bytesT [])
+
+ -- parseRequestLine
+ , testCase "parseRequestLine GET slash" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseRequestLine (append \"GET / HTTP/1.1\\r\\n\" \"x\")"
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserOk
+ (pairT (ofString "GET") (pairT (ofString "/") (ofString "HTTP/1.1")))
+ (ofString "x")
+
+ , testCase "parseRequestLine POST path" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseRequestLine \"POST /foo/bar HTTP/1.1\\r\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserOk
+ (pairT (ofString "POST") (pairT (ofString "/foo/bar") (ofString "HTTP/1.1")))
+ (ofString "")
+
+ , testCase "parseRequestLine too short" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseRequestLine \"GET\\r\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ , testCase "parseRequestLine no version" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseRequestLine \"GET /foo\\r\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ , testCase "parseRequestLine empty line" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseRequestLine \"\\r\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ , testCase "parseRequestLine rejects extra fields" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseRequestLine \"GET / HTTP/1.1 wat\\r\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ -- parseHeaders
+ , testCase "parseHeaders two headers lowercases names" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseHeaders (append \"Host: localhost\\r\\nContent-Length: 42\\r\\n\\r\\n\" \"x\")"
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserOk
+ (ofList
+ [ pairT (ofString "host") (ofString "localhost")
+ , pairT (ofString "content-length") (ofString "42")
+ ])
+ (ofString "x")
+
+ , testCase "parseHeaders preserves colon in value" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseHeaders (append \"X-Custom: a: b\\r\\n\\r\\n\" \"x\")"
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserOk
+ (ofList [pairT (ofString "x-custom") (ofString "a: b")])
+ (ofString "x")
+
+ , testCase "parseHeaders accepts empty value" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseHeaders (append \"X-Empty:\\r\\n\\r\\n\" \"x\")"
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserOk
+ (ofList [pairT (ofString "x-empty") (ofString "")])
+ (ofString "x")
+
+ , testCase "parseHeaders immediate blank" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseHeaders \"\\r\\nx\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserOk (ofList []) (ofString "x")
+
+ , testCase "parseHeaders rejects missing colon" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "parseHeaders \"Host\\r\\n\\r\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n")
+
+ -- statusLine / headerLine
+ , testCase "statusLine 200 OK" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusLine 200 \"OK\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 200 OK\r\n"
+
+ , testCase "headerLine Content-Length" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "headerLine \"Content-Length\" \"42\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Content-Length: 42\r\n"
+
+ -- statusPhrase
+ , testCase "statusPhrase 200" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 200"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "OK"
+
+ , testCase "statusPhrase 201" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 201"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Created"
+
+ , testCase "statusPhrase 204" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 204"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "No Content"
+
+ , testCase "statusPhrase 400" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 400"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Bad Request"
+
+ , testCase "statusPhrase 404" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 404"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Not Found"
+
+ , testCase "statusPhrase 405" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 405"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Method Not Allowed"
+
+ , testCase "statusPhrase 431" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 431"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Request Header Fields Too Large"
+
+ , testCase "statusPhrase 501" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 501"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Not Implemented"
+
+ , testCase "statusPhrase 505" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 505"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP Version Not Supported"
+
+ , testCase "statusPhrase 500" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 500"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Internal Server Error"
+
+ , testCase "statusPhrase unknown" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "statusPhrase 999"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "Internal Server Error"
+
+ -- buildResponse
+ , testCase "buildResponse 200 no headers" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "buildResponse 200 [] \"hi\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 200 OK\r\n\r\nhi"
+
+ , testCase "buildResponse 404 with header" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "buildResponse 404 [(pair \"Content-Length\" \"9\")] \"Not found\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Length: 9\r\n\r\nNot found"
+
+ -- convenience responses
+ , testCase "okResponse" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "okResponse \"hi\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi"
+
+ , testCase "notFoundResponse" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "notFoundResponse"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 404 Not Found\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 10\r\nConnection: close\r\n\r\nNot found\n"
+
+ , testCase "textResponse" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "textResponse \"hi\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 2\r\nConnection: close\r\n\r\nhi"
+
+ , testCase "jsonResponse" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "jsonResponse \"{}\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 200 OK\r\nContent-Type: application/json\r\nContent-Length: 2\r\nConnection: close\r\n\r\n{}"
+
+ , testCase "createdResponse" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "createdResponse \"created\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 201 Created\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 8\r\nConnection: close\r\n\r\ncreated\n"
+
+ , testCase "emptyResponse 204" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "emptyResponse 204"
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\nConnection: close\r\n\r\n"
+
+ , testCase "badRequestResponse" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "badRequestResponse \"Bad Request\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 12\r\nConnection: close\r\n\r\nBad Request\n"
+
+ , testCase "errorResponse 405" $ do
+ lib <- evaluateFile "./lib/http.tri"
+ let input = "errorResponse 405 \"Method Not Allowed\\n\""
+ env = evalTricu lib (parseTricu input)
+ result env @?= ofString "HTTP/1.1 405 Method Not Allowed\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 19\r\nConnection: close\r\n\r\nMethod Not Allowed\n"
+ ]
+
withFreePort :: (Int -> IO a) -> IO a
withFreePort action =
bracket
@@ -2978,4 +3577,4 @@ ioOkResult :: T -> T
ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
ioErrResult :: String -> T
-ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)
+ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)
+\ No newline at end of file
diff --git a/tricu.cabal b/tricu.cabal
@@ -48,12 +48,10 @@ executable tricu
, filepath
, fsnotify
, haskeline
- , http-types
, megaparsec
, memory
, mtl
, network
- , servant
, sqlite-simple
, stm
, tasty
@@ -62,8 +60,6 @@ executable tricu
, time
, transformers
, vector
- , wai
- , warp
, zlib
other-modules:
ContentStore
@@ -75,7 +71,6 @@ executable tricu
Paths_tricu
REPL
Research
- Server
Wire
default-language: Haskell2010
@@ -146,12 +141,10 @@ test-suite tricu-tests
, filepath
, fsnotify
, haskeline
- , http-types
, megaparsec
, memory
, mtl
, network
- , servant
, sqlite-simple
, stm
, tasty
@@ -162,8 +155,6 @@ test-suite tricu-tests
, transformers
, unix
, vector
- , wai
- , warp
, zlib
default-language: Haskell2010
other-modules:
@@ -176,5 +167,4 @@ test-suite tricu-tests
Paths_tricu
REPL
Research
- Server
Wire
