sx-gitea Phase 3: wire — smart-HTTP protocol over native CIDs (TDD, 272/272)
lib/gitea/wire.sx: git-style pkt-line framing (byte-compatible hex4 lengths + flush sections); object closure walker (commits/trees/blobs/ tags) with missing-object detection; wants/haves pack negotiation. Objects travel as '<cid> <serialized-sx>' pkt lines — receivers re-derive the CID from the bytes, so packs are tamper-evident by construction. Server endpoints: GET info/refs (read-gated advertisement incl. '@ HEAD' symref line), POST git-upload-pack (read), POST git-receive-pack (write; 401/403/404 like the rest of the API) with per-ref command application: create/update/delete via ref-CAS, fast-forward enforcement on heads/*, closure-completeness check, stale detection, heads|tags-only. Client: gitea/remote over any dream app fn — ls-remote, clone! (sets HEAD + default-branch, cleans up on unreachable remote), mirror fetch!, push!/push-delete! with local pack computation. Suite syncs two in-memory forges end to end: clone, incremental fetch, push, non-ff rejection + recovery, branch create/delete, tag push, private-repo credentialed round trip. sx-parse comes from spec/parser.sx on the OCaml server host — added to the conformance load order. Also merged loops/git (git-wire export/ import adapters, 267/267) for future stock-git interop. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
@@ -23,6 +23,7 @@ VERBOSE="${1:-}"
|
|||||||
SUITES=(
|
SUITES=(
|
||||||
"repo|gitea-repo-pass|gitea-repo-fail|gitea-repo-fails"
|
"repo|gitea-repo-pass|gitea-repo-fail|gitea-repo-fails"
|
||||||
"access|gitea-access-pass|gitea-access-fail|gitea-access-fails"
|
"access|gitea-access-pass|gitea-access-fail|gitea-access-fails"
|
||||||
|
"wire|gitea-wire-pass|gitea-wire-fail|gitea-wire-fails"
|
||||||
)
|
)
|
||||||
|
|
||||||
OUT_JSON="lib/gitea/scoreboard.json"
|
OUT_JSON="lib/gitea/scoreboard.json"
|
||||||
@@ -32,6 +33,7 @@ OUT_MD="lib/gitea/scoreboard.md"
|
|||||||
# (types/router/middleware/error/html/json/api), then the gitea modules.
|
# (types/router/middleware/error/html/json/api), then the gitea modules.
|
||||||
MODULES=(
|
MODULES=(
|
||||||
"spec/stdlib.sx"
|
"spec/stdlib.sx"
|
||||||
|
"spec/parser.sx"
|
||||||
"lib/r7rs.sx"
|
"lib/r7rs.sx"
|
||||||
"lib/persist/event.sx"
|
"lib/persist/event.sx"
|
||||||
"lib/persist/backend.sx"
|
"lib/persist/backend.sx"
|
||||||
@@ -69,6 +71,7 @@ MODULES=(
|
|||||||
"lib/gitea/repo.sx"
|
"lib/gitea/repo.sx"
|
||||||
"lib/gitea/access.sx"
|
"lib/gitea/access.sx"
|
||||||
"lib/gitea/web.sx"
|
"lib/gitea/web.sx"
|
||||||
|
"lib/gitea/wire.sx"
|
||||||
)
|
)
|
||||||
|
|
||||||
run_suite() {
|
run_suite() {
|
||||||
|
|||||||
@@ -1,9 +1,10 @@
|
|||||||
{
|
{
|
||||||
"suites": {
|
"suites": {
|
||||||
"repo": {"pass": 91, "fail": 0},
|
"repo": {"pass": 91, "fail": 0},
|
||||||
"access": {"pass": 103, "fail": 0}
|
"access": {"pass": 103, "fail": 0},
|
||||||
|
"wire": {"pass": 78, "fail": 0}
|
||||||
},
|
},
|
||||||
"total_pass": 194,
|
"total_pass": 272,
|
||||||
"total_fail": 0,
|
"total_fail": 0,
|
||||||
"total": 194
|
"total": 272
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -6,4 +6,5 @@ _Generated by `lib/gitea/conformance.sh`_
|
|||||||
|-------|-----:|-----:|------:|
|
|-------|-----:|-----:|------:|
|
||||||
| repo | 91 | 0 | 91 |
|
| repo | 91 | 0 | 91 |
|
||||||
| access | 103 | 0 | 103 |
|
| access | 103 | 0 | 103 |
|
||||||
| **Total** | **194** | **0** | **194** |
|
| wire | 78 | 0 | 78 |
|
||||||
|
| **Total** | **272** | **0** | **272** |
|
||||||
|
|||||||
490
lib/gitea/tests/wire.sx
Normal file
490
lib/gitea/tests/wire.sx
Normal file
@@ -0,0 +1,490 @@
|
|||||||
|
; 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)
|
||||||
555
lib/gitea/wire.sx
Normal file
555
lib/gitea/wire.sx
Normal file
@@ -0,0 +1,555 @@
|
|||||||
|
; 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 (added to the web routes by gitea/forge-routes):
|
||||||
|
; 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.
|
||||||
|
;
|
||||||
|
; 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.
|
||||||
|
|
||||||
|
; ── 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
|
||||||
|
(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))))
|
||||||
|
(if
|
||||||
|
(= n 0)
|
||||||
|
(gitea/pkt-sections-loop
|
||||||
|
data
|
||||||
|
(+ i 4)
|
||||||
|
(list)
|
||||||
|
(cons (reverse cur) sections))
|
||||||
|
(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)}
|
||||||
|
(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))
|
||||||
|
(gitea/closure-walk
|
||||||
|
grepo
|
||||||
|
(concat (gitea/obj-refs obj) more)
|
||||||
|
(assoc seen cid true)
|
||||||
|
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`
|
||||||
|
(define
|
||||||
|
gitea/pack-cids
|
||||||
|
(fn
|
||||||
|
(grepo wants haves)
|
||||||
|
(let
|
||||||
|
((have-set (gitea/closure grepo haves)))
|
||||||
|
(filter
|
||||||
|
(fn (c) (not (get have-set c)))
|
||||||
|
(gitea/closure-list grepo wants)))))
|
||||||
|
|
||||||
|
; ── wire object encoding ─────────────────────────────────────────────
|
||||||
|
|
||||||
|
(define
|
||||||
|
gitea/pack-line
|
||||||
|
(fn (grepo cid) (str cid " " (serialize (git/read grepo cid)))))
|
||||||
|
|
||||||
|
; 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 (first (sx-parse (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: web + wire ───────────────────────────────────────────────
|
||||||
|
|
||||||
|
(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))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gitea/forge-routes
|
||||||
|
(fn (forge) (concat (gitea/routes forge) (gitea/wire-routes forge))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
gitea/forge-app
|
||||||
|
(fn (forge) (dream-make-app (gitea/forge-routes forge))))
|
||||||
|
|
||||||
|
; ── client ───────────────────────────────────────────────────────────
|
||||||
|
; A remote is any dream app fn plus repo coordinates and a token — the
|
||||||
|
; same code drives an in-memory forge or (later) a real HTTP transport.
|
||||||
|
|
||||||
|
(define gitea/remote (fn (app owner name token) {:name name :token token :owner owner :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)))
|
||||||
|
(let
|
||||||
|
((pack (if (equal? new gitea/zero-ref) (list) (gitea/pack-cids grepo (list new) (if (equal? old gitea/zero-ref) (list) (list old))))))
|
||||||
|
(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)))
|
||||||
Reference in New Issue
Block a user