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

(: Aiche Tee Tee Pee :)

Browse Source 
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.
This commit is contained in:
James Eversole
2026-05-20 15:52:03 -05:00
parent 7ae3fc33f4
commit bf30d5945e
27 changed files with 1852 additions and 400 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
lib/arboricx.tri → lib/arboricx/arboricx.tri
View File

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

8
lib/arboricx-common.tri → lib/arboricx/common.tri
View File

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

0
lib/arboricx-dispatch.tri → lib/arboricx/dispatch.tri
View File

2
lib/arboricx-manifest.tri → lib/arboricx/manifest.tri
View File

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

4
lib/arboricx-nodes.tri → lib/arboricx/nodes.tri
View File

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

143
lib/arboricx/server.tri Normal file
View File

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

48
lib/base.tri
View File

@@ -121,6 +121,18 @@ maybe? = matchMaybe false (_ : true)
-- Basic arithmetic
-- ---------------------------------------------------------------------------
ifLazy = (cond thenK elseK :
matchBool
(thenK t)
(elseK t)
cond)
andLazy? = (a bK :
ifLazy
a
bK
(_ : false))
pred = y (self : triage
0
(_ : 0)
@@ -146,19 +158,35 @@ add = y (self x y :
x)
sub = y (self a b :
matchBool
a
(self (pred a) (pred b))
(isZero? b))
ifLazy
(isZero? b)
(_ : a)
(_ : self (pred a) (pred b)))
lt? = a b : not? (isZero? (sub b a))
lte? = a b : isZero? (sub a b)
lte? = y (self a b :
ifLazy
(isZero? a)
(_ : true)
(_ :
ifLazy
(isZero? b)
(_ : false)
(_ : self (pred a) (pred b))))
gte? = a b :
lte? b a
lt? = a b :
and? (lte? a b) (not? (equal? a b))
gt? = a b :
lt? b a
mul = y (self a b :
matchBool
0
(add a (self a (pred b)))
(isZero? b))
ifLazy
(isZero? b)
(_ : 0)
(_ : add a (self a (pred b))))
-- ---------------------------------------------------------------------------
-- Result combinators

4
lib/binary.tri
View File

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

1
lib/bytes.tri
View File

@@ -7,7 +7,6 @@ bytesHead = matchList nothing (h _ : just h)
bytesTail = matchList nothing (_ r : just r)
byteEq? = equal?
bytesLength = length
bytesAppend = append
bytesTake = take

755
lib/http.tri Normal file
View File

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

17
lib/io.tri
View File

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

25
lib/list.tri
View File

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

27
lib/socket.tri
View File

@@ -2,9 +2,8 @@
!import "io.tri" !Local
-- Socket primitives for the IO driver.
-- All actions return a Result tree (see lib/base.tri):
-- ok value -- pair true (pair value t)
-- err msg -- pair false (pair msg t)
-- ok value t -- pair true (pair value t)
-- err msg t -- pair false (pair msg t)
socket = pair 70 t
closeSocket = sock : pair 71 sock
@@ -16,7 +15,7 @@ recv = sock maxBytes : pair 76 (pair sock maxBytes)
send = sock bytes : pair 77 (pair sock bytes)
getSocketName = sock : pair 78 sock
-- Result-aware wrappers over raw socket actions.
-- Result-aware wrappers over raw socket actions
onSocket = onResult socket
onBindSocket = sock addr port : onResult (bindSocket sock addr port)
onListen = sock backlog : onResult (listen sock backlog)
@@ -26,15 +25,15 @@ onRecv = sock maxBytes : onResult (recv sock maxBytes)
onSend = sock bytes : onResult (send sock bytes)
onGetSocketName = sock : onResult (getSocketName sock)
-- Result-aware wrappers that drop the useless 'rest' parameter.
onSocket_ = onResult_ socket
onBindSocket_ = sock addr port : onResult_ (bindSocket sock addr port)
onListen_ = sock backlog : onResult_ (listen sock backlog)
onAccept_ = sock : onResult_ (accept sock)
onConnect_ = sock addr port : onResult_ (connect sock addr port)
onRecv_ = sock maxBytes : onResult_ (recv sock maxBytes)
onSend_ = sock bytes : onResult_ (send sock bytes)
onGetSocketName_ = sock : onResult_ (getSocketName sock)
-- Result-aware wrappers that drop the 'rest' parameter
onSocket_ = onResult_ socket
onBindSocket_ = sock addr port : onResult_ (bindSocket sock addr port)
onListen_ = sock backlog : onResult_ (listen sock backlog)
onAccept_ = sock : onResult_ (accept sock)
onConnect_ = sock addr port : onResult_ (connect sock addr port)
onRecv_ = sock maxBytes : onResult_ (recv sock maxBytes)
onSend_ = sock bytes : onResult_ (send sock bytes)
onGetSocketName_ = sock : onResult_ (getSocketName sock)
-- Close a socket, ignoring errors.
closeSocket_ = sock : void (closeSocket sock)
@@ -45,7 +44,7 @@ listenSocket = addr port backlog :
onOk_ socket (server :
onOk_ (bindSocket server addr port) (_ :
onOk_ (listen server backlog) (_ :
pure (ok server))))
pure (ok server t))))
-- Accept a connection with explicit error and ok branches.
-- okHandler receives (clientSocket, peerAddr).