rose-ash/lib/gitea/pr.sx

; lib/gitea/pr.sx — sx-gitea Phase 5: pull requests.
;
; A PR is a kv record: source branch -> target branch, title/author/body
; (Markdown, rendered via content like issues), a review thread (latest
; verdict per reviewer wins), and a merge outcome. Numbers share the
; per-repo counter with issues (gitea/issue-next!), GitHub-style.
;
; The diff is always LIVE — computed with sx-git from the merge base of
; the current branch heads to the source head (so a target that moved on
; never shows spurious deletions), never stored.
;
; Lifecycle is a lib/flow durable workflow (deterministic-replay
; suspend): open -(approval)-> approved -(merge)-> merged. review! resumes
; the approval suspend when the verdict set first becomes approving;
; merge!/close! resume/cancel the rest. The flow env lives in the forge
; handle; the record's :state stays the source of truth (merge re-checks
; approval live — the flow is the durable journal of the lifecycle).
;
; Merging uses git/merge-commits (3-way over the merge base): up-to-date
; and fast-forward move nothing or just the ref; a true merge writes a
; two-parent commit; conflicts abort with the conflicting paths. All ref
; moves go through branch-cas! — a concurrent push surfaces as "stale".
;
; The merge queue is a per-repo list of approved PR numbers;
; queue-process! merges them in order, keeping the failures queued.
;
; Requires: lib/gitea/{repo,access,web,issues}.sx and their stacks, plus
; the flow stack (lib/guest/lex, lib/guest/reflective/{env,quoting},
; lib/scheme/{parser,eval,runtime}, lib/flow/{spec,store,remote,host,api}).

; ── record plumbing ──────────────────────────────────────────────────

(define
  gitea/pr-key
  (fn (owner name n) (str "gitea/pr/" owner "/" name "/" (gitea/pad8 n))))

(define
  gitea/pr-get
  (fn
    (forge owner name n)
    (persist/kv-get (gitea/forge-db forge) (gitea/pr-key owner name n))))

(define
  gitea/prs
  (fn
    (forge owner name)
    (map
      (fn (s) (parse-int s))
      (gitea/names-under forge (str "gitea/pr/" owner "/" name "/")))))

(define
  gitea/pr-records
  (fn
    (forge owner name)
    (map
      (fn (n) (gitea/pr-get forge owner name n))
      (gitea/prs forge owner name))))

(define
  gitea/pr-update!
  (fn
    (forge owner name n f)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (if
        (nil? rec)
        nil
        (persist/kv-put
          (gitea/forge-db forge)
          (gitea/pr-key owner name n)
          (f rec))))))

; ── the lifecycle flow ───────────────────────────────────────────────

(define
  gitea/pr-flow-src
  "(defflow pr-lifecycle (sequence (flow-node (lambda (x) (suspend (quote approval)))) (flow-node (lambda (x) (suspend (quote merge)))) (flow-node (lambda (x) (quote merged)))))")

(define
  gitea/flow-env
  (fn
    (forge)
    (let
      ((cache (get forge :cache)))
      (if
        (and cache (get cache "flow-env"))
        (get cache "flow-env")
        (let
          ((env (flow-make-env)))
          (begin
            (flow-run-in env gitea/pr-flow-src)
            (if cache (dict-set! cache "flow-env" env) nil)
            env))))))

; => flow id (int) | nil
(define
  gitea/pr-flow-start!
  (fn
    (forge n)
    (let
      ((res (flow-run-in (gitea/flow-env forge) (str "(flow/start pr-lifecycle " n ")"))))
      (if
        (and (list? res) (>= (len res) 2))
        (nth res 1)
        nil))))

(define
  gitea/flow-pending-tag
  (fn
    (forge fid)
    (let
      ((pending (flow-run-in (gitea/flow-env forge) "(flow/pending)")))
      (reduce
        (fn
          (acc p)
          (if
            (and (list? p) (= (first p) fid))
            (str (nth p 1))
            acc))
        nil
        pending))))

