; 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
(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)}.
; `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 "<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 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)))