Fix HTTP body framing and eliminate request over-read

Packaging: Fully static Haskell builds and webapp
2026-05-21 17:09:43 -05:00 · 2026-05-21 15:25:26 -05:00
6 changed files with 213 additions and 104 deletions
--- a/demos/interactionTrees/arboricxServer.tri
+++ b/demos/interactionTrees/arboricxServer.tri
@@ -6,7 +6,7 @@
 --
 -- Endpoints:
 --   GET  /_arboricx/health          -> "OK"
--   POST /_arboricx/bundles         -> upload bundle, returns hash
+--   POST /_arboricx/bundle          -> upload bundle, returns hash
 --   GET  /_arboricx/bundle/hash/:h  -> download bundle by hash
 --
 -- Example usage:
--- a/flake.nix
+++ b/flake.nix
@@ -16,7 +16,29 @@
        haskellPackages = pkgs.haskellPackages;
        hsLib = pkgs.haskell.lib;

-        tricuStatic = hsLib.justStaticExecutables self.packages.${system}.default;
+        staticPkgs = pkgs.pkgsStatic;
+        staticHaskellPackages = staticPkgs.haskellPackages;
+        staticHsLib = staticPkgs.haskell.lib;
+
+        tricuMuslStatic =
+          staticHsLib.justStaticExecutables (
+            staticHsLib.dontCheck (
+              staticHaskellPackages.callCabal2nix packageName self {}
+            )
+          );
+
+        tricuStatic = pkgs.runCommand "${packageName}-static-upx" {
+          nativeBuildInputs = [ pkgs.upx ];
+        } ''
+            mkdir -p $out/bin
+            cp ${tricuMuslStatic}/bin/tricu $out/bin/tricu
+            chmod +w $out/bin/tricu
+
+            # Good compression, slower build.
+            upx --best --lzma $out/bin/tricu
+
+            chmod 755 $out/bin/tricu
+          '';

        tricuPackageTests =
          haskellPackages.callCabal2nix packageName self {};