(define
  gitea/pr-flow-resume!
  (fn
    (forge fid value)
    (flow-run-in
      (gitea/flow-env forge)
      (str "(flow/resume " fid " (quote " value "))"))))

(define
  gitea/pr-flow-cancel!
  (fn
    (forge fid)
    (flow-run-in (gitea/flow-env forge) (str "(flow/cancel " fid ")"))))

; lifecycle stage as seen from the durable flow
(define
  gitea/pr-flow-status
  (fn
    (forge rec)
    (let
      ((fid (get rec :flow-id)))
      (if
        (nil? fid)
        "none"
        (let
          ((st (str (flow-run-in (gitea/flow-env forge) (str "(flow/status " fid ")")))))
          (cond
            ((= st "done") "merged")
            ((= st "cancelled") "closed")
            ((= st "suspended")
              (let
                ((tag (gitea/flow-pending-tag forge fid)))
                (cond
                  ((= tag "approval") "review")
                  ((= tag "merge") "approved")
                  (else "suspended"))))
            (else st)))))))

; ── create ───────────────────────────────────────────────────────────

(define
  gitea/pr-create!
  (fn
    (forge owner name author title source target body opts)
    (cond
      ((not (gitea/repo-exists? forge owner name)) {:error "no-such-repo"})
      ((not (gitea/owner-exists? forge author)) {:error "no-such-user"})
      ((or (not (string? title)) (= title "")) {:error "empty-title"})
      ((= source target) {:error "same-branch"})
      (else
        (let
          ((grepo (gitea/repo-git forge owner name)))
          (cond
            ((nil? (git/branch-get grepo source)) {:error "no-such-source"})
            ((nil? (git/branch-get grepo target)) {:error "no-such-target"})
            (else
              (let
                ((o (or opts {})))
                (let
                  ((n (gitea/issue-next! forge owner name)))
                  (let
                    ((rec {:source source :state "open" :title title :merge-cid nil :reviews (list) :body (or body "") :number n :author author :created-at (or (get o :created-at) 0) :target target :flow-id (gitea/pr-flow-start! forge n)}))
                    (begin
                      (persist/kv-put
                        (gitea/forge-db forge)
                        (gitea/pr-key owner name n)
                        rec)
                      rec)))))))))))

; ── live diff (merge base -> source head) ────────────────────────────

(define
  gitea/pr-heads
  (fn
    (forge owner name rec)
    (let
      ((grepo (gitea/repo-git forge owner name)))
      (let
        ((tcid (git/branch-get grepo (get rec :target)))
          (scid (git/branch-get grepo (get rec :source))))
        {:base-cid (if (or (nil? tcid) (nil? scid)) nil (or (git/merge-base grepo tcid scid) tcid)) :grepo grepo :target-cid tcid :source-cid scid}))))

; {:added :modified :deleted} from the merge base to the source head
(define
  gitea/pr-diff
  (fn
    (forge owner name n)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (if
        (nil? rec)
        nil
        (let
          ((h (gitea/pr-heads forge owner name rec)))
          (if
            (or (nil? (get h :base-cid)) (nil? (get h :source-cid)))
            nil
            (git/commit-diff
              (get h :grepo)
              (get h :base-cid)
              (get h :source-cid))))))))

(define
  gitea/pr-diff-unified
  (fn
    (forge owner name n)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (if
        (nil? rec)
        nil
        (let
          ((h (gitea/pr-heads forge owner name rec)))
          (if
            (or (nil? (get h :base-cid)) (nil? (get h :source-cid)))
            nil
            (git/commit-diff-unified
              (get h :grepo)
              (get h :base-cid)
              (get h :source-cid))))))))

; ── reviews ──────────────────────────────────────────────────────────

(define gitea/pr-verdicts (list "approve" "request-changes"))

