James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: James:4bf2ce56dd035ec3cc4c2393e5c192b82e8a8007
Branches Tags
James:main James:contentstore James:feat/elimination-optimizations-debruijn-kiselyov
James:0.18.1 James:0.18.0 James:0.16.0 James:0.15.0 James:0.14.0 James:0.13.1 James:0.13.0 James:0.12.0-hotfixes James:0.12.0 James:0.11.0 James:0.10.0 James:0.9.0 James:0.8.0 James:0.7.0 James:0.6.0-2e246eb1c8 James:0.6.0-8995efce15 James:0.5.0
...
compare: James:7cea3d15590a571dba1f86534aa0311dfddd6b11
Branches Tags
James:main James:contentstore James:feat/elimination-optimizations-debruijn-kiselyov
James:0.18.1 James:0.18.0 James:0.16.0 James:0.15.0 James:0.14.0 James:0.13.1 James:0.13.0 James:0.12.0-hotfixes James:0.12.0 James:0.11.0 James:0.10.0 James:0.9.0 James:0.8.0 James:0.7.0 James:0.6.0-2e246eb1c8 James:0.6.0-8995efce15 James:0.5.0

2 Commits
4bf2ce56dd ... 7cea3d1559

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
6 changed files with 213 additions and 104 deletions
Expand all files Collapse all files

2
demos/interactionTrees/arboricxServer.tri
View File

@@ -6,7 +6,7 @@
-- --
-- Endpoints: -- Endpoints:
-- GET /_arboricx/health -> "OK" -- 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 -- GET /_arboricx/bundle/hash/:h -> download bundle by hash
-- --
-- Example usage: -- Example usage:

53
flake.nix
View File

@@ -16,7 +16,29 @@
haskellPackages = pkgs.haskellPackages; haskellPackages = pkgs.haskellPackages;
hsLib = pkgs.haskell.lib; 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 = tricuPackageTests =
haskellPackages.callCabal2nix packageName self {}; haskellPackages.callCabal2nix packageName self {};
@@ -221,6 +243,8 @@
in { in {
packages.${packageName} = tricuPackage; packages.${packageName} = tricuPackage;
packages.default = tricuPackage; packages.default = tricuPackage;
packages.tricu-static = tricuMuslStatic;
packages.tricu-static-upx = tricuStatic;
packages.tricu-bench = tricuBench; packages.tricu-bench = tricuBench;
packages.tricu-zig = tricuZig; packages.tricu-zig = tricuZig;
packages.tricu-zig-tests = tricuZigTests; packages.tricu-zig-tests = tricuZigTests;
@@ -252,20 +276,35 @@
packages.${containerPackageName} = pkgs.dockerTools.buildImage { packages.${containerPackageName} = pkgs.dockerTools.buildImage {
name = "tricu"; name = "tricu";
tag = "latest";
copyToRoot = pkgs.buildEnv { copyToRoot = pkgs.buildEnv {
name = "image-root"; name = "image-root";
paths = [ tricuStatic ]; paths = [ tricuStatic ];
pathsToLink = [ "/bin" ]; pathsToLink = [ "/bin" ];
}; };
tag = "latest";
config = { config = {
Cmd = [ Cmd = [ "/bin/tricu" ];
"/bin/tricu"
];
WorkingDir = "/app"; 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" = {}; };
}; };
}; };
}); });

33
lib/arboricx/server.tri
View File

