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>
522 lines
15 KiB
Plaintext
522 lines
15 KiB
Plaintext
; lib/gitea/tests/wire.sx — Phase 3: pkt-line framing, object closure,
|
|
; smart-HTTP endpoints (info/refs, upload-pack, receive-pack), and the
|
|
; client (ls-remote/clone!/fetch!/push!) syncing two in-memory forges.
|
|
|
|
(define gitea-wire-pass 0)
|
|
(define gitea-wire-fail 0)
|
|
(define gitea-wire-fails (list))
|
|
|
|
(define
|
|
gitea-wire-test
|
|
(fn
|
|
(name actual expected)
|
|
(if
|
|
(= actual expected)
|
|
(set! gitea-wire-pass (+ gitea-wire-pass 1))
|
|
(begin
|
|
(set! gitea-wire-fail (+ gitea-wire-fail 1))
|
|
(set! gitea-wire-fails (append gitea-wire-fails (list {:name name :expected (inspect expected) :actual (inspect actual)})))))))
|
|
|
|
; ── pkt-line framing ─────────────────────────────────────────────────
|
|
|
|
(gitea-wire-test "hex4 small" (gitea/hex4 5) "0005")
|
|
(gitea-wire-test "hex4 max" (gitea/hex4 65535) "ffff")
|
|
(gitea-wire-test "hex4-parse" (gitea/hex4-parse "001a") 26)
|
|
(gitea-wire-test
|
|
"hex4 round trip"
|
|
(gitea/hex4-parse (gitea/hex4 4242))
|
|
4242)
|
|
(gitea-wire-test "pkt frames with length" (gitea/pkt "hi") "0006hi")
|
|
(gitea-wire-test
|
|
"pkt-sections round trip"
|
|
(gitea/pkt-sections (gitea/pkt-render (list (list "a" "bc") (list "z"))))
|
|
(list (list "a" "bc") (list "z")))
|
|
(gitea-wire-test "pkt-sections empty" (gitea/pkt-sections "") (list))
|
|
(gitea-wire-test
|
|
"pkt-sections flush only"
|
|
(gitea/pkt-sections "0000")
|
|
(list (list)))
|
|
(gitea-wire-test "pkt-fits? small" (gitea/pkt-fits? "x") true)
|
|
|
|
(define
|
|
gw-big
|
|
(reduce
|
|
(fn (acc i) (str acc acc))
|
|
"xxxxxxxxxx"
|
|
(list
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13)))
|
|
(gitea-wire-test "pkt-fits? huge payload" (gitea/pkt-fits? gw-big) false)
|
|
|
|
; ── forge A with history ─────────────────────────────────────────────
|
|
|
|
(define gw-db (persist/mem-backend))
|
|
(define gw-forge (gitea/forge gw-db))
|
|
(gitea/user-create! gw-forge "alice")
|
|
(gitea/user-create! gw-forge "bob")
|
|
(gitea/user-create! gw-forge "rope")
|
|
(gitea/token-create! gw-forge "alice" "tok-a")
|
|
(gitea/token-create! gw-forge "bob" "tok-b")
|
|
(gitea/token-create! gw-forge "rope" "tok-r")
|
|
(gitea/repo-create! gw-forge "alice" "lib" {})
|
|
(gitea/collab-add! gw-forge "alice" "lib" "rope" "read")
|
|
|
|
(define gw-ga (gitea/repo-git gw-forge "alice" "lib"))
|
|
(git/add! gw-ga "README.md" "hello\n")
|
|
(git/add! gw-ga "src/a.txt" "alpha\n")
|
|
(define gw-c1 (git/commit! gw-ga {:message "init" :time 1 :author "alice"}))
|
|
(git/add! gw-ga "src/a.txt" "alpha2\n")
|
|
(define gw-c2 (git/commit! gw-ga {:message "more" :time 2 :author "alice"}))
|
|
(git/tag! gw-ga "v1" {:message "rel" :time 3})
|
|
(define gw-tag-cid (git/tag-get gw-ga "v1"))
|
|
(git/branch-create! gw-ga "dev" gw-c1)
|
|
|
|
; ── closure ──────────────────────────────────────────────────────────
|
|
|
|
; c1 = commit + root tree + src tree + 2 blobs
|
|
(gitea-wire-test
|
|
"closure of c1"
|
|
(len (gitea/closure-list gw-ga (list gw-c1)))
|
|
5)
|
|
; c2 adds commit + new root + new src + new blob
|
|
(gitea-wire-test
|
|
"closure of c2"
|
|
(len (gitea/closure-list gw-ga (list gw-c2)))
|
|
9)
|
|
(gitea-wire-test
|
|
"pack-cids c2 given c1"
|
|
(len (gitea/pack-cids gw-ga (list gw-c2) (list gw-c1)))
|
|
4)
|
|
(gitea-wire-test
|
|
"pack includes tip commit"
|
|
(contains? (gitea/pack-cids gw-ga (list gw-c2) (list gw-c1)) gw-c2)
|
|
true)
|
|
(gitea-wire-test
|
|
"pack excludes had commit"
|
|
(contains? (gitea/pack-cids gw-ga (list gw-c2) (list gw-c1)) gw-c1)
|
|
false)
|
|
(gitea-wire-test
|
|
"closure through tag object"
|
|
(len (gitea/closure-list gw-ga (list gw-tag-cid)))
|
|
10)
|
|
(gitea-wire-test
|
|
"closure-complete? tip"
|
|
(gitea/closure-complete? gw-ga (list gw-c2))
|
|
true)
|
|
(gitea-wire-test
|
|
"closure-complete? missing cid"
|
|
(gitea/closure-complete? gw-ga (list "sx1:doesnotexist"))
|
|
false)
|
|
(gitea-wire-test
|
|
"obj-refs of commit"
|
|
(len (gitea/obj-refs (git/read gw-ga gw-c2)))
|
|
2)
|
|
|
|
; ── pack line verification ───────────────────────────────────────────
|
|
|
|
(gitea-wire-test
|
|
"pack-line parses and verifies"
|
|
(get (gitea/pack-line-parse (gitea/pack-line gw-ga gw-c1)) :cid)
|
|
gw-c1)
|
|
(gitea-wire-test
|
|
"pack-line tamper detected"
|
|
(get
|
|
(gitea/pack-line-parse (str gw-c1 " " (serialize (git/blob "evil"))))
|
|
:error)
|
|
"cid-mismatch")
|
|
(gitea-wire-test
|
|
"unpack! rejects tampered pack"
|
|
(get
|
|
(gitea/unpack!
|
|
gw-ga
|
|
(list (str gw-c1 " " (serialize (git/blob "evil")))))
|
|
:error)
|
|
"cid-mismatch")
|
|
|
|
; ── server endpoints ─────────────────────────────────────────────────
|
|
|
|
(define gw-app (gitea/forge-app gw-forge))
|
|
(define gw-hdr (fn (tok) (if (nil? tok) {} {:authorization (str "Bearer " tok)})))
|
|
(define
|
|
gw-get
|
|
(fn (target tok) (gw-app (dream-request "GET" target (gw-hdr tok) ""))))
|
|
(define
|
|
gw-post
|
|
(fn
|
|
(target tok body)
|
|
(gw-app (dream-request "POST" target (gw-hdr tok) body))))
|
|
|
|
(gitea-wire-test
|
|
"info/refs 200"
|
|
(dream-status (gw-get "/alice/lib/info/refs" nil))
|
|
200)
|
|
(gitea-wire-test
|
|
"info/refs advertises main"
|
|
(contains?
|
|
(dream-resp-body (gw-get "/alice/lib/info/refs" nil))
|
|
(str gw-c2 " heads/main"))
|
|
true)
|
|
(gitea-wire-test
|
|
"info/refs advertises dev"
|
|
(contains?
|
|
(dream-resp-body (gw-get "/alice/lib/info/refs" nil))
|
|
(str gw-c1 " heads/dev"))
|
|
true)
|
|
(gitea-wire-test
|
|
"info/refs advertises tag"
|
|
(contains?
|
|
(dream-resp-body (gw-get "/alice/lib/info/refs" nil))
|
|
(str gw-tag-cid " tags/v1"))
|
|
true)
|
|
(gitea-wire-test
|
|
"info/refs advertises HEAD"
|
|
(contains?
|
|
(dream-resp-body (gw-get "/alice/lib/info/refs" nil))
|
|
"@ heads/main")
|
|
true)
|
|
(gitea-wire-test
|
|
"info/refs unknown repo 404"
|
|
(dream-status (gw-get "/alice/none/info/refs" nil))
|
|
404)
|
|
|
|
(define
|
|
gw-up-body
|
|
(fn
|
|
(wants haves)
|
|
(gitea/pkt-render
|
|
(list
|
|
(concat
|
|
(map (fn (c) (str "want " c)) wants)
|
|
(map (fn (c) (str "have " c)) haves))))))
|
|
|
|
(define
|
|
gw-up-lines
|
|
(fn
|
|
(resp)
|
|
(let
|
|
((s (gitea/pkt-sections (dream-resp-body resp))))
|
|
(if (empty? s) (list) (first s)))))
|
|
|
|
(gitea-wire-test
|
|
"upload-pack full clone size"
|
|
(len
|
|
(gw-up-lines
|
|
(gw-post
|
|
"/alice/lib/git-upload-pack"
|
|
nil
|
|
(gw-up-body (list gw-c2) (list)))))
|
|
9)
|
|
(gitea-wire-test
|
|
"upload-pack incremental size"
|
|
(len
|
|
(gw-up-lines
|
|
(gw-post
|
|
"/alice/lib/git-upload-pack"
|
|
nil
|
|
(gw-up-body (list gw-c2) (list gw-c1)))))
|
|
4)
|
|
(gitea-wire-test
|
|
"upload-pack lines all verify"
|
|
(len
|
|
(filter
|
|
(fn (l) (get (gitea/pack-line-parse l) :error))
|
|
(gw-up-lines
|
|
(gw-post
|
|
"/alice/lib/git-upload-pack"
|
|
nil
|
|
(gw-up-body (list gw-c2) (list))))))
|
|
0)
|
|
|
|
(gitea-wire-test
|
|
"receive-pack anon 401"
|
|
(dream-status
|
|
(gw-post
|
|
"/alice/lib/git-receive-pack"
|
|
nil
|
|
(gitea/pkt-render (list (list) (list)))))
|
|
401)
|
|
(gitea-wire-test
|
|
"receive-pack read-only 403"
|
|
(dream-status
|
|
(gw-post
|
|
"/alice/lib/git-receive-pack"
|
|
"tok-r"
|
|
(gitea/pkt-render (list (list) (list)))))
|
|
403)
|
|
|
|
; private repo wire gating
|
|
(gitea/repo-create! gw-forge "alice" "priv" {:visibility "private"})
|
|
(define gw-gp (gitea/repo-git gw-forge "alice" "priv"))
|
|
(git/add! gw-gp "p.txt" "private\n")
|
|
(git/commit! gw-gp {:message "p" :time 1 :author "alice"})
|
|
|
|
(gitea-wire-test
|
|
"private info/refs anon 404"
|
|
(dream-status (gw-get "/alice/priv/info/refs" nil))
|
|
404)
|
|
(gitea-wire-test
|
|
"private info/refs owner 200"
|
|
(dream-status (gw-get "/alice/priv/info/refs" "tok-a"))
|
|
200)
|
|
(gitea-wire-test
|
|
"private upload-pack anon 404"
|
|
(dream-status
|
|
(gw-post "/alice/priv/git-upload-pack" nil (gw-up-body (list) (list))))
|
|
404)
|
|
|
|
; ── client: ls-remote ────────────────────────────────────────────────
|
|
|
|
(define gw-remote-anon (gitea/remote gw-app "alice" "lib" nil))
|
|
(define gw-remote-bob (gitea/remote gw-app "alice" "lib" "tok-b"))
|
|
(define gw-remote-rope (gitea/remote gw-app "alice" "lib" "tok-r"))
|
|
|
|
(define gw-ls (gitea/ls-remote gw-remote-anon))
|
|
(gitea-wire-test "ls-remote head" (get gw-ls :head) "heads/main")
|
|
(gitea-wire-test "ls-remote main" (get (get gw-ls :refs) "heads/main") gw-c2)
|
|
(gitea-wire-test "ls-remote dev" (get (get gw-ls :refs) "heads/dev") gw-c1)
|
|
(gitea-wire-test
|
|
"ls-remote tag"
|
|
(get (get gw-ls :refs) "tags/v1")
|
|
gw-tag-cid)
|
|
(gitea-wire-test
|
|
"ls-remote unknown repo"
|
|
(gitea/ls-remote (gitea/remote gw-app "alice" "none" nil))
|
|
nil)
|
|
|
|
; ── client: clone into forge B ───────────────────────────────────────
|
|
|
|
(define gw-db2 (persist/mem-backend))
|
|
(define gw-forge2 (gitea/forge gw-db2))
|
|
(gitea/user-create! gw-forge2 "bob")
|
|
|
|
(define
|
|
gw-clone
|
|
(gitea/clone! gw-forge2 "bob" "lib" gw-remote-anon {}))
|
|
(gitea-wire-test "clone returns record" (get gw-clone :owner) "bob")
|
|
|
|
(define gw-gb (gitea/repo-git gw-forge2 "bob" "lib"))
|
|
(gitea-wire-test "clone main" (git/branch-get gw-gb "main") gw-c2)
|
|
(gitea-wire-test "clone dev" (git/branch-get gw-gb "dev") gw-c1)
|
|
(gitea-wire-test "clone tag" (git/tag-get gw-gb "v1") gw-tag-cid)
|
|
(gitea-wire-test "clone HEAD" (git/head-target gw-gb) "heads/main")
|
|
(gitea-wire-test
|
|
"clone default branch recorded"
|
|
(get (gitea/repo-get gw-forge2 "bob" "lib") :default-branch)
|
|
"main")
|
|
(gitea-wire-test "clone log" (git/log gw-gb gw-c2) (list gw-c2 gw-c1))
|
|
(gitea-wire-test
|
|
"clone blob content"
|
|
(git/blob-data
|
|
(git/read gw-gb (get (gitea/tree-at gw-gb gw-c2 "src/a.txt") :cid)))
|
|
"alpha2\n")
|
|
(gitea-wire-test
|
|
"clone closure complete"
|
|
(gitea/closure-complete? gw-gb (list gw-c2))
|
|
true)
|
|
(gitea-wire-test
|
|
"clone again conflicts"
|
|
(get
|
|
(gitea/clone! gw-forge2 "bob" "lib" gw-remote-anon {})
|
|
:conflict)
|
|
true)
|
|
(gitea-wire-test
|
|
"clone unreachable remote errors"
|
|
(get
|
|
(gitea/clone!
|
|
gw-forge2
|
|
"bob"
|
|
"ghost"
|
|
(gitea/remote gw-app "alice" "none" nil)
|
|
{})
|
|
:error)
|
|
404)
|
|
(gitea-wire-test
|
|
"failed clone leaves no repo"
|
|
(gitea/repo-exists? gw-forge2 "bob" "ghost")
|
|
false)
|
|
|
|
; ── client: fetch after upstream moves ───────────────────────────────
|
|
|
|
(git/add! gw-ga "src/c.txt" "gamma\n")
|
|
(define gw-c3 (git/commit! gw-ga {:message "third" :time 4 :author "alice"}))
|
|
|
|
(define gw-fetch1 (gitea/fetch! gw-remote-anon gw-gb))
|
|
(gitea-wire-test
|
|
"fetch stores new objects"
|
|
(> (get gw-fetch1 :stored) 0)
|
|
true)
|
|
(gitea-wire-test "fetch moves main" (git/branch-get gw-gb "main") gw-c3)
|
|
(gitea-wire-test
|
|
"fetch closure complete"
|
|
(gitea/closure-complete? gw-gb (list gw-c3))
|
|
true)
|
|
(gitea-wire-test
|
|
"fetch up-to-date is no-op"
|
|
(get (gitea/fetch! gw-remote-anon gw-gb) :stored)
|
|
0)
|
|
|
|
; ── client: push ─────────────────────────────────────────────────────
|
|
|
|
; bob gets write on the upstream, commits locally, pushes
|
|
(gitea/collab-add! gw-forge "alice" "lib" "bob" "write")
|
|
(git/checkout! gw-gb "main")
|
|
(git/add! gw-gb "src/b.txt" "beta\n")
|
|
(define gw-c4 (git/commit! gw-gb {:message "from-bob" :time 5 :author "bob"}))
|
|
|
|
(gitea-wire-test
|
|
"push ok"
|
|
(get (gitea/push! gw-remote-bob gw-gb "heads/main") :ok)
|
|
true)
|
|
(gitea-wire-test
|
|
"push moved upstream main"
|
|
(git/branch-get gw-ga "main")
|
|
gw-c4)
|
|
(gitea-wire-test
|
|
"upstream has pushed objects"
|
|
(gitea/closure-complete? gw-ga (list gw-c4))
|
|
true)
|
|
|
|
; push auth: anon 401, read-only 403
|
|
(gitea-wire-test
|
|
"push anon rejected"
|
|
(get (gitea/push! gw-remote-anon gw-gb "heads/main") :error)
|
|
401)
|
|
(gitea-wire-test
|
|
"push read-only rejected"
|
|
(get (gitea/push! gw-remote-rope gw-gb "heads/main") :error)
|
|
403)
|
|
|
|
; non-fast-forward: upstream moves on while bob commits on the old tip
|
|
(git/checkout! gw-ga "main")
|
|
(git/add! gw-ga "src/d.txt" "delta\n")
|
|
(define gw-c5 (git/commit! gw-ga {:message "upstream-moves" :time 6 :author "alice"}))
|
|
|
|
(git/add! gw-gb "src/e.txt" "eps\n")
|
|
(define gw-c4b (git/commit! gw-gb {:message "bob-diverges" :time 7 :author "bob"}))
|
|
|
|
(gitea-wire-test
|
|
"push non-fast-forward rejected"
|
|
(get (gitea/push! gw-remote-bob gw-gb "heads/main") :ng)
|
|
"non-fast-forward")
|
|
(gitea-wire-test
|
|
"upstream main unchanged after ng"
|
|
(git/branch-get gw-ga "main")
|
|
gw-c5)
|
|
|
|
; recover: fetch (mirror moves local main to upstream), rebuild, push
|
|
(gitea/fetch! gw-remote-bob gw-gb)
|
|
(gitea-wire-test
|
|
"fetch after ng syncs main"
|
|
(git/branch-get gw-gb "main")
|
|
gw-c5)
|
|
(git/checkout! gw-gb "main")
|
|
(git/add! gw-gb "src/e.txt" "eps\n")
|
|
(define gw-c6 (git/commit! gw-gb {:message "bob-rebased" :time 8 :author "bob"}))
|
|
(gitea-wire-test
|
|
"push after sync ok"
|
|
(get (gitea/push! gw-remote-bob gw-gb "heads/main") :ok)
|
|
true)
|
|
(gitea-wire-test
|
|
"upstream at bob's rebased tip"
|
|
(git/branch-get gw-ga "main")
|
|
gw-c6)
|
|
|
|
; branch create / delete over the wire
|
|
(git/branch-create! gw-gb "feat" gw-c6)
|
|
(gitea-wire-test
|
|
"push new branch"
|
|
(get (gitea/push! gw-remote-bob gw-gb "heads/feat") :ok)
|
|
true)
|
|
(gitea-wire-test
|
|
"upstream sees new branch"
|
|
(git/branch-get gw-ga "feat")
|
|
gw-c6)
|
|
(gitea-wire-test
|
|
"push delete branch"
|
|
(get (gitea/push-delete! gw-remote-bob gw-gb "heads/feat") :ok)
|
|
true)
|
|
(gitea-wire-test "upstream branch deleted" (git/branch-get gw-ga "feat") nil)
|
|
|
|
; tag push
|
|
(git/tag-lightweight! gw-gb "v2")
|
|
(gitea-wire-test
|
|
"push tag"
|
|
(get (gitea/push! gw-remote-bob gw-gb "tags/v2") :ok)
|
|
true)
|
|
(gitea-wire-test "upstream sees tag" (git/tag-get gw-ga "v2") gw-c6)
|
|
|
|
; guard rails
|
|
(gitea-wire-test
|
|
"push unknown local ref"
|
|
(get (gitea/push! gw-remote-bob gw-gb "heads/nope") :error)
|
|
"no-such-local-ref")
|
|
(gitea-wire-test
|
|
"apply-cmd rejects non-shared ref"
|
|
(gitea/apply-cmd! gw-ga {:name "bogus/x" :new gw-c1 :old "-"})
|
|
"ng bogus/x invalid-ref")
|
|
(gitea-wire-test
|
|
"apply-cmd rejects missing objects"
|
|
(gitea/apply-cmd! gw-ga {:name "heads/zzz" :new "sx1:missing" :old "-"})
|
|
"ng heads/zzz missing-objects")
|
|
|
|
; private repo full round trip with credentials
|
|
(define gw-remote-priv (gitea/remote gw-app "alice" "priv" "tok-a"))
|
|
(gitea/user-create! gw-forge2 "alice")
|
|
(define
|
|
gw-pclone
|
|
(gitea/clone! gw-forge2 "alice" "priv" gw-remote-priv {:visibility "private"}))
|
|
(gitea-wire-test "private clone with token" (get gw-pclone :owner) "alice")
|
|
(gitea-wire-test
|
|
"private clone anon fails"
|
|
(get
|
|
(gitea/clone!
|
|
gw-forge2
|
|
"alice"
|
|
"priv2"
|
|
(gitea/remote gw-app "alice" "priv" nil)
|
|
{})
|
|
:error)
|
|
404)
|
|
|
|
(gitea-wire-test
|
|
"pkt-sections malformed len errors"
|
|
(guard (e (true "errored")) (gitea/pkt-sections "zzzzzzzz"))
|
|
"errored")
|
|
|
|
(gitea-wire-test
|
|
"pkt-sections truncated pkt clamps"
|
|
(guard (e (true "errored")) (gitea/pkt-sections "0009hi"))
|
|
(list (list "hi")))
|
|
|
|
(define gw-po-blob (serialize (git/blob "hello \"quoted\" \n multiline")))
|
|
|
|
(define
|
|
gw-po-commit
|
|
(serialize (git/commit "sx1:tree" (list "sx1:p1" "sx1:p2") {:message "m" :author "a" :time 42})))
|
|
|
|
(gitea-wire-test
|
|
"parse-obj blob = sx-parse"
|
|
(gitea/parse-obj gw-po-blob)
|
|
(first (sx-parse gw-po-blob)))
|
|
|
|
(gitea-wire-test
|
|
"parse-obj commit = sx-parse"
|
|
(gitea/parse-obj gw-po-commit)
|
|
(first (sx-parse gw-po-commit)))
|
|
|
|
(gitea-wire-test
|
|
"parse-obj cid stable"
|
|
(git/cid (gitea/parse-obj gw-po-commit))
|
|
(git/cid (first (sx-parse gw-po-commit))))
|