; latest verdict per reviewer
(define
  gitea/pr-latest-verdicts
  (fn
    (rec)
    (reduce
      (fn (acc r) (assoc acc (get r :reviewer) (get r :verdict)))
      {}
      (get rec :reviews))))

(define
  gitea/pr-approved?
  (fn
    (rec)
    (let
      ((latest (gitea/pr-latest-verdicts rec)))
      (let
        ((vs (map (fn (k) (get latest k)) (keys latest))))
        (and
          (contains? vs "approve")
          (not (contains? vs "request-changes")))))))

; resume the approval suspend the first time the verdict set approves
(define
  gitea/pr-sync-flow!
  (fn
    (forge owner name n)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (if
        (and
          rec
          (gitea/pr-approved? rec)
          (not (nil? (get rec :flow-id)))
          (= (gitea/flow-pending-tag forge (get rec :flow-id)) "approval"))
        (begin
          (gitea/pr-flow-resume! forge (get rec :flow-id) "approved")
          true)
        false))))

(define
  gitea/pr-review!
  (fn
    (forge owner name n reviewer verdict body opts)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (cond
        ((nil? rec) {:error "no-such-pr"})
        ((not (= (get rec :state) "open")) {:error "not-open"})
        ((not (gitea/owner-exists? forge reviewer)) {:error "no-such-user"})
        ((= reviewer (get rec :author)) {:error "own-pr"})
        ((not (contains? gitea/pr-verdicts verdict)) {:error "invalid-verdict"})
        (else
          (let
            ((review {:verdict verdict :body (or body "") :at (or (get (or opts {}) :at) 0) :reviewer reviewer}))
            (begin
              (gitea/pr-update!
                forge
                owner
                name
                n
                (fn
                  (r)
                  (assoc r :reviews (append (get r :reviews) (list review)))))
              (gitea/pr-sync-flow! forge owner name n)
              review)))))))

; ── merge ────────────────────────────────────────────────────────────

(define
  gitea/pr-mark-merged!
  (fn
    (forge owner name n cid)
    (let
      ((rec (gitea/pr-update! forge owner name n (fn (r) (assoc (assoc r :state "merged") :merge-cid cid)))))
      (begin
        (if
          (and
            rec
            (not (nil? (get rec :flow-id)))
            (= (gitea/flow-pending-tag forge (get rec :flow-id)) "merge"))
          (gitea/pr-flow-resume! forge (get rec :flow-id) "merged")
          nil)
        rec))))

(define
  gitea/pr-merge!
  (fn
    (forge owner name n merger opts)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (cond
        ((nil? rec) {:error "no-such-pr"})
        ((not (= (get rec :state) "open")) {:error "not-open"})
        ((not (gitea/pr-approved? rec)) {:error "not-approved"})
        (else
          (let
            ((h (gitea/pr-heads forge owner name rec)))
            (let
              ((grepo (get h :grepo))
                (tcid (get h :target-cid))
                (scid (get h :source-cid)))
              (cond
                ((or (nil? tcid) (nil? scid)) {:error "missing-branch"})
                (else
                  (let
                    ((m (git/merge-commits grepo tcid scid)))
                    (cond
                      ((= (get m :result) "up-to-date")
                        (gitea/pr-mark-merged! forge owner name n tcid))
                      ((= (get m :result) "fast-forward")
                        (let
                          ((res (git/branch-cas! grepo (get rec :target) tcid scid)))
                          (if
                            (and (dict? res) (get res :conflict))
                            {:error "stale"}
                            (gitea/pr-mark-merged! forge owner name n scid))))
                      ((= (get m :result) "merged")
                        (let
                          ((mc (git/write grepo (git/commit (get m :tree) (list tcid scid) {:message (str "Merge PR #" n ": " (get rec :title)) :time (or (get (or opts {}) :time) 0) :author (or merger "")}))))
                          (let
                            ((res (git/branch-cas! grepo (get rec :target) tcid mc)))
                            (if
                              (and (dict? res) (get res :conflict))
                              {:error "stale"}
                              (gitea/pr-mark-merged! forge owner name n mc)))))
                      (else {:conflicts (get m :conflicts) :error "conflicts"}))))))))))))