@@ -221,6 +243,8 @@
      in {
        packages.${packageName} = tricuPackage;
        packages.default = tricuPackage;
+				packages.tricu-static = tricuMuslStatic;
+				packages.tricu-static-upx = tricuStatic;
        packages.tricu-bench = tricuBench;
        packages.tricu-zig = tricuZig;
        packages.tricu-zig-tests = tricuZigTests;
@@ -252,20 +276,35 @@

        packages.${containerPackageName} = pkgs.dockerTools.buildImage {
          name = "tricu";
+          tag = "latest";

          copyToRoot = pkgs.buildEnv {
            name = "image-root";
            paths = [ tricuStatic ];
            pathsToLink = [ "/bin" ];
          };
-          tag = "latest";
+
          config = {
-            Cmd = [
-              "/bin/tricu"
-            ];
+            Cmd = [ "/bin/tricu" ];
            WorkingDir = "/app";
-            extraCommands = ''
+          };
+        };
+
+        packages.arboricxServer = pkgs.dockerTools.buildImage {
+          name = "arboricxServer";
+          tag = "latest";
+
+          copyToRoot = pkgs.runCommand "arboricxServer" {} ''
+            mkdir -p $out/app/bin $out/app/lib $out/app/tricu-apps $out/app/store
+            cp ${tricuStatic}/bin/tricu $out/app/bin/
+            cp -r ${./lib}/* $out/app/lib/
+            cp ${./tricu-apps/arboricxServer.tri} $out/app/tricu-apps/arboricxServer.tri
          '';
+
+          config = {
+            Entrypoint = [ "/app/bin/tricu" "eval" "tricu-apps/arboricxServer.tri" "--io" "--allow-read" "./store" "--allow-write" "./store" "-f" "decode" ];
+            WorkingDir = "/app";
+            ExposedPorts = { "8080/tcp" = {}; };
          };
        };
      });
--- a/lib/arboricx/server.tri
+++ b/lib/arboricx/server.tri
@@ -129,6 +129,15 @@ stripPrefix = (prefix input :

 bundleHashPrefix = "/_arboricx/bundle/hash/"

+-- ---------------------------------------------------------------------------
+-- Landing page
+-- ---------------------------------------------------------------------------
+
+-- TODO: Let's replace in-line HTML with the ability to read and serve files
+-- from a public/ folder.
+
+htmlLandingPage = "<!DOCTYPE html><html><head><meta name='viewport' content='width=device-width, initial-scale=1'><title>Arboricx Server</title></head><body><h1>Arboricx Server</h1><p>Bundle registry</p><p><a href='https://git.eversole.co/James/tricu'>Made with Love (and trees, lots of trees)</a></p></body></html>"
+
 -- ---------------------------------------------------------------------------
 -- Registry routes
 -- ---------------------------------------------------------------------------
@@ -154,7 +163,7 @@ putBundleRoute = (root method target body :
              (hash _ : pure (createdResponse hash))
              result))
        (_ : pure notFoundResponse)
-        (equal? target "/_arboricx/bundles"))
+        (equal? target "/_arboricx/bundle"))
    (_ : pure notFoundResponse)
    (equal? method "POST"))

@@ -175,6 +184,9 @@ getBundleRoute = (root method target :

 arboricxRouter = (root method target headers body :
  lazyBool
+    (_ :
+      lazyBool
+        (_ : pure (htmlResponse htmlLandingPage))
        (_ :
          lazyMaybe
            (_ : healthRoute method target)
@@ -185,6 +197,7 @@ arboricxRouter = (root method target headers body :
                  (bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
                  result))
            (stripPrefix bundleHashPrefix target))
+        (equal? target "/"))
    (_ :
      lazyBool
        (_ : putBundleRoute root method target body)
--- a/lib/http.tri
+++ b/lib/http.tri
@@ -104,6 +104,9 @@ textResponse = (body :
 jsonResponse = (body :
  response 200 "application/json" body)

+htmlResponse = (body :
+  response 200 "text/html; charset=utf-8" body)
+
 createdResponse = (body :
  response 201 "text/plain; charset=utf-8" body)

@@ -156,7 +159,7 @@ responseForMethod = (method resp :
 -- ---------------------------------------------------------------------------

 recvUntilMax_ = (y (self sock pattern maxBytes acc accLen :
-  onResult_ (recv sock 4096)
+  onResult_ (recv sock 1)
    (err :
      pure (err 400 acc))
    (chunk :
@@ -515,63 +518,130 @@ contentLength = (headers :
 --  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))
+bodyReadState = (remaining accRev rest :
+  pair remaining (pair accRev rest))

-consumeAvailable = (bytes n :
-  consumeAvailable_ bytes n t)
+bodyReadRemaining = (state :
+  fst state)

-readBodyN_ = (y (self sock remaining acc :
+bodyReadAccRev = (state :
+  fst (snd state))
+
+bodyReadRest = (state :
+  snd (snd state))
+
+takeBodyBytes_ = (self bytes remaining accRev :
  lazyBool
-    (_ : pure (ok acc t))
+    (_ : bodyReadState 0 accRev bytes)
    (_ :
-      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)))
+      lazyList
+        (_ : bodyReadState remaining accRev t)
+        (h r :
+          self r (pred remaining) (pair h accRev))
+        bytes)
+    (isZero? remaining))

-readBodyN = (sock n acc :
-  readBodyN_ sock n acc)
+takeBodyBytes = (bytes remaining accRev :
+  y takeBodyBytes_ bytes remaining accRev)
+
+readBodyRecv = (self sock remaining accRev recvBytes :
+  onResult_ (recv sock recvBytes)
+    (errMsg :
+      pure
+        (err
+          400
+          (append "recv failed while reading body: " errMsg)))
+    (chunk :
+      ((state :
+        ((nextRemaining :
+          ((nextAccRev :
+            lazyBool
+              (_ : pure (ok (reverse nextAccRev) (bodyReadRest state)))
+              (_ : self sock nextRemaining nextAccRev)
+              (isZero? nextRemaining))
+           (bodyReadAccRev state)))
+         (bodyReadRemaining state)))
+       (takeBodyBytes chunk remaining accRev))))
+
+readBodyMore_ = (self sock remaining accRev :
+  lazyBool
+    (_ : pure (ok (reverse accRev) t))
+    (_ :
+      lazyBool
+        (_ : readBodyRecv self sock remaining accRev 4096)
+        (_ :
+          lazyBool
+            (_ : readBodyRecv self sock remaining accRev 1024)
+            (_ :
+              lazyBool
+                (_ : readBodyRecv self sock remaining accRev 256)
+                (_ :
+                  lazyBool
+                    (_ : readBodyRecv self sock remaining accRev 64)
+                    (_ :
+                      lazyBool
+                        (_ : readBodyRecv self sock remaining accRev 16)
+                        (_ : readBodyRecv self sock remaining accRev 1)
+                        (lte? 16 remaining))
+                    (lte? 64 remaining))
+                (lte? 256 remaining))
+            (lte? 1024 remaining))
+        (lte? 4096 remaining))
+    (isZero? remaining))
+
+readBodyMore = (sock remaining accRev :
+  y readBodyMore_ sock remaining accRev)
+
+readBodyExact = (sock expected initialBytes :
+  ((state :
+    ((remaining :
+      ((accRev :
+        lazyBool
+          (_ : pure (ok (reverse accRev) (bodyReadRest state)))
+          (_ : readBodyMore sock remaining accRev)
+          (isZero? remaining))
+       (bodyReadAccRev state)))
+     (bodyReadRemaining state)))
+   (takeBodyBytes initialBytes expected t)))
+
+validateBodyLength = (expected body rest :
+  ((actual :
+    lazyBool
+      (_ : pure (ok body rest))
+      (_ :
+        pure
+          (err
+            400
+            (append
+              "body length mismatch expected="
+              (append
+                (showNumber expected)
+                (append
+                  " actual="
+                  (showNumber actual))))))
+      (equal? actual expected))
+   (length body)))

 readBody = (sock headers initialBytes :
  matchResult
    (status msg :
-      pure (err status "Bad Request\n"))
+      pure (err status msg))
    (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)))
+              onOk (readBodyExact sock n initialBytes)
+                (body rest :
+                  validateBodyLength n body rest))
+            (_ : pure (err 400 "Request body too large\n"))
+            (lte? n maxBodyBytes))
        maybeLen)
    (contentLength headers))

 -- ---------------------------------------------------------------------------
-- 10. Request validation
+-- Request validation
 -- ---------------------------------------------------------------------------

 validMethod? = (method :
@@ -626,12 +696,12 @@ respondAndClose = (sock resp :
    pure (ok t t)))

 handleReadableRequest = (router client method target headers rest3 :
-  onResult_ (readBody client headers rest3)
-    (status :
+  onResult (readBody client headers rest3)
+    (status msg :
      respondAndClose client
        (responseForMethod method
-          (badRequestResponse "Bad Request\n")))
-    (body :
+          (errorResponse status msg)))
+    (body rest :
      respondAndClose client
        (responseForMethod method
          (router (routerMethod method) target headers body))))
@@ -677,12 +747,12 @@ httpHandler = (router client peer :
 -- ---------------------------------------------------------------------------

 handleReadableRequestIO = (routerIO client method target headers rest3 :
-  onResult_ (readBody client headers rest3)
-    (status :
+  onResult (readBody client headers rest3)
+    (status msg :
      respondAndClose client
        (responseForMethod method
-          (badRequestResponse "Bad Request\n")))
-    (body :
+          (errorResponse status msg)))
+    (body rest :
      bind (routerIO (routerMethod method) target headers body) (resp :
        respondAndClose client (responseForMethod method resp))))

--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -2122,42 +2122,6 @@ binaryParserTests = testGroup "Binary Parser Tests"
      let input = "expectAscii \"hi\" [(104) (99)]"
          env = evalTricu lib (parseTricu input)
      result env @?= parserErr (ofNumber 2) (bytesT [104, 99])
-
-  , testCase "u16BE decodes big-endian" $ do
-      lib <- evaluateFile "./lib/binary.tri"
-      let input = "u16BE [(1) (0)]"
-          env = evalTricu lib (parseTricu input)
-      result env @?= ofNumber 256
-
-  , testCase "u16BE zero" $ do
-      lib <- evaluateFile "./lib/binary.tri"
-      let input = "u16BE [(0) (1)]"
-          env = evalTricu lib (parseTricu input)
-      result env @?= ofNumber 1
-
-  , testCase "u16LE decodes little-endian" $ do
-      lib <- evaluateFile "./lib/binary.tri"
-      let input = "u16LE [(1) (0)]"
-          env = evalTricu lib (parseTricu input)
-      result env @?= ofNumber 1
-
-  , testCase "u16LE zero" $ do
-      lib <- evaluateFile "./lib/binary.tri"
-      let input = "u16LE [(0) (1)]"
-          env = evalTricu lib (parseTricu input)
-      result env @?= ofNumber 256
-
-  , testCase "readU16BE parses and decodes" $ do
-      lib <- evaluateFile "./lib/binary.tri"
-      let input = "readU16BE [(0) (1) (2)]"
-          env = evalTricu lib (parseTricu input)
-      result env @?= parserOk (ofNumber 1) (bytesT [2])
-
-  , testCase "readU16LE parses and decodes" $ do
-      lib <- evaluateFile "./lib/binary.tri"
-      let input = "readU16LE [(1) (0) (2)]"
-          env = evalTricu lib (parseTricu input)
-      result env @?= parserOk (ofNumber 1) (bytesT [2])
  ]

 -- --------------------------------------------------------------------------
--- a/tricu-apps/arboricxServer.tri
+++ b/tricu-apps/arboricxServer.tri
@@ -0,0 +1,23 @@
+!import "../lib/io.tri"            !Local
+!import "../lib/arboricx/server.tri" !Local
+
+-- Arboricx HTTP registry server.
+-- Run with --allow-write ./store --allow-read ./store
+--
+-- Endpoints:
+--   GET  /                          -> HTML landing page
+--   GET  /_arboricx/health          -> "OK"
+--   POST /_arboricx/bundle          -> upload bundle, returns hash
+--   GET  /_arboricx/bundle/hash/:h  -> download bundle by hash
+--
+-- Example usage:
+--   curl http://localhost:8080/
+--   curl http://localhost:8080/_arboricx/health
+--   curl -X POST --data-binary @mybundle.arboricx http://localhost:8080/_arboricx/bundles
+--   curl http://localhost:8080/_arboricx/bundle/hash/<hash>
+
+main = io (thenIO
+  (putStrLn "Starting Arboricx server on 0.0.0.0:8080")
+  (thenIO
+    (void (ensureStore "./store"))
+    (arboricxServer "./store" "0.0.0.0" 8080)))
Author	SHA1	Message	Date
James Eversole	7cea3d1559	Fix HTTP body framing and eliminate request over-read	2026-05-21 17:09:43 -05:00
James Eversole	ac90d23b46	Packaging: Fully static Haskell builds and webapp	2026-05-21 15:25:26 -05:00