penpot/backend/test/backend_tests/rpc_file_pull_request_test.clj
Álvaro Tejero Cantero 74e33d05b6
Merge branch 'juan-vc-ui-tweaks-01' into iop-vc-preview
Takes penpot#12596: branch access by team role alone (no file role on
a branch, the owner role on materialise, branches move with their
source file, migrations 0807 and 0808), the merge record with its
comment (migration 0806) and the reviews dialog, the new git icons, and
the workspace tidy-up.

Where Juan's later redesign of the compare, conflict and merge dialogs
(c68daed816, e4e237346e) already changed the same code, the redesign
wins: the old dialogs stay in branch_review/, the redrawn compare
icon stays, and the merge keeps its "Archive this branch" option. So
merge-file-branch accepts both `comment` and `keep-branch`, a kept
merged branch is listed and counted again, and the keep-branch tests
the PR removed are restored. The merge dialog asks for the comment
beside the archive option, and the conflicts dialog sends it on.

AI-assisted-by: claude-opus-5-5
2026-10-28 12:06:11 +01:00

870 lines
43 KiB
Clojure

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC Sucursal en España SL
(ns backend-tests.rpc-file-pull-request-test
(:require
[app.common.features :as cfeat]
[app.common.files.branch-merge :as bm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.email :as eml]
[app.msgbus :as mbus]
[app.rpc :as-alias rpc]
[backend-tests.helpers :as th]
[clojure.string :as str]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(def ^:private pr-flags
(conj cf/flags :branching))
(defn- apply-change*
[profile file-id change]
(let [f (th/db-get :file {:id file-id})]
(th/command! {::th/type :update-file
::rpc/profile-id (:id profile)
:id file-id
:session-id (uuid/random)
:revn (:revn f)
:vern (:vern f)
:features cfeat/supported-features
:changes [change]})))
(defn- add-color*
[profile file-id name]
(apply-change* profile file-id
{:type :add-color
:color {:id (uuid/random) :name name :color "#ff0000" :opacity 1}}))
(defn- create-branch*
[profile file name]
(:result (th/command! {::th/type :create-file-branch
::rpc/profile-id (:id profile)
:file-id (:id file)
:name name})))
(defn- create-pr*
[profile branch-id params]
(th/command! (merge {::th/type :create-pull-request
::rpc/profile-id (:id profile)
:branch-id branch-id
:title "review me"}
params)))
(t/deftest create-and-list-pull-requests
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
reviewer (th/create-profile* 2 {:is-active true})
proj-id (:default-project-id author)
file (th/create-file* 1 {:profile-id (:id author)
:project-id proj-id})]
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id reviewer)
:role :editor})
(let [branch (create-branch* author file "feature")
branch-file-id (:branch-file-id branch)
pr-id (volatile! nil)]
(add-color* author branch-file-id "Brand")
(t/testing "create pull request with a reviewer"
(let [out (create-pr* author (:id branch)
{:description "please check the brand color"
:reviewers [(:id reviewer)]})]
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (uuid? (:id result)))
(t/is (= branch-file-id (:source-file-id result)))
(t/is (= (:id file) (:target-file-id result)))
(t/is (= "open" (:status result)))
(t/is (= [(:id reviewer)] (:reviewers result)))
(vreset! pr-id (:id result)))))
(t/testing "review snapshot is pinned on the branch file"
(let [rows (->> (th/db-query :file-change {:file-id branch-file-id})
(filter #(some-> (:label %) (str/starts-with? "pr-review/"))))]
(t/is (= 1 (count rows)))
(t/is (every? (fn [{:keys [deleted-at]}]
(and (some? deleted-at)
(ct/is-after? deleted-at (ct/in-future {:days 3000}))))
rows))))
(t/testing "list from the target file"
(let [out (th/command! {::th/type :get-file-pull-requests
::rpc/profile-id (:id author)
:file-id (:id file)})]
(t/is (nil? (:error out)))
(let [[row :as result] (:result out)]
(t/is (= 1 (count result)))
(t/is (= @pr-id (:id row)))
(t/is (= "review me" (:title row)))
(t/is (= "feature" (:branch-name row)))
(t/is (= (:name file) (:target-name row)))
(t/is (= "pending" (:review-state row)))
(t/is (false? (:outdated row)))
;; the branch carries one change (the added color)
(t/is (= 1 (:ahead row)))
(t/is (= 0 (:behind row)))
(t/is (= 0 (:conflicts row)))
(t/is (= 1 (count (:reviews row))))
(t/is (= (:id reviewer) (-> row :reviews first :profile-id)))
(t/is (= "pending" (-> row :reviews first :state))))))
(t/testing "list resolves a branch file id to its target"
(let [out (th/command! {::th/type :get-file-pull-requests
::rpc/profile-id (:id author)
:file-id branch-file-id})]
(t/is (nil? (:error out)))
(t/is (= 1 (count (:result out))))))
(t/testing "get single pull request"
(let [out (th/command! {::th/type :get-pull-request
::rpc/profile-id (:id reviewer)
:id @pr-id})]
(t/is (nil? (:error out)))
(t/is (= "review me" (-> out :result :title)))))))))
(t/deftest one-open-pull-request-per-branch
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "feature")]
(t/is (nil? (:error (create-pr* author (:id branch) {}))))
(let [out (create-pr* author (:id branch) {:title "second"})
error (:error out)]
(t/is (some? error))
(t/is (= :pull-request-already-exists (-> error ex-data :code)))))))
(t/deftest create-validates-reviewers-and-permissions
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
stranger (th/create-profile* 2 {:is-active true})
viewer (th/create-profile* 3 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "feature")]
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id viewer)
:role :viewer})
(t/testing "a reviewer outside the team is refused"
(let [out (create-pr* author (:id branch)
{:reviewers [(:id stranger)]})
error (:error out)]
(t/is (some? error))
(t/is (= :reviewer-not-team-member (-> error ex-data :code)))))
(t/testing "the author is silently dropped from the reviewer list"
(let [out (create-pr* author (:id branch)
{:reviewers [(:id author) (:id viewer)]})]
(t/is (nil? (:error out)))
(t/is (= [(:id viewer)] (-> out :result :reviewers)))))
(t/testing "a viewer of the branch file cannot create a pull request"
(let [branch2 (create-branch* author file "feature-2")
out (create-pr* viewer (:id branch2) {})]
(t/is (some? (:error out))))))))
(t/deftest bundle-serves-the-pinned-snapshot
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "feature")
bfid (:branch-file-id branch)
color-1 (uuid/random)
color-2 (uuid/random)]
(apply-change* author bfid
{:type :add-color
:color {:id color-1 :name "One" :color "#111111" :opacity 1}})
(let [pr (:result (create-pr* author (:id branch) {}))]
;; the branch keeps moving AFTER the pull request was created
(apply-change* author bfid
{:type :add-color
:color {:id color-2 :name "Two" :color "#222222" :opacity 1}})
(t/testing "the sandbox shows the reviewed state, not the live branch"
(let [out (th/command! {::th/type :get-pull-request-bundle
::rpc/profile-id (:id author)
:id (:id pr)})
result (:result out)
colors (-> result :data :colors)]
(t/is (nil? (:error out)))
(t/is (contains? colors color-1))
(t/is (not (contains? colors color-2)))
;; read-only by construction, whatever the caller's role is
(t/is (false? (-> result :permissions :can-edit)))))
(t/testing "the pull request reports the branch moved on"
(let [out (th/command! {::th/type :get-pull-request
::rpc/profile-id (:id author)
:id (:id pr)})]
(t/is (true? (-> out :result :outdated)))))
(t/testing "publishing the branch state refreshes the sandbox"
(let [out (th/command! {::th/type :update-pull-request-snapshot
::rpc/profile-id (:id author)
:id (:id pr)})]
(t/is (nil? (:error out)))
(t/is (true? (-> out :result :updated))))
(let [out (th/command! {::th/type :get-pull-request-bundle
::rpc/profile-id (:id author)
:id (:id pr)})
colors (-> out :result :data :colors)]
(t/is (contains? colors color-2)))
(let [out (th/command! {::th/type :get-pull-request
::rpc/profile-id (:id author)
:id (:id pr)})]
(t/is (false? (-> out :result :outdated)))))
(t/testing "publishing again with no new changes is a no-op"
(let [out (th/command! {::th/type :update-pull-request-snapshot
::rpc/profile-id (:id author)
:id (:id pr)})]
(t/is (nil? (:error out)))
(t/is (false? (-> out :result :updated)))))))))
(t/deftest viewer-bundle-serves-the-pinned-snapshot
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "feature")
bfid (:branch-file-id branch)
color-1 (uuid/random)
color-2 (uuid/random)]
(apply-change* author bfid
{:type :add-color
:color {:id color-1 :name "One" :color "#111111" :opacity 1}})
(let [pr (:result (create-pr* author (:id branch) {}))]
;; the branch keeps moving AFTER the pull request was created
(apply-change* author bfid
{:type :add-color
:color {:id color-2 :name "Two" :color "#222222" :opacity 1}})
;; the bundle strips file :data down to pages/components, so the
;; served state is asserted through :revn (the overlay carries the
;; snapshot's revn; the live branch is one save ahead)
(t/testing "the viewer bundle shows the reviewed state, read-only"
(let [out (th/command! {::th/type :get-view-only-bundle
::rpc/profile-id (:id author)
:file-id bfid
:pr-id (:id pr)})
result (:result out)]
(t/is (nil? (:error out)))
(t/is (= (:review-revn pr) (-> result :file :revn)))
(t/is (false? (-> result :permissions :can-edit)))))
(t/testing "the viewer bundle without pr-id keeps the live state"
(let [out (th/command! {::th/type :get-view-only-bundle
::rpc/profile-id (:id author)
:file-id bfid})
bf (th/db-get :file {:id bfid})]
(t/is (nil? (:error out)))
(t/is (= (:revn bf) (-> out :result :file :revn)))
(t/is (< (:review-revn pr) (:revn bf)))))
(t/testing "the viewer bundle refuses a closed pull request"
(th/command! {::th/type :close-pull-request
::rpc/profile-id (:id author)
:id (:id pr)})
(let [out (th/command! {::th/type :get-view-only-bundle
::rpc/profile-id (:id author)
:file-id bfid
:pr-id (:id pr)})
error (:error out)]
(t/is (some? error))
(t/is (= :pull-request-not-open (-> error ex-data :code)))))))))
(t/deftest review-lifecycle
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
reviewer (th/create-profile* 2 {:is-active true})
other (th/create-profile* 3 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})]
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id reviewer)
:role :editor})
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id other)
:role :editor})
(let [branch (create-branch* author file "feature")
bfid (:branch-file-id branch)
_ (add-color* author bfid "Brand")
pr (:result (create-pr* author (:id branch)
{:reviewers [(:id reviewer)]}))]
(t/testing "a non-assigned member cannot submit a review"
(let [out (th/command! {::th/type :submit-pull-request-review
::rpc/profile-id (:id other)
:id (:id pr)
:state "approved"})
error (:error out)]
(t/is (some? error))
(t/is (= :not-a-reviewer (-> error ex-data :code)))))
(t/testing "an approval flips the aggregate review state"
(let [out (th/command! {::th/type :submit-pull-request-review
::rpc/profile-id (:id reviewer)
:id (:id pr)
:state "approved"
:comment "ship it"})]
(t/is (nil? (:error out))))
(let [out (th/command! {::th/type :get-pull-request
::rpc/profile-id (:id author)
:id (:id pr)})
row (:result out)]
(t/is (= "approved" (:review-state row)))
(t/is (false? (-> row :reviews first :stale)))))
(t/testing "publishing new changes makes the verdict stale"
(add-color* author bfid "Another")
(let [out (th/command! {::th/type :update-pull-request-snapshot
::rpc/profile-id (:id author)
:id (:id pr)})]
(t/is (nil? (:error out))))
(let [row (:result (th/command! {::th/type :get-pull-request
::rpc/profile-id (:id author)
:id (:id pr)}))]
;; the verdict is kept for the history but no longer current
(t/is (= "in-review" (:review-state row)))
(t/is (true? (-> row :reviews first :stale)))))
(t/testing "requesting changes beats an approval"
(let [out (th/command! {::th/type :submit-pull-request-review
::rpc/profile-id (:id reviewer)
:id (:id pr)
:state "changes-requested"
:comment "the second color is off-brand"})]
(t/is (nil? (:error out))))
(let [row (:result (th/command! {::th/type :get-pull-request
::rpc/profile-id (:id author)
:id (:id pr)}))]
(t/is (= "changes-requested" (:review-state row)))))))))
(t/deftest update-pull-request-metadata-and-reviewers
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
reviewer-1 (th/create-profile* 2 {:is-active true})
reviewer-2 (th/create-profile* 3 {:is-active true})
editor (th/create-profile* 4 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})]
(doseq [[profile role] [[reviewer-1 :editor] [reviewer-2 :editor] [editor :editor]]]
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id profile)
:role role}))
(let [branch (create-branch* author file "feature")
pr (:result (create-pr* author (:id branch)
{:reviewers [(:id reviewer-1)]}))]
(t/testing "a plain editor (not author, not admin) cannot manage it"
(let [out (th/command! {::th/type :update-pull-request
::rpc/profile-id (:id editor)
:id (:id pr)
:title "hijacked"})]
(t/is (some? (:error out)))))
(t/testing "the author can replace title, description and reviewers"
(let [out (th/command! {::th/type :update-pull-request
::rpc/profile-id (:id author)
:id (:id pr)
:title "better title"
:description "more context"
:reviewers [(:id reviewer-2)]})]
(t/is (nil? (:error out))))
(let [row (:result (th/command! {::th/type :get-pull-request
::rpc/profile-id (:id author)
:id (:id pr)}))]
(t/is (= "better title" (:title row)))
(t/is (= "more context" (:description row)))
(t/is (= [(:id reviewer-2)] (mapv :profile-id (:reviews row))))))
(t/testing "a removed reviewer can no longer submit"
(let [out (th/command! {::th/type :submit-pull-request-review
::rpc/profile-id (:id reviewer-1)
:id (:id pr)
:state "approved"})
error (:error out)]
(t/is (some? error))
(t/is (= :not-a-reviewer (-> error ex-data :code)))))))))
(t/deftest close-and-reopen-pull-request
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
editor (th/create-profile* 2 {:is-active true})
admin (th/create-profile* 3 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})]
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id editor)
:role :editor})
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id admin)
:role :admin})
(let [branch (create-branch* author file "feature")
bfid (:branch-file-id branch)
pr (:result (create-pr* author (:id branch) {}))]
(t/testing "a plain editor cannot close someone else's pull request"
(let [out (th/command! {::th/type :close-pull-request
::rpc/profile-id (:id editor)
:id (:id pr)})]
(t/is (some? (:error out)))))
(t/testing "a team admin can close it"
(let [out (th/command! {::th/type :close-pull-request
::rpc/profile-id (:id admin)
:id (:id pr)})]
(t/is (nil? (:error out)))
(t/is (= "closed" (-> out :result :status)))))
(t/testing "the sandbox stops resolving once closed"
(let [out (th/command! {::th/type :get-pull-request-bundle
::rpc/profile-id (:id author)
:id (:id pr)})
error (:error out)]
(t/is (some? error))
(t/is (= :pull-request-not-open (-> error ex-data :code)))))
(t/testing "the review snapshot pin is released on close"
(let [rows (->> (th/db-query :file-change {:file-id bfid})
(filter #(some-> (:label %) (str/starts-with? "pr-review/"))))]
(t/is (seq rows))
(t/is (every? (fn [{:keys [deleted-at]}]
(and (some? deleted-at)
(ct/is-before? deleted-at (ct/in-future {:days 400}))))
rows))))
(t/testing "the author can reopen it, re-pinned at the current head"
(add-color* author bfid "Late")
(let [out (th/command! {::th/type :reopen-pull-request
::rpc/profile-id (:id author)
:id (:id pr)})
bf (th/db-get :file {:id bfid})]
(t/is (nil? (:error out)))
(t/is (= "open" (-> out :result :status)))
(t/is (= (:revn bf) (-> out :result :review-revn)))))))))
(t/deftest branch-lifecycle-closes-pull-requests
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})]
(t/testing "merging the branch marks the pull request merged"
(let [branch (create-branch* author file "merge-me")
_ (add-color* author (:branch-file-id branch) "Brand")
pr (:result (create-pr* author (:id branch) {}))
out (th/command! {::th/type :merge-file-branch
::rpc/profile-id (:id author)
:branch-id (:id branch)})]
(t/is (nil? (:error out)))
(let [[row] (th/db-query :file-pull-request {:id (:id pr)})]
(t/is (= "merged" (:status row)))
(t/is (some? (:closed-at row)))
;; the row survives as history even though the branch is gone
(t/is (nil? (:deleted-at row))))
;; the record of the merge names the review it accepted, so the
;; list of merges keeps it once the review is gone
(let [merges (:result (th/command! {::th/type :get-file-branch-merges
::rpc/profile-id (:id author)
:file-id (:id file)}))]
(t/is (= [(:id pr)] (mapv :pull-request-id merges)))
(t/is (= [(:title pr)] (mapv :pull-request-title merges))))))
(t/testing "deleting the branch closes the pull request"
(let [branch (create-branch* author file "delete-me")
pr (:result (create-pr* author (:id branch) {}))
out (th/command! {::th/type :delete-file-branch
::rpc/profile-id (:id author)
:id (:id branch)})]
(t/is (nil? (:error out)))
(let [[row] (th/db-query :file-pull-request {:id (:id pr)})]
(t/is (= "closed" (:status row))))))
(t/testing "archiving the branch closes the pull request"
(let [branch (create-branch* author file "archive-me")
pr (:result (create-pr* author (:id branch) {}))
out (th/command! {::th/type :archive-file-branch
::rpc/profile-id (:id author)
:id (:id branch)})]
(t/is (nil? (:error out)))
(let [[row] (th/db-query :file-pull-request {:id (:id pr)})]
(t/is (= "closed" (:status row)))))))))
(t/deftest create-serializes-against-a-concurrent-merge
;; the create must re-read the branch under the advisory lock: a merge
;; that wins the race closes the branch while the create waits for the
;; lock, so a create arriving afterwards must refuse instead of opening
;; a review over a branch that is already merged and gone.
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "contested")
branch-id (:id branch)
branch-file-id (:branch-file-id branch)]
(add-color* author branch-file-id "Brand")
(let [orig-lock db/xact-lock!
merging? (atom false)
merged (atom nil)]
(with-redefs [db/xact-lock!
(fn [conn id]
;; the first lock the create takes is the signal:
;; merge the same branch through the pool in its
;; own transaction BEFORE the create locks
(when (compare-and-set! merging? false true)
(reset! merged (th/command! {::th/type :merge-file-branch
::rpc/profile-id (:id author)
:branch-id branch-id})))
(orig-lock conn id))]
(let [out (th/command! {::th/type :create-pull-request
::rpc/profile-id (:id author)
:branch-id branch-id
:title "review me"})]
(t/is (= :merged (-> @merged :result :status)))
(t/is (= :branch-not-found (-> out :error ex-data :code)))
(t/is (= [] (th/db-query :file-pull-request {:file-branch-id branch-id})))))))))
(t/deftest reopen-serializes-against-a-concurrent-merge
;; the reopen must re-read the branch under the advisory lock too: the
;; merge that wins the race closes the branch under the closed pull
;; request's feet, so a reopen arriving afterwards must refuse instead
;; of reviving a review over a branch that is already merged and gone.
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "contested")
branch-id (:id branch)
branch-file-id (:branch-file-id branch)]
(add-color* author branch-file-id "Brand")
(let [pr (:result (create-pr* author branch-id {}))]
(t/is (nil? (:error (th/command! {::th/type :close-pull-request
::rpc/profile-id (:id author)
:id (:id pr)}))))
(let [orig-lock db/xact-lock!
merging? (atom false)
merged (atom nil)]
(with-redefs [db/xact-lock!
(fn [conn id]
;; the first lock the reopen takes is the signal:
;; merge the same branch through the pool in its
;; own transaction BEFORE the reopen locks
(when (compare-and-set! merging? false true)
(reset! merged (th/command! {::th/type :merge-file-branch
::rpc/profile-id (:id author)
:branch-id branch-id})))
(orig-lock conn id))]
(let [out (th/command! {::th/type :reopen-pull-request
::rpc/profile-id (:id author)
:id (:id pr)})]
(t/is (= :merged (-> @merged :result :status)))
(t/is (= :branch-not-open (-> out :error ex-data :code)))
(t/is (= "closed" (:status (first (th/db-query :file-pull-request {:id (:id pr)}))))))))))))
(t/deftest closed-pull-requests-listing
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "feature")
pr (:result (create-pr* author (:id branch) {}))]
(th/command! {::th/type :close-pull-request
::rpc/profile-id (:id author)
:id (:id pr)})
(t/testing "closed pull requests are hidden by default"
(let [out (th/command! {::th/type :get-file-pull-requests
::rpc/profile-id (:id author)
:file-id (:id file)})]
(t/is (nil? (:error out)))
(t/is (= 0 (count (:result out))))))
(t/testing "and visible with include-closed"
(let [out (th/command! {::th/type :get-file-pull-requests
::rpc/profile-id (:id author)
:file-id (:id file)
:include-closed true})]
(t/is (nil? (:error out)))
(t/is (= 1 (count (:result out))))
(t/is (= "closed" (-> out :result first :status))))))))
(t/deftest pull-request-listing-shares-the-branch-summary-cache
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "feature")
branches (fn [] (:result (th/command! {::th/type :get-file-branches
::rpc/profile-id (:id author)
:file-id (:id file)})))
prs (fn [] (:result (th/command! {::th/type :get-file-pull-requests
::rpc/profile-id (:id author)
:file-id (:id file)})))
summary (fn [row] (select-keys row [:ahead :behind :conflicts]))]
;; diverge both sides so the comparison is real work
(add-color* author (:branch-file-id branch) "Brand")
(add-color* author (:id file) "Accent")
(t/is (nil? (:error (create-pr* author (:id branch) {}))))
(let [orig-merge bm/compute-merge
calls (atom 0)]
(with-redefs [bm/compute-merge (fn [& args] (swap! calls inc) (apply orig-merge args))]
(let [cold-branch (first (branches))
cold-calls @calls
_ (reset! calls 0)
warm-pr (first (prs))
pr-calls @calls
_ (reset! calls 0)
repeat-pr (first (prs))]
(t/testing "the branches listing pays for the comparison"
(t/is (pos? cold-calls))
(t/is (= {:ahead 1 :behind 1 :conflicts 0} (summary cold-branch))))
(t/testing "the pull-request listing arrives warm and agrees"
(t/is (zero? pr-calls))
(t/is (= (summary cold-branch) (summary warm-pr))))
(t/testing "and a repeat of it performs no comparison work either"
(t/is (zero? @calls))
(t/is (= (summary warm-pr) (summary repeat-pr))))))))))
(t/deftest branching-flag-gates-pull-request-commands
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (with-redefs [cf/flags pr-flags]
(create-branch* author file "feature"))
out (create-pr* author (:id branch) {})
error (:error out)]
(t/is (some? error))
(t/is (= :branching-disabled (-> error ex-data :code)))))
(t/deftest pull-request-commands-notify-only-after-the-commit
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
reviewer (th/create-profile* 2 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})]
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id reviewer)
:role :editor})
(let [branch (create-branch* author file "notify")
bfid (:branch-file-id branch)
actors {:author (:id author) :reviewer (:id reviewer)}
;; one case per mutation; at the very moment `mbus/pub!`
;; fires, `:view` reads the row ANOTHER pool connection sees
;; and `:expected` is the state that must already be visible
;; there (the transaction has committed)
cases
[{:label "create-pull-request"
:type :create-pull-request
:actor :author
:params (fn [_] {:branch-id (:id branch)
:title "review me"
:reviewers [(:id reviewer)]})
:message-type :pull-request-created
:view (fn [id] (select-keys (th/db-get :file-pull-request {:id id})
[:status]))
:expected (constantly {:status "open"})}
{:label "update-pull-request"
:type :update-pull-request
:actor :author
:params (fn [id] {:id id :title "renamed"})
:message-type :pull-request-updated
:view (fn [id] (select-keys (th/db-get :file-pull-request {:id id})
[:title]))
:expected (constantly {:title "renamed"})}
{:label "update-pull-request-snapshot"
:type :update-pull-request-snapshot
:actor :author
;; the sandbox only republishes when the branch moved
:before (fn [] (add-color* author bfid "Extra"))
:params (fn [id] {:id id})
:message-type :pull-request-updated
:view (fn [id] (select-keys (th/db-get :file-pull-request {:id id})
[:review-revn]))
:expected (fn [_] {:review-revn (:revn (th/db-get :file {:id bfid}))})}
{:label "submit-pull-request-review"
:type :submit-pull-request-review
:actor :reviewer
:params (fn [id] {:id id :state "approved" :comment "ship it"})
:message-type :pull-request-review-submitted
:view (fn [id] (select-keys (th/db-get :file-pull-request-review
{:pull-request-id id
:profile-id (:id reviewer)})
[:state :reviewed-revn]))
:expected (fn [id] {:state "approved"
:reviewed-revn (:review-revn (th/db-get :file-pull-request {:id id}))})}
{:label "close-pull-request"
:type :close-pull-request
:actor :author
:params (fn [id] {:id id})
:message-type :pull-request-closed
:view (fn [id] (select-keys (th/db-get :file-pull-request {:id id})
[:status]))
:expected (constantly {:status "closed"})}
{:label "reopen-pull-request"
:type :reopen-pull-request
:actor :author
:params (fn [id] {:id id})
:message-type :pull-request-updated
:view (fn [id] (select-keys (th/db-get :file-pull-request {:id id})
[:status]))
:expected (constantly {:status "open"})}]]
(loop [cases cases
pr-id nil]
(when-some [{:keys [label type actor before params message-type view expected]}
(first cases)]
(let [seen (atom [])
_ (when before (before))
out (with-redefs [mbus/pub!
(fn [_ & {:keys [message]}]
(swap! seen conj {:message message
:row (view (:pull-request-id message))}))]
(th/command! (merge {::th/type type
::rpc/profile-id (actors actor)}
(params pr-id))))]
(t/is (nil? (:error out)) (str label " runs"))
(let [{:keys [message row]} (first @seen)]
(t/is (= 1 (count @seen)) (str label " publishes once"))
(t/is (= message-type (:type message)) (str label " message type"))
(t/is (= (expected (:pull-request-id message)) row)
(str label " publishes only after the commit")))
(recur (rest cases) (or pr-id (-> out :result :id))))))))))
(t/deftest rolled-back-pull-request-commands-notify-nothing
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
reviewer (th/create-profile* 2 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})]
(th/create-team-role* {:team-id (:default-team-id author)
:profile-id (:id reviewer)
:role :editor})
(let [branch (create-branch* author file "rollback")
seen (atom [])]
;; the reviewer emails are queued inside the transaction: make
;; that queueing fail after the pull request row is written
(with-redefs [mbus/pub! (fn [_ & {:keys [message]}]
(swap! seen conj message))
eml/send (fn [_ _] (throw (IllegalStateException. "boom")))]
(let [out (create-pr* author (:id branch) {:reviewers [(:id reviewer)]})]
(t/is (some? (:error out)))))
(t/is (empty? @seen))
(t/is (empty? (th/db-query :file-pull-request
{:file-branch-id (:id branch)})))))))
(t/deftest create-serializes-against-a-kept-concurrent-merge
;; same race, but the merge keeps the branch: its row stays readable
;; with status "merged" and its file is not deleted, so without the
;; re-read the create sails past the stale status check and INSERTS a
;; pull request for a branch the merge already closed.
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "contested")
branch-id (:id branch)
branch-file-id (:branch-file-id branch)]
(add-color* author branch-file-id "Brand")
(let [orig-lock db/xact-lock!
merging? (atom false)
merged (atom nil)]
(with-redefs [db/xact-lock!
(fn [conn id]
;; the first lock the create takes is the signal:
;; merge the same branch through the pool in its
;; own transaction BEFORE the create locks
(when (compare-and-set! merging? false true)
(reset! merged (th/command! {::th/type :merge-file-branch
::rpc/profile-id (:id author)
:branch-id branch-id
:keep-branch true})))
(orig-lock conn id))]
(let [out (th/command! {::th/type :create-pull-request
::rpc/profile-id (:id author)
:branch-id branch-id
:title "review me"})]
(t/is (= :merged (-> @merged :result :status)))
(t/is (= "merged" (:status (first (th/db-query :file-branch {:id branch-id})))))
(t/is (= :branch-not-open (-> out :error ex-data :code)))
(t/is (= [] (th/db-query :file-pull-request {:file-branch-id branch-id})))))))))
(t/deftest reopen-serializes-against-a-kept-concurrent-merge
;; same race for the reopen: the kept merge leaves the branch row
;; readable with status "merged", so without the re-read the reopen
;; sails past the stale status check and REOPENS the closed pull
;; request over a branch the merge already closed.
(with-redefs [cf/flags pr-flags]
(let [author (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id author)
:project-id (:default-project-id author)})
branch (create-branch* author file "contested")
branch-id (:id branch)
branch-file-id (:branch-file-id branch)]
(add-color* author branch-file-id "Brand")
(let [pr (:result (create-pr* author branch-id {}))]
(t/is (nil? (:error (th/command! {::th/type :close-pull-request
::rpc/profile-id (:id author)
:id (:id pr)}))))
(let [orig-lock db/xact-lock!
merging? (atom false)
merged (atom nil)]
(with-redefs [db/xact-lock!
(fn [conn id]
;; the first lock the reopen takes is the signal:
;; merge the same branch through the pool in its
;; own transaction BEFORE the reopen locks
(when (compare-and-set! merging? false true)
(reset! merged (th/command! {::th/type :merge-file-branch
::rpc/profile-id (:id author)
:branch-id branch-id
:keep-branch true})))
(orig-lock conn id))]
(let [out (th/command! {::th/type :reopen-pull-request
::rpc/profile-id (:id author)
:id (:id pr)})]
(t/is (= :merged (-> @merged :result :status)))
(t/is (= "merged" (:status (first (th/db-query :file-branch {:id branch-id})))))
(t/is (= :branch-not-open (-> out :error ex-data :code)))
(t/is (= "closed" (:status (first (th/db-query :file-pull-request {:id (:id pr)}))))))))))))