; ── close / reopen ───────────────────────────────────────────────────

(define
  gitea/pr-close!
  (fn
    (forge owner name n)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (if
        (or (nil? rec) (not (= (get rec :state) "open")))
        nil
        (begin
          (if
            (nil? (get rec :flow-id))
            nil
            (gitea/pr-flow-cancel! forge (get rec :flow-id)))
          (gitea/pr-update!
            forge
            owner
            name
            n
            (fn (r) (assoc r :state "closed"))))))))

; reopening restarts the lifecycle (a cancelled flow cannot resume)
(define
  gitea/pr-reopen!
  (fn
    (forge owner name n)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (if
        (or (nil? rec) (not (= (get rec :state) "closed")))
        nil
        (gitea/pr-update!
          forge
          owner
          name
          n
          (fn
            (r)
            (assoc
              (assoc r :state "open")
              :flow-id (gitea/pr-flow-start! forge n))))))))

; ── merge queue ──────────────────────────────────────────────────────

(define
  gitea/queue-key
  (fn (owner name) (str "gitea/mergeq/" owner "/" name)))

(define
  gitea/queue
  (fn
    (forge owner name)
    (persist/kv-get-or
      (gitea/forge-db forge)
      (gitea/queue-key owner name)
      (list))))

(define
  gitea/queue-add!
  (fn
    (forge owner name n)
    (let
      ((rec (gitea/pr-get forge owner name n)))
      (cond
        ((nil? rec) {:error "no-such-pr"})
        ((not (= (get rec :state) "open")) {:error "not-open"})
        ((not (gitea/pr-approved? rec)) {:error "not-approved"})
        (else
          (let
            ((q (gitea/queue forge owner name)))
            (if
              (contains? q n)
              q
              (persist/kv-put
                (gitea/forge-db forge)
                (gitea/queue-key owner name)
                (append q (list n))))))))))

(define
  gitea/queue-remove!
  (fn
    (forge owner name n)
    (persist/kv-put
      (gitea/forge-db forge)
      (gitea/queue-key owner name)
      (filter (fn (x) (not (= x n))) (gitea/queue forge owner name)))))

; merge queued PRs in order; merged ones leave the queue, failures stay
; => ({:number n :merged true} | {:number n :error reason} ...)
(define
  gitea/queue-process!
  (fn
    (forge owner name merger)
    (let
      ((results (map (fn (n) (let ((res (gitea/pr-merge! forge owner name n merger {}))) (if (get res :error) {:error (get res :error) :number n} {:merged true :number n}))) (gitea/queue forge owner name))))
      (begin
        (persist/kv-put
          (gitea/forge-db forge)
          (gitea/queue-key owner name)
          (map
            (fn (r) (get r :number))
            (filter (fn (r) (get r :error)) results)))
        results))))

; ── web ──────────────────────────────────────────────────────────────

(define
  gitea/w-pr-item
  (fn
    (owner name r)
    (str
      "<li class=\""
      (get r :state)
      "\"><a href=\"/"
      owner
      "/"
      name
      "/pulls/"
      (get r :number)
      "\">#"
      (get r :number)
      " "
      (dream-escape (get r :title))
      "</a> ["
      (get r :state)
      "] "
      (dream-escape (get r :source))
      " -&gt; "
      (dream-escape (get r :target))
      "</li>")))

(define
  gitea/w-pulls-page
  (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)
        (gitea/w-page
          (str owner "/" name " pull requests")
          (str
            "<h1>Pull Requests</h1><ul>"
            (join
              ""
              (map
                (fn (r) (gitea/w-pr-item owner name r))
                (gitea/pr-records forge owner name)))
            "</ul>"))))))

