giles
8ed44f7770
The sx-forge native-loop blocker: clone! of the live giles/rose-ash never returned over gitea/http-app. Root cause was NOT the transport — pack-line-parse ran every pack line through the interpreted spec parser (~6.6KB/s on the CEK machine; a full-repo pack = hours), and a non-hex byte in a pkt length header parsed negative (index-of -1), walking the scan index backwards forever. - gitea/parse-obj: use the host reader (open-input-string + read, ~3700x faster, value-identical) when the host provides it; hosts without string ports keep sx-parse. Feature-detected at load. - pkt-sections-loop: (< n 4) guard — malformed lengths error instead of hanging. - push-cmd!: haves = every advertised remote ref held locally, so a NEW branch pushes only its delta, not the whole repo closure. - tests/wire.sx: malformed-len errors, truncated-pkt clamps, parse-obj = sx-parse equivalence (blob/commit + cid). 83/83. - tests/wire-http.sh + wire-http-client.sx: end-to-end over REAL http-listen/http-request on :8943 — ls-remote/clone/push-new-branch/ fresh-clone-verify/delete. The coverage gap that hid all this. Proven vs the live forge (in sx-gitea-1): full 4468-file clone in 77s (was: hang), commit, push heads/sx-smoke-test ok, branch advertised on sx.sx-web.org. Conformance 620/620. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
591 lines
20 KiB
Plaintext
591 lines
20 KiB
Plaintext
; lib/gitea/wire.sx — sx-gitea Phase 3: smart-HTTP wire protocol.
|
|
;
|
|
; git-style smart HTTP over the NATIVE sx-git object model: pkt-line
|
|
; framing (byte-compatible with git's framing), ref advertisement,
|
|
; upload-pack (clone/fetch) and receive-pack (push). Objects travel as
|
|
; "<cid> <serialized-sx>" pkt lines — the receiver re-derives the CID
|
|
; from the bytes, so a pack can't lie about its contents. SHA-1/packfile
|
|
; byte compat for stock git clients stays in lib/git/{export,import}.sx.
|
|
;
|
|
; Endpoints (registered on gitea/route-packs):
|
|
; GET /:owner/:name/info/refs read-gated ref advertisement
|
|
; POST /:owner/:name/git-upload-pack read-gated; wants/haves -> pack
|
|
; POST /:owner/:name/git-receive-pack write-gated; commands+pack -> statuses
|
|
;
|
|
; A client (gitea/remote over any dream app fn) provides ls-remote /
|
|
; clone! / fetch! / push! / push-delete! — two in-memory forges can sync
|
|
; with no sockets anywhere.
|
|
;
|
|
; Scale notes: the closure walk mutates a PRIVATE seen-dict in place
|
|
; (dict-set!) and stacks pending cids with cons — `assoc` copies the
|
|
; whole hashtable per call and list concat copies its head, either of
|
|
; which makes a 10k-object walk quadratic. Pack enumeration is unsorted
|
|
; for the same reason (artdag/sort-strings is an insertion sort; pack
|
|
; order is irrelevant to the receiver).
|
|
;
|
|
; Limits: one object per pkt line => objects over ~64KB need side-band
|
|
; chunking (future extension); gitea/pkt-fits? reports this.
|
|
;
|
|
; Requires: lib/gitea/{repo,access,web}.sx and their stacks, plus
|
|
; sx-parse (spec/parser.sx on the OCaml server host).
|
|
|
|
; ── pkt-line framing ─────────────────────────────────────────────────
|
|
|
|
(define gitea/hex-chars "0123456789abcdef")
|
|
|
|
(define
|
|
gitea/hex4
|
|
(fn
|
|
(n)
|
|
(str
|
|
(char-at gitea/hex-chars (mod (quotient n 4096) 16))
|
|
(char-at gitea/hex-chars (mod (quotient n 256) 16))
|
|
(char-at gitea/hex-chars (mod (quotient n 16) 16))
|
|
(char-at gitea/hex-chars (mod n 16)))))
|
|
|
|
(define gitea/hex-val (fn (c) (index-of gitea/hex-chars (lower c))))
|
|
|
|
(define
|
|
gitea/hex4-parse
|
|
(fn
|
|
(s)
|
|
(+
|
|
(* 4096 (gitea/hex-val (char-at s 0)))
|
|
(* 256 (gitea/hex-val (char-at s 1)))
|
|
(* 16 (gitea/hex-val (char-at s 2)))
|
|
(gitea/hex-val (char-at s 3)))))
|
|
|
|
(define gitea/pkt-max 65531)
|
|
(define gitea/pkt-fits? (fn (s) (<= (string-length s) gitea/pkt-max)))
|
|
|
|
(define
|
|
gitea/pkt
|
|
(fn
|
|
(s)
|
|
(if
|
|
(gitea/pkt-fits? s)
|
|
(str (gitea/hex4 (+ (string-length s) 4)) s)
|
|
(error "gitea/pkt: payload exceeds pkt-line limit"))))
|
|
|
|
(define gitea/pkt-flush "0000")
|
|
|
|
; frame a list of line-lists, flush after each section
|
|
(define
|
|
gitea/pkt-render
|
|
(fn
|
|
(sections)
|
|
(join
|
|
""
|
|
(map
|
|
(fn (lines) (str (join "" (map gitea/pkt lines)) gitea/pkt-flush))
|
|
sections))))
|
|
|
|
; parse framed data into sections (lists of lines) split on flush pkts.
|
|
; A non-hex byte in a length header parses negative (index-of -> -1);
|
|
; the (< n 4) guard makes that an error — without it i walks backwards
|
|
; and the loop never terminates (a malformed body must not hang).
|
|
(define
|
|
gitea/pkt-sections-loop
|
|
(fn
|
|
(data i cur sections)
|
|
(if
|
|
(>= i (string-length data))
|
|
(reverse (if (empty? cur) sections (cons (reverse cur) sections)))
|
|
(let
|
|
((n (gitea/hex4-parse (substr data i 4))))
|
|
(cond
|
|
((= n 0)
|
|
(gitea/pkt-sections-loop
|
|
data
|
|
(+ i 4)
|
|
(list)
|
|
(cons (reverse cur) sections)))
|
|
((< n 4)
|
|
(error (str "gitea/pkt-sections: malformed pkt-len at " i)))
|
|
(else
|
|
(gitea/pkt-sections-loop
|
|
data
|
|
(+ i n)
|
|
(cons (substr data (+ i 4) (- n 4)) cur)
|
|
sections)))))))
|
|
|
|
(define
|
|
gitea/pkt-sections
|
|
(fn (data) (gitea/pkt-sections-loop data 0 (list) (list))))
|
|
|
|
; ── object closure ───────────────────────────────────────────────────
|
|
|
|
; cids an object references
|
|
(define
|
|
gitea/obj-refs
|
|
(fn
|
|
(obj)
|
|
(cond
|
|
((git/commit? obj)
|
|
(cons (git/commit-tree obj) (git/commit-parents obj)))
|
|
((git/tree? obj)
|
|
(map
|
|
(fn (n) (git/entry-cid (git/tree-entry-for obj n)))
|
|
(git/tree-names obj)))
|
|
((git/tag? obj) (list (git/tag-target obj)))
|
|
(else (list)))))
|
|
|
|
; walk from pending cids; returns {:seen {cid true} :missing (cids)}.
|
|
; `seen` must be a PRIVATE dict — it is mutated in place.
|
|
(define
|
|
gitea/closure-walk
|
|
(fn
|
|
(grepo pending seen missing)
|
|
(if
|
|
(empty? pending)
|
|
{:seen seen :missing (reverse missing)}
|
|
(let
|
|
((cid (first pending)) (more (rest pending)))
|
|
(if
|
|
(get seen cid)
|
|
(gitea/closure-walk grepo more seen missing)
|
|
(let
|
|
((obj (git/read grepo cid)))
|
|
(if
|
|
(nil? obj)
|
|
(gitea/closure-walk grepo more seen (cons cid missing))
|
|
(begin
|
|
(dict-set! seen cid true)
|
|
(gitea/closure-walk
|
|
grepo
|
|
(reduce
|
|
(fn (acc r) (cons r acc))
|
|
more
|
|
(gitea/obj-refs obj))
|
|
seen
|
|
missing)))))))))
|
|
|
|
(define
|
|
gitea/closure
|
|
(fn
|
|
(grepo cids)
|
|
(get (gitea/closure-walk grepo cids {} (list)) :seen)))
|
|
|
|
(define
|
|
gitea/closure-list
|
|
(fn (grepo cids) (artdag/sort-strings (keys (gitea/closure grepo cids)))))
|
|
|
|
(define
|
|
gitea/closure-complete?
|
|
(fn
|
|
(grepo cids)
|
|
(empty?
|
|
(get (gitea/closure-walk grepo cids {} (list)) :missing))))
|
|
|
|
; objects needed to bring someone with `haves` up to `wants` (unsorted)
|
|
(define
|
|
gitea/pack-cids
|
|
(fn
|
|
(grepo wants haves)
|
|
(let
|
|
((have-set (gitea/closure grepo haves)))
|
|
(filter
|
|
(fn (c) (not (get have-set c)))
|
|
(keys (gitea/closure grepo wants))))))
|
|
|
|
; ── wire object encoding ─────────────────────────────────────────────
|
|
|
|
(define
|
|
gitea/pack-line
|
|
(fn (grepo cid) (str cid " " (serialize (git/read grepo cid)))))
|
|
|
|
; parse one serialized object. sx-parse (the spec parser) is interpreted —
|
|
; ~6KB/s on the CEK machine, which turns a full-repo pack into hours; the
|
|
; host reader (open-input-string + read) parses the same grammar natively
|
|
; (~3700x faster, value-identical). Feature-detect at load: hosts without
|
|
; string ports keep the spec parser.
|
|
(define
|
|
gitea/parse-obj
|
|
(if
|
|
(and (primitive? "open-input-string") (primitive? "read"))
|
|
(fn (s) (read (open-input-string s)))
|
|
(fn (s) (first (sx-parse s)))))
|
|
|
|
; parse "<cid> <sx>" and verify the cid matches the bytes
|
|
(define
|
|
gitea/pack-line-parse
|
|
(fn
|
|
(line)
|
|
(let
|
|
((sp (index-of line " ")))
|
|
(if
|
|
(< sp 0)
|
|
{:error "malformed"}
|
|
(let
|
|
((cid (substr line 0 sp))
|
|
(obj (gitea/parse-obj (substr line (+ sp 1)))))
|
|
(if (= (git/cid obj) cid) {:obj obj :cid cid} {:error "cid-mismatch" :cid cid}))))))
|
|
|
|
; verify + store every pack line; => {:stored n} | {:error ...}
|
|
(define
|
|
gitea/unpack!
|
|
(fn
|
|
(grepo lines)
|
|
(reduce
|
|
(fn
|
|
(acc line)
|
|
(if
|
|
(get acc :error)
|
|
acc
|
|
(let
|
|
((p (gitea/pack-line-parse line)))
|
|
(if
|
|
(get p :error)
|
|
p
|
|
(begin (git/write grepo (get p :obj)) {:stored (+ (get acc :stored) 1)})))))
|
|
{:stored 0}
|
|
lines)))
|
|
|
|
; ── server: ref advertisement ────────────────────────────────────────
|
|
|
|
(define
|
|
gitea/shared-ref?
|
|
(fn (name) (or (starts-with? name "heads/") (starts-with? name "tags/"))))
|
|
|
|
(define
|
|
gitea/wire-refs
|
|
(fn
|
|
(grepo)
|
|
(filter (fn (n) (gitea/shared-ref? n)) (git/ref-names grepo))))
|
|
|
|
(define
|
|
gitea/w-info-refs
|
|
(fn
|
|
(forge req)
|
|
(let
|
|
((owner (dream-param req "owner")) (name (dream-param req "name")))
|
|
(if
|
|
(not (gitea/w-readable? forge req owner name))
|
|
(dream-not-found)
|
|
(let
|
|
((grepo (gitea/repo-git forge owner name)))
|
|
(let
|
|
((head-line (let ((target (git/head-target grepo))) (if (nil? target) (list) (list (str "@ " target)))))
|
|
(ref-lines
|
|
(map
|
|
(fn (n) (str (git/ref-get grepo n) " " n))
|
|
(gitea/wire-refs grepo))))
|
|
(dream-text
|
|
(gitea/pkt-render (list (concat head-line ref-lines))))))))))
|
|
|
|
; ── server: upload-pack (clone/fetch) ────────────────────────────────
|
|
|
|
(define
|
|
gitea/want-lines
|
|
(fn
|
|
(lines prefix)
|
|
(map
|
|
(fn (l) (substr l (string-length prefix)))
|
|
(filter (fn (l) (starts-with? l prefix)) lines))))
|
|
|
|
(define
|
|
gitea/w-upload-pack
|
|
(fn
|
|
(forge req)
|
|
(let
|
|
((owner (dream-param req "owner")) (name (dream-param req "name")))
|
|
(if
|
|
(not (gitea/w-readable? forge req owner name))
|
|
(dream-not-found)
|
|
(let
|
|
((grepo (gitea/repo-git forge owner name))
|
|
(sections (gitea/pkt-sections (dream-body req))))
|
|
(let
|
|
((lines (if (empty? sections) (list) (first sections))))
|
|
(let
|
|
((wants (gitea/want-lines lines "want "))
|
|
(haves (gitea/want-lines lines "have ")))
|
|
(dream-text
|
|
(gitea/pkt-render
|
|
(list
|
|
(map
|
|
(fn (c) (gitea/pack-line grepo c))
|
|
(gitea/pack-cids grepo wants haves))))))))))))
|
|
|
|
; ── server: receive-pack (push) ──────────────────────────────────────
|
|
|
|
(define gitea/zero-ref "-")
|
|
|
|
; "<old> <new> <refname>" — old/new are cids or "-"
|
|
(define
|
|
gitea/cmd-parse
|
|
(fn
|
|
(line)
|
|
(let
|
|
((a (index-of line " ")))
|
|
(let ((b (index-of (substr line (+ a 1)) " "))) {:name (substr line (+ a 1 b 1)) :new (substr line (+ a 1) b) :old (substr line 0 a)}))))
|
|
|
|
; apply one ref command; => "ok <name>" | "ng <name> <reason>"
|
|
(define
|
|
gitea/apply-cmd!
|
|
(fn
|
|
(grepo cmd)
|
|
(let
|
|
((old (get cmd :old)) (new (get cmd :new)) (name (get cmd :name)))
|
|
(cond
|
|
((not (gitea/shared-ref? name)) (str "ng " name " invalid-ref"))
|
|
((equal? new gitea/zero-ref)
|
|
(if
|
|
(=
|
|
(git/ref-get grepo name)
|
|
(if (equal? old gitea/zero-ref) nil old))
|
|
(begin (git/ref-delete! grepo name) (str "ok " name))
|
|
(str "ng " name " stale")))
|
|
((not (gitea/closure-complete? grepo (list new)))
|
|
(str "ng " name " missing-objects"))
|
|
((and (not (equal? old gitea/zero-ref)) (starts-with? name "heads/") (not (git/is-ancestor? grepo old new)))
|
|
(str "ng " name " non-fast-forward"))
|
|
(else
|
|
(let
|
|
((res (git/ref-cas! grepo name (if (equal? old gitea/zero-ref) nil old) new)))
|
|
(if
|
|
(and (dict? res) (get res :conflict))
|
|
(str "ng " name " stale")
|
|
(str "ok " name))))))))
|
|
|
|
(define
|
|
gitea/w-receive-pack
|
|
(fn
|
|
(forge req)
|
|
(let
|
|
((owner (dream-param req "owner")) (name (dream-param req "name")))
|
|
(let
|
|
((user (gitea/w-user forge req)))
|
|
(cond
|
|
((not (gitea/can? forge user "read" owner name))
|
|
(dream-not-found))
|
|
((nil? user) (gitea/w-unauthorized))
|
|
((not (gitea/can? forge user "write" owner name))
|
|
(gitea/w-forbidden))
|
|
(else
|
|
(let
|
|
((grepo (gitea/repo-git forge owner name))
|
|
(sections (gitea/pkt-sections (dream-body req))))
|
|
(let
|
|
((cmds (if (empty? sections) (list) (first sections)))
|
|
(objs
|
|
(if
|
|
(< (len sections) 2)
|
|
(list)
|
|
(nth sections 1))))
|
|
(let
|
|
((unpack (gitea/unpack! grepo objs)))
|
|
(if
|
|
(get unpack :error)
|
|
(dream-text
|
|
(gitea/pkt-render
|
|
(list (list (str "unpack " (get unpack :error))))))
|
|
(dream-text
|
|
(gitea/pkt-render
|
|
(list
|
|
(cons
|
|
"unpack ok"
|
|
(map
|
|
(fn
|
|
(c)
|
|
(gitea/apply-cmd! grepo (gitea/cmd-parse c)))
|
|
cmds)))))))))))))))
|
|
|
|
; ── routes ───────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
gitea/wire-routes
|
|
(fn
|
|
(forge)
|
|
(list
|
|
(dream-get
|
|
"/:owner/:name/info/refs"
|
|
(fn (req) (gitea/w-info-refs forge req)))
|
|
(dream-post
|
|
"/:owner/:name/git-upload-pack"
|
|
(fn (req) (gitea/w-upload-pack forge req)))
|
|
(dream-post
|
|
"/:owner/:name/git-receive-pack"
|
|
(fn (req) (gitea/w-receive-pack forge req))))))
|
|
|
|
(set! gitea/route-packs (append gitea/route-packs (list gitea/wire-routes)))
|
|
|
|
; back-compat aliases from before the route-pack registry
|
|
(define gitea/forge-routes gitea/all-routes)
|
|
(define gitea/forge-app gitea/app)
|
|
|
|
; ── client ───────────────────────────────────────────────────────────
|
|
; A remote is any dream app fn plus repo coordinates and a token — the
|
|
; same code drives an in-memory forge or a real HTTP transport.
|
|
|
|
(define gitea/remote (fn (app owner name token) {:name name :owner owner :token token :app app}))
|
|
|
|
(define
|
|
gitea/remote-call
|
|
(fn
|
|
(remote method suffix body)
|
|
((get remote :app)
|
|
(dream-request
|
|
method
|
|
(str "/" (get remote :owner) "/" (get remote :name) suffix)
|
|
(if (nil? (get remote :token)) {} {:authorization (str "Bearer " (get remote :token))})
|
|
body))))
|
|
|
|
; => {:head "heads/..."|nil :refs {name cid}} | nil when unreachable
|
|
(define
|
|
gitea/ls-remote
|
|
(fn
|
|
(remote)
|
|
(let
|
|
((resp (gitea/remote-call remote "GET" "/info/refs" "")))
|
|
(if
|
|
(not (= (dream-status resp) 200))
|
|
nil
|
|
(let
|
|
((lines (let ((s (gitea/pkt-sections (dream-resp-body resp)))) (if (empty? s) (list) (first s)))))
|
|
(reduce
|
|
(fn
|
|
(acc l)
|
|
(let
|
|
((sp (index-of l " ")))
|
|
(if
|
|
(starts-with? l "@ ")
|
|
(assoc acc :head (substr l 2))
|
|
(assoc
|
|
acc
|
|
:refs (assoc
|
|
(get acc :refs)
|
|
(substr l (+ sp 1))
|
|
(substr l 0 sp))))))
|
|
{:refs {} :head nil}
|
|
lines))))))
|
|
|
|
; fetch the closure of `wants` (minus `haves`) into grepo
|
|
(define
|
|
gitea/fetch-pack!
|
|
(fn
|
|
(remote grepo wants haves)
|
|
(let
|
|
((resp (gitea/remote-call remote "POST" "/git-upload-pack" (gitea/pkt-render (list (concat (map (fn (c) (str "want " c)) wants) (map (fn (c) (str "have " c)) haves)))))))
|
|
(if
|
|
(not (= (dream-status resp) 200))
|
|
{:error (dream-status resp)}
|
|
(let
|
|
((s (gitea/pkt-sections (dream-resp-body resp))))
|
|
(gitea/unpack! grepo (if (empty? s) (list) (first s))))))))
|
|
|
|
; mirror-style fetch: pull missing objects, retarget local heads/tags
|
|
; => {:refs ... :stored n} | {:error status}
|
|
(define
|
|
gitea/fetch!
|
|
(fn
|
|
(remote grepo)
|
|
(let
|
|
((ls (gitea/ls-remote remote)))
|
|
(if
|
|
(nil? ls)
|
|
{:error 404}
|
|
(let
|
|
((refs (get ls :refs)))
|
|
(let
|
|
((wants (filter (fn (c) (not (git/has? grepo c))) (map (fn (n) (get refs n)) (keys refs))))
|
|
(haves
|
|
(filter
|
|
(fn (c) (not (nil? c)))
|
|
(map
|
|
(fn (b) (git/branch-get grepo b))
|
|
(git/branches grepo)))))
|
|
(let
|
|
((res (if (empty? wants) {:stored 0} (gitea/fetch-pack! remote grepo wants haves))))
|
|
(if
|
|
(get res :error)
|
|
res
|
|
(begin
|
|
(for-each
|
|
(fn (n) (git/ref-set! grepo n (get refs n)))
|
|
(keys refs))
|
|
{:refs refs :stored (get res :stored)})))))))))
|
|
|
|
; clone a remote into this forge as owner/name; the repo is removed
|
|
; again if the remote turns out to be unreachable
|
|
(define
|
|
gitea/clone!
|
|
(fn
|
|
(forge owner name remote opts)
|
|
(let
|
|
((rec (gitea/repo-create! forge owner name (or opts {}))))
|
|
(if
|
|
(or (get rec :error) (get rec :conflict))
|
|
rec
|
|
(let
|
|
((grepo (gitea/repo-git forge owner name)))
|
|
(let
|
|
((res (gitea/fetch! remote grepo)))
|
|
(if
|
|
(get res :error)
|
|
(begin (gitea/repo-delete! forge owner name) res)
|
|
(let
|
|
((head (get (gitea/ls-remote remote) :head)))
|
|
(begin
|
|
(if
|
|
(and head (starts-with? head "heads/"))
|
|
(let
|
|
((branch (substr head (string-length "heads/"))))
|
|
(begin
|
|
(git/head-set! grepo branch)
|
|
(gitea/repo-update!
|
|
forge
|
|
owner
|
|
name
|
|
(fn (r) (assoc r :default-branch branch)))
|
|
nil))
|
|
nil)
|
|
rec)))))))))
|
|
|
|
; push one ref; => {:ok true} | {:ng reason} | {:error status}
|
|
(define
|
|
gitea/push-cmd!
|
|
(fn
|
|
(remote grepo refname new)
|
|
(let
|
|
((ls (gitea/ls-remote remote)))
|
|
(if
|
|
(nil? ls)
|
|
{:error 404}
|
|
(let
|
|
((old (or (get (get ls :refs) refname) gitea/zero-ref))
|
|
(haves
|
|
(filter
|
|
(fn (c) (git/has? grepo c))
|
|
(map
|
|
(fn (k) (get (get ls :refs) k))
|
|
(keys (get ls :refs))))))
|
|
(let
|
|
((pack (if (equal? new gitea/zero-ref) (list) (gitea/pack-cids grepo (list new) haves))))
|
|
(let
|
|
((resp (gitea/remote-call remote "POST" "/git-receive-pack" (gitea/pkt-render (list (list (str old " " new " " refname)) (map (fn (c) (gitea/pack-line grepo c)) pack))))))
|
|
(if
|
|
(not (= (dream-status resp) 200))
|
|
{:error (dream-status resp)}
|
|
(let
|
|
((lines (let ((s (gitea/pkt-sections (dream-resp-body resp)))) (if (empty? s) (list) (first s)))))
|
|
(let
|
|
((status (first (filter (fn (l) (or (starts-with? l "ok ") (starts-with? l "ng "))) lines))))
|
|
(cond
|
|
((nil? status) {:error "no-status"})
|
|
((starts-with? status "ok ") {:ok true})
|
|
(else {:ng (substr status (+ (index-of (substr status 3) " ") 4))}))))))))))))
|
|
|
|
(define
|
|
gitea/push!
|
|
(fn
|
|
(remote grepo refname)
|
|
(let
|
|
((new (git/ref-get grepo refname)))
|
|
(if (nil? new) {:error "no-such-local-ref"} (gitea/push-cmd! remote grepo refname new)))))
|
|
|
|
(define
|
|
gitea/push-delete!
|
|
(fn
|
|
(remote grepo refname)
|
|
(gitea/push-cmd! remote grepo refname gitea/zero-ref))) |