@@ -129,6 +129,15 @@ stripPrefix = (prefix input :
bundleHashPrefix = "/_arboricx/bundle/hash/" 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 -- Registry routes
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
@@ -154,7 +163,7 @@ putBundleRoute = (root method target body :
(hash _ : pure (createdResponse hash)) (hash _ : pure (createdResponse hash))
result)) result))
(_ : pure notFoundResponse) (_ : pure notFoundResponse)
(equal? target "/_arboricx/bundles")) (equal? target "/_arboricx/bundle"))
(_ : pure notFoundResponse) (_ : pure notFoundResponse)
(equal? method "POST")) (equal? method "POST"))
@@ -176,15 +185,19 @@ getBundleRoute = (root method target :
arboricxRouter = (root method target headers body : arboricxRouter = (root method target headers body :
lazyBool lazyBool
(_ : (_ :
lazyMaybe lazyBool
(_ : healthRoute method target) (_ : pure (htmlResponse htmlLandingPage))
(hash : (_ :
bind (getBundleByHash root hash) (result : lazyMaybe
matchResult (_ : healthRoute method target)
(errMsg _ : pure (errorResponse 404 errMsg)) (hash :
(bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes)) bind (getBundleByHash root hash) (result :
result)) matchResult
(stripPrefix bundleHashPrefix target)) (errMsg _ : pure (errorResponse 404 errMsg))
(bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
result))
(stripPrefix bundleHashPrefix target))
(equal? target "/"))
(_ : (_ :
lazyBool lazyBool
(_ : putBundleRoute root method target body) (_ : putBundleRoute root method target body)

168
lib/http.tri
View File

@@ -104,6 +104,9 @@ textResponse = (body :
jsonResponse = (body : jsonResponse = (body :
response 200 "application/json" body) response 200 "application/json" body)
htmlResponse = (body :
response 200 "text/html; charset=utf-8" body)
createdResponse = (body : createdResponse = (body :
response 201 "text/plain; charset=utf-8" body) response 201 "text/plain; charset=utf-8" body)
@@ -156,7 +159,7 @@ responseForMethod = (method resp :
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
recvUntilMax_ = (y (self sock pattern maxBytes acc accLen : recvUntilMax_ = (y (self sock pattern maxBytes acc accLen :
onResult_ (recv sock 4096) onResult_ (recv sock 1)
(err : (err :
pure (err 400 acc)) pure (err 400 acc))
(chunk : (chunk :
@@ -515,63 +518,130 @@ contentLength = (headers :
-- Body reading -- Body reading
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
consumeAvailable_ = (y (self bytes remaining acc : bodyReadState = (remaining accRev rest :
lazyList pair remaining (pair accRev rest))
(_ : 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 : bodyReadRemaining = (state :
consumeAvailable_ bytes n t) fst state)
readBodyN_ = (y (self sock remaining acc : bodyReadAccRev = (state :
fst (snd state))
bodyReadRest = (state :
snd (snd state))
takeBodyBytes_ = (self bytes remaining accRev :
lazyBool lazyBool
(_ : pure (ok acc t)) (_ : bodyReadState 0 accRev bytes)
(_ : (_ :
onResult_ (recv sock remaining) lazyList
(err : (_ : bodyReadState remaining accRev t)
pure (err 400 acc)) (h r :
(chunk : self r (pred remaining) (pair h accRev))
((got : bytes)
lazyBool (isZero? remaining))
(_ : pure (err 400 acc))
(_ : self sock (sub remaining got) (append acc chunk))
(equal? got 0))
(length chunk))))
(isZero? remaining)))
readBodyN = (sock n acc : takeBodyBytes = (bytes remaining accRev :
readBodyN_ sock n acc) 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 : readBody = (sock headers initialBytes :
matchResult matchResult
(status msg : (status msg :
pure (err status "Bad Request\n")) pure (err status msg))
(maybeLen rest : (maybeLen rest :
lazyMaybe lazyMaybe
(_ : pure (ok t initialBytes)) (_ : pure (ok t initialBytes))
(n : (n :
((consumed : lazyBool
((body0 : (_ :
((remaining : onOk (readBodyExact sock n initialBytes)
lazyBool (body rest :
(_ : pure (ok body0 t)) validateBodyLength n body rest))
(_ : (_ : pure (err 400 "Request body too large\n"))
onOk (readBodyN sock remaining body0) (lte? n maxBodyBytes))
(body rest : pure (ok body t)))
(isZero? remaining))
(fst (snd consumed))))
(fst consumed)))
(consumeAvailable initialBytes n)))
maybeLen) maybeLen)
(contentLength headers)) (contentLength headers))
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- 10. Request validation -- Request validation
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
validMethod? = (method : validMethod? = (method :
@@ -626,12 +696,12 @@ respondAndClose = (sock resp :
pure (ok t t))) pure (ok t t)))
handleReadableRequest = (router client method target headers rest3 : handleReadableRequest = (router client method target headers rest3 :
onResult_ (readBody client headers rest3) onResult (readBody client headers rest3)
(status : (status msg :
respondAndClose client respondAndClose client
(responseForMethod method (responseForMethod method
(badRequestResponse "Bad Request\n"))) (errorResponse status msg)))
(body : (body rest :
respondAndClose client respondAndClose client
(responseForMethod method (responseForMethod method
(router (routerMethod method) target headers body)))) (router (routerMethod method) target headers body))))
@@ -677,12 +747,12 @@ httpHandler = (router client peer :
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
handleReadableRequestIO = (routerIO client method target headers rest3 : handleReadableRequestIO = (routerIO client method target headers rest3 :
onResult_ (readBody client headers rest3) onResult (readBody client headers rest3)
(status : (status msg :
respondAndClose client respondAndClose client
(responseForMethod method (responseForMethod method
(badRequestResponse "Bad Request\n"))) (errorResponse status msg)))
(body : (body rest :
bind (routerIO (routerMethod method) target headers body) (resp : bind (routerIO (routerMethod method) target headers body) (resp :
respondAndClose client (responseForMethod method resp)))) respondAndClose client (responseForMethod method resp))))

38
test/Spec.hs
View File

@@ -2122,42 +2122,6 @@ binaryParserTests = testGroup "Binary Parser Tests"
let input = "expectAscii \"hi\" [(104) (99)]" let input = "expectAscii \"hi\" [(104) (99)]"
env = evalTricu lib (parseTricu input) env = evalTricu lib (parseTricu input)
result env @?= parserErr (ofNumber 2) (bytesT [104, 99]) 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])
] ]
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
@@ -3577,4 +3541,4 @@ ioOkResult :: T -> T
ioOkResult val = Fork (Stem Leaf) (Fork val Leaf) ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
ioErrResult :: String -> T ioErrResult :: String -> T
ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf) ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)

23
tricu-apps/arboricxServer.tri Normal file
View File

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