(define
  gitea/w-review-html
  (fn
    (owner name n i r)
    (str
      "<div class=\"review "
      (get r :verdict)
      "\"><p>"
      (dream-escape (get r :reviewer))
      ": "
      (get r :verdict)
      "</p>"
      (gitea/md-html (get r :body) (str "rv-" owner "-" name "-" n "-" i))
      "</div>")))

(define
  gitea/w-pull-page
  (fn
    (forge req)
    (let
      ((owner (dream-param req "owner"))
        (name (dream-param req "name"))
        (n (gitea/w-issue-n req)))
      (if
        (or (nil? n) (not (gitea/w-readable? forge req owner name)))
        (dream-not-found)
        (let
          ((rec (gitea/pr-get forge owner name n)))
          (if
            (nil? rec)
            (dream-not-found)
            (gitea/w-page
              (str "#" n " " (get rec :title))
              (str
                "<h1>#"
                n
                " "
                (dream-escape (get rec :title))
                "</h1>"
                "<p class=\"state\">"
                (get rec :state)
                "</p>"
                "<p class=\"branches\">"
                (dream-escape (get rec :source))
                " -&gt; "
                (dream-escape (get rec :target))
                "</p>"
                "<p class=\"lifecycle\">"
                (gitea/pr-flow-status forge rec)
                "</p>"
                "<div class=\"body\">"
                (gitea/md-html
                  (get rec :body)
                  (str "pr-" owner "-" name "-" n))
                "</div>"
                "<h2>Reviews</h2>"
                (join
                  ""
                  (map-indexed
                    (fn (i r) (gitea/w-review-html owner name n i r))
                    (get rec :reviews)))
                "<h2>Diff</h2><pre>"
                (dream-escape
                  (or (gitea/pr-diff-unified forge owner name n) ""))
                "</pre>"))))))))

; ── json api ─────────────────────────────────────────────────────────

(define
  gitea/w-api-pulls
  (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)
        (dream-json-value
          (map (fn (r) {:source (get r :source) :state (get r :state) :title (get r :title) :number (get r :number) :target (get r :target)}) (gitea/pr-records forge owner name)))))))

(define
  gitea/w-api-pr-create
  (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))
            (if
              (nil? user)
              (if
                (and
                  (gitea/repo-exists? forge owner name)
                  (equal?
                    (get (gitea/repo-get forge owner name) :visibility)
                    "public"))
                (gitea/w-unauthorized)
                (dream-not-found))
              (dream-not-found)))
          ((nil? user) (gitea/w-unauthorized))
          (else
            (let
              ((body (dream-json-body req)))
              (let
                ((res (gitea/pr-create! forge owner name user (get body :title) (get body :source) (get body :target) (or (get body :body) "") {:created-at (or (get body :created-at) 0)})))
                (if
                  (get res :error)
                  (gitea/w-json-status 400 {:error (get res :error)})
                  (gitea/w-json-status 201 {:title (get res :title) :number (get res :number)}))))))))))

(define
  gitea/w-api-pr-review
  (fn
    (forge req)
    (let
      ((owner (dream-param req "owner"))
        (name (dream-param req "name"))
        (n (gitea/w-issue-n req)))
      (let
        ((user (gitea/w-user forge req)))
        (cond
          ((or (nil? n) (not (gitea/can? forge user "read" owner name)))
            (dream-not-found))
          ((nil? user) (gitea/w-unauthorized))
          (else
            (let
              ((body (dream-json-body req)))
              (let
                ((res (gitea/pr-review! forge owner name n user (get body :verdict) (or (get body :body) "") {:at (or (get body :created-at) 0)})))
                (cond
                  ((equal? (get res :error) "no-such-pr") (dream-not-found))
                  ((get res :error)
                    (gitea/w-json-status 400 {:error (get res :error)}))
                  (else (dream-json-value {:verdict (get res :verdict) :reviewer user})))))))))))

