giles
d96529effe
lib/gitea/issues.sx: issues as kv records (zero-padded per-repo numbering, title/author/state, sorted label+assignee sets, Markdown body, comment thread). Bodies and comments are content-on-sx documents: content/from-markdown -> block doc -> content/html for pages, with the round-trip law asserted in the suite. The issue graph (issue->repo parent, author origin, assignee member, label link, commenter reply) is DERIVED into lib/relations facts and rebuilt on fact change — same pattern as the acl db, so deleting a repo can never dangle edges. Views: open/closed/by-label/by-assignee; graph queries: repo-issue-nodes, user-authored, user-assigned, label-issues, issue-participants. Web: issues list + issue page (rendered HTML body + comments), JSON API: create (any authenticated reader), comment, close/reopen (author or write), label/assignee management (write). All read-gated like the rest. Infra: gitea/route-packs registry — wire/issues append their routes at load; gitea/app serves all packs. repo-delete! now purges collab/issue/ issue-seq rows too (ghost-state regression tested). Conformance runner gains per-suite extra modules; the issues suite loads relations + smalltalk + content (~5s). Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
555 lines
18 KiB
Plaintext
555 lines
18 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.
|
|
;
|
|
; 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
|
|
(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 ───────────────────────────────────────────────────────────
|
|
|
|
(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 (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)))
|