(: Aiche Tee Tee Pee :)

Perhaps the first webserver in Tree Calculus? Sure, it's married to a Haskell
IO runtime... but we're managing all of the actual webserver semantics in tricu!

This includes a demo Arboricx application server that is capable of storing
and serving bundles.

.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

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

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"
 

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

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

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

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.

flake.nix

@@ -262,14 +262,8 @@
           config = {
             Cmd = [
               "/bin/tricu"
-              "server"
-              "-h" "0.0.0.0"
-              "-p" "8787"
             ];
             WorkingDir = "/app";
-            ExposedPorts = {
-              "8787/tcp" = {};
-            };
             extraCommands = ''
             '';
           };

lib/arboricx/arboricx.tri

@@ -1,4 +1,4 @@
-!import "arboricx-manifest.tri" !Local
+!import "manifest.tri" !Local
 
 -- Read and validate a full Arboricx bundle.
 -- Returns (pair validManifest afterContainer).

lib/arboricx/common.tri

@@ -1,7 +1,7 @@
-!import "base.tri" !Local
+!import "../base.tri" !Local
-!import "list.tri" !Local
+!import "../list.tri" !Local
-!import "bytes.tri" !Local
+!import "../bytes.tri" !Local
-!import "binary.tri" !Local
+!import "../binary.tri" !Local
 
 arboricxMagic = [(65) (82) (66) (79) (82) (73) (67) (88)]
 arboricxMajorVersion = [(0) (1)]

lib/arboricx/manifest.tri

@@ -1,4 +1,4 @@
-!import "arboricx-nodes.tri" !Local
+!import "nodes.tri" !Local
 
 readManifestMagic = (bs :
   expectBytes arboricxManifestMagic bs)

lib/arboricx/nodes.tri

@@ -1,4 +1,4 @@
-!import "arboricx-common.tri" !Local
+!import "common.tri" !Local
 
 -- Indexed Arboricx node section reader.
 --
@@ -22,7 +22,7 @@ nodePayloadKind = (nodePayload : bytesHead nodePayload)
 nodePayloadHasTag? = (tag nodePayload :
   triage
     false
-    (actualTag : byteEq? actualTag tag)
+    (actualTag : equal? actualTag tag)
     (_ _ : false)
     (nodePayloadKind nodePayload))
 

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

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
+  ifLazy
-    a
+    (isZero? b)
-    (self (pred a) (pred b))
+    (_ : a)
-    (isZero? b))
+    (_ : self (pred a) (pred b)))
 
-lt? = a b : not? (isZero? (sub b a))
+lte? = y (self a b :
-lte? = a b : isZero? (sub 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
+  ifLazy
-    0
+    (isZero? b)
-    (add a (self a (pred b)))
+    (_ : 0)
-    (isZero? b))
+    (_ : add a (self a (pred b))))
 
 -- ---------------------------------------------------------------------------
 -- Result combinators

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)

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

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

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

lib/list.tri

@@ -162,7 +162,10 @@ strAppend = append
 strEq? = equal?
 strEmpty? = emptyList?
 
-startsWith? = y (self prefix str :
+startsWith? = (prefix input :
+  ((go :
+    go prefix input)
+   (y (self p s :
       matchList
         true
         (ph pr :
@@ -173,8 +176,8 @@ startsWith? = y (self prefix str :
                 (self pr sr)
                 false
                 (equal? ph sh))
-        str)
+            s)
-    prefix)
+        p))))
 
 endsWith? = prefix str : startsWith? (reverse prefix) (reverse str)
 

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 t  -- pair true (pair value t)
---   ok value  -- pair true (pair value t)
+--   err msg t   -- pair false (pair msg t)
---   err msg   -- 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,7 +25,7 @@ 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.
+-- 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)
@@ -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).

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 Data.List (isPrefixOf, isInfixOf)
-import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories)
+import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories, takeDirectory)
-import System.Directory (canonicalizePath, doesPathExist, getCurrentDirectory)
+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

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

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 = '_'

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,7 +2940,605 @@ 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

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