(define
  gitea/w-api-pr-merge
  (fn
    (forge req)
    (let
      ((owner (dream-param req "owner"))
        (name (dream-param req "name"))
        (n (gitea/w-issue-n req)))
      (let
        ((user (gitea/w-user forge req)))
        (cond
          ((or (nil? n) (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
              ((res (gitea/pr-merge! forge owner name n user {:time (or (get (dream-json-body req) :time) 0)})))
              (cond
                ((equal? (get res :error) "no-such-pr") (dream-not-found))
                ((get res :error)
                  (gitea/w-json-status 409 {:error (get res :error)}))
                (else (dream-json-value {:state (get res :state) :merge-cid (get res :merge-cid) :number n}))))))))))

(define
  gitea/w-api-pr-close
  (fn
    (forge req)
    (let
      ((owner (dream-param req "owner"))
        (name (dream-param req "name"))
        (n (gitea/w-issue-n req)))
      (let
        ((user (gitea/w-user forge req)))
        (cond
          ((or (nil? n) (not (gitea/can? forge user "read" owner name)))
            (dream-not-found))
          ((nil? user) (gitea/w-unauthorized))
          (else
            (let
              ((rec (gitea/pr-get forge owner name n)))
              (cond
                ((nil? rec) (dream-not-found))
                ((not (or (= user (get rec :author)) (gitea/can? forge user "write" owner name)))
                  (gitea/w-forbidden))
                (else
                  (let
                    ((res (gitea/pr-close! forge owner name n)))
                    (if
                      (nil? res)
                      (gitea/w-json-status 409 {:error "not-open"})
                      (dream-json-value {:state "closed" :number n}))))))))))))

(define
  gitea/w-api-queue
  (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)
        (dream-json-value (gitea/queue forge owner name))))))

(define
  gitea/w-api-queue-add
  (fn
    (forge req)
    (let
      ((owner (dream-param req "owner"))
        (name (dream-param req "name"))
        (n (gitea/w-issue-n req)))
      (let
        ((user (gitea/w-user forge req)))
        (cond
          ((or (nil? n) (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
              ((res (gitea/queue-add! forge owner name n)))
              (if
                (and (dict? res) (get res :error))
                (gitea/w-json-status 409 {:error (get res :error)})
                (dream-json-value (gitea/queue forge owner name))))))))))

(define
  gitea/w-api-queue-process
  (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
            (dream-json-value (gitea/queue-process! forge owner name user))))))))

(define
  gitea/pr-routes
  (fn
    (forge)
    (list
      (dream-get
        "/:owner/:name/pulls"
        (fn (req) (gitea/w-pulls-page forge req)))
      (dream-get
        "/:owner/:name/pulls/:n"
        (fn (req) (gitea/w-pull-page forge req)))
      (dream-get
        "/api/repos/:owner/:name/pulls"
        (fn (req) (gitea/w-api-pulls forge req)))
      (dream-post
        "/api/repos/:owner/:name/pulls"
        (fn (req) (gitea/w-api-pr-create forge req)))
      (dream-post
        "/api/repos/:owner/:name/pulls/:n/reviews"
        (fn (req) (gitea/w-api-pr-review forge req)))
      (dream-post
        "/api/repos/:owner/:name/pulls/:n/merge"
        (fn (req) (gitea/w-api-pr-merge forge req)))
      (dream-post
        "/api/repos/:owner/:name/pulls/:n/close"
        (fn (req) (gitea/w-api-pr-close forge req)))
      (dream-get
        "/api/repos/:owner/:name/merge-queue"
        (fn (req) (gitea/w-api-queue forge req)))
      (dream-post
        "/api/repos/:owner/:name/pulls/:n/enqueue"
        (fn (req) (gitea/w-api-queue-add forge req)))
      (dream-post
        "/api/repos/:owner/:name/merge-queue/process"
        (fn (req) (gitea/w-api-queue-process forge req))))))

(set! gitea/route-packs (append gitea/route-packs (list gitea/pr-routes)))