From 5717ce82cef5a80194df1ad2b1e65de6b43329fc Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 24 May 2025 22:55:35 +0100 Subject: [PATCH] Move away from cgit to more flexible linking to repositories --- guix-data-service/branch-updated-emails.scm | 5 +- .../jobs/load-new-guix-revision.scm | 4 +- guix-data-service/model/git-branch.scm | 16 +- guix-data-service/model/git-repository.scm | 137 ++++++++--- guix-data-service/model/guix-revision.scm | 8 +- guix-data-service/poll-git-repository.scm | 14 +- guix-data-service/substitutes.scm | 60 ++--- guix-data-service/web/compare/controller.scm | 32 +-- guix-data-service/web/compare/html.scm | 52 +++-- guix-data-service/web/controller.scm | 2 +- .../web/repository/controller.scm | 29 ++- guix-data-service/web/repository/html.scm | 36 +-- guix-data-service/web/revision/html.scm | 214 ++++++++++-------- guix-data-service/web/view/html.scm | 17 +- scripts/guix-data-service.in | 13 +- sqitch/deploy/git_repository_link_fields.sql | 13 ++ sqitch/revert/git_repository_link_fields.sql | 7 + sqitch/sqitch.plan | 1 + sqitch/verify/git_repository_link_fields.sql | 7 + 19 files changed, 405 insertions(+), 262 deletions(-) create mode 100644 sqitch/deploy/git_repository_link_fields.sql create mode 100644 sqitch/revert/git_repository_link_fields.sql create mode 100644 sqitch/verify/git_repository_link_fields.sql diff --git a/guix-data-service/branch-updated-emails.scm b/guix-data-service/branch-updated-emails.scm index 2c0e992..d5adff0 100644 --- a/guix-data-service/branch-updated-emails.scm +++ b/guix-data-service/branch-updated-emails.scm @@ -83,7 +83,7 @@ (select-git-repository conn git-repository-id)) (channel-for-commit (channel (name 'guix) - (url (second git-repository-details)) + (url (assq-ref git-repository-details 'url)) (commit x-git-newrev))) (channel-instance ;; Obtain a session level lock here, to avoid conflicts with @@ -100,7 +100,8 @@ (latest-channel-instances store (list channel-for-commit) #:authenticate? - (fourth git-repository-details))))))))) + (assq-ref git-repository-details + 'fetch-with-authentication?))))))))) (when (string=? (channel-instance-commit channel-instance) x-git-newrev) diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 11fc168..84d549e 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -2548,9 +2548,9 @@ SELECT store_path FROM derivation_source_files WHERE id = $1" (let* ((git-repository-fields (select-git-repository conn git-repository-id)) (git-repository-url - (second git-repository-fields)) + (assq-ref git-repository-fields 'url)) (fetch-with-authentication? - (fourth git-repository-fields)) + (assq-ref git-repository-fields 'fetch-with-authentication?)) (channel-for-commit (channel (name 'guix) (url git-repository-url) diff --git a/guix-data-service/model/git-branch.scm b/guix-data-service/model/git-branch.scm index c4b56c0..f9b38c6 100644 --- a/guix-data-service/model/git-branch.scm +++ b/guix-data-service/model/git-branch.scm @@ -21,6 +21,7 @@ #:use-module (squee) #:use-module (srfi srfi-19) #:use-module (guix-data-service model utils) + #:use-module (guix-data-service model git-repository) #:export (git-branch-for-repository-and-name insert-git-branch-entry git-branches-for-commit @@ -69,9 +70,7 @@ ORDER BY git_commits.datetime DESC") (define (git-branches-with-repository-details-for-commit conn commit) (define query " -SELECT git_repositories.id, git_repositories.label, - git_repositories.url, git_repositories.cgit_url_base, - git_branches.name, git_commits.datetime +SELECT git_repositories.id, git_branches.name, git_commits.datetime FROM git_commits INNER JOIN git_branches ON git_commits.git_branch_id = git_branches.id @@ -79,9 +78,14 @@ INNER JOIN git_repositories ON git_branches.git_repository_id = git_repositories.id WHERE git_commits.commit = $1") - (group-list-by-first-n-fields - 4 - (exec-query conn query (list commit)))) + (map + (match-lambda + (((git-repository-id) . val) + (cons (select-git-repository conn git-repository-id) + val))) + (group-list-by-first-n-fields + 1 + (exec-query conn query (list commit))))) (define* (latest-processed-commit-for-branch conn repository-id branch-name) (define query diff --git a/guix-data-service/model/git-repository.scm b/guix-data-service/model/git-repository.scm index b5f9fbe..0e6327c 100644 --- a/guix-data-service/model/git-repository.scm +++ b/guix-data-service/model/git-repository.scm @@ -18,6 +18,7 @@ (define-module (guix-data-service model git-repository) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (ice-9 string-fun) #:use-module (json) #:use-module (squee) #:use-module (guix-data-service database) @@ -34,28 +35,78 @@ git-repository-url->git-repository-id git-repositories-containing-commit - guix-revisions-and-jobs-for-git-repository)) + guix-revisions-and-jobs-for-git-repository + + git-repository-commit-link-template->url + git-repository-commit-range-link-template->url + git-repository-file-link-template->url)) + +(define (make-regexes lst) + (map + (lambda (item) + (if (string-prefix? "/" item) + (make-regexp + (string-drop + (string-drop-right item 1) + 1)) + item)) + lst)) + +(define (not-null-string-or-#f s) + (if s + (if (string-null? s) + #f + s) + #f)) + +(define (git-repository->alist fields) + (match fields + ((id label url link_url x_git_repo_header included_branches excluded_branches + fetch_with_authentication query_substitutes + poll_interval job_priority + commit_link_url_template commit_range_link_url_template + file_link_url_template) + `((id . ,(string->number id)) + (label . ,label) + (url . ,url) + (link-url . ,(not-null-string-or-#f link_url)) + (x-git-repo-header . ,x_git_repo_header) + (included-branches + . ,(if (or (eq? #f included_branches) + (NULL? included_branches)) + included_branches + (make-regexes + (parse-postgresql-array-string included_branches)))) + (excluded-branches + . ,(if (or (eq? #f excluded_branches) + (NULL? excluded_branches)) + excluded_branches + (make-regexes + (parse-postgresql-array-string excluded_branches)))) + (fetch-with-authentication? . ,(string=? fetch_with_authentication "t")) + (query-substitutes? . ,(string=? query_substitutes "t")) + (poll-interval . ,(and=> poll_interval string->number)) + (job-priority . ,(and=> job_priority string->number)) + (commit-link-url-template . ,(not-null-string-or-#f + commit_link_url_template)) + (commit-range-link-url-template . ,(not-null-string-or-#f + commit_range_link_url_template)) + (file-link-url-template . ,(not-null-string-or-#f + file_link_url_template)))))) (define (all-git-repositories conn) (map - (match-lambda - ((id label url cgit-base-url poll-interval) - (list (string->number id) - label - url - cgit-base-url - (and=> poll-interval string->number)))) + git-repository->alist (exec-query conn " -SELECT id, label, url, cgit_url_base, poll_interval -FROM git_repositories ORDER BY id ASC"))) +SELECT * FROM git_repositories ORDER BY id ASC"))) (define (select-git-repository conn id) (match (exec-query conn " -SELECT label, url, cgit_url_base, fetch_with_authentication, poll_interval +SELECT * FROM git_repositories WHERE id = $1" (list (if (number? id) @@ -63,12 +114,8 @@ WHERE id = $1" id))) (() #f) - (((label url cgit_url_base fetch_with_authentication poll-interval)) - (list label - url - cgit_url_base - (string=? fetch_with_authentication "t") - (and=> poll-interval string->number))))) + ((fields) + (git-repository->alist fields)))) (define (specify-git-repositories repositories) (with-postgresql-connection @@ -78,14 +125,16 @@ WHERE id = $1" conn (lambda (conn) (let* ((existing-ids - (map first (all-git-repositories conn))) + (map (lambda (details) + (assq-ref details 'id)) + (all-git-repositories conn))) (target-ids (map (lambda (repo) (or (assq-ref repo 'id) (error "repository missing id"))) repositories)) (repositories-to-delete - (lset-difference equal? + (lset-difference = existing-ids target-ids))) (for-each @@ -128,17 +177,6 @@ WHERE id = $1" (((url)) url))) (define (select-includes-and-excluded-branches-for-git-repository conn id) - (define (make-regexes lst) - (map - (lambda (item) - (if (string-prefix? "/" item) - (make-regexp - (string-drop - (string-drop-right item 1) - 1)) - item)) - lst)) - (match (exec-query-with-null-handling conn " @@ -240,7 +278,7 @@ ORDER BY 1 DESC NULLS FIRST, 2 DESC LIMIT 10;") (define (git-repositories-containing-commit conn commit) (define query " -SELECT id, label, url, cgit_url_base +SELECT * FROM git_repositories WHERE id IN ( SELECT git_repository_id FROM git_branches @@ -249,4 +287,39 @@ FROM git_repositories WHERE id IN ( WHERE commit = $1 )") - (exec-query conn query (list commit))) + (map git-repository->alist (exec-query conn query (list commit)))) + +(define (git-repository-commit-link-template->url template commit) + (and template + (string-replace-substring + template + "$1" + commit))) + +(define (git-repository-commit-range-link-template->url template + base-commit + target-commit) + (and template + (string-replace-substring + (string-replace-substring + template + "$2" + target-commit) + "$1" + base-commit))) + +(define* (git-repository-file-link-template->url template + commit + file + line) + (and template + (string-replace-substring + (string-replace-substring + (string-replace-substring + template + "$3" + line) + "$2" + file) + "$1" + commit))) diff --git a/guix-data-service/model/guix-revision.scm b/guix-data-service/model/guix-revision.scm index 21e20a5..c2b0058 100644 --- a/guix-data-service/model/guix-revision.scm +++ b/guix-data-service/model/guix-revision.scm @@ -28,7 +28,7 @@ guix-commit-exists? guix-revision-exists? select-guix-revision-for-branch-and-datetime - guix-revisions-cgit-url-bases)) + guix-revisions-commit-range-link-url-templates)) (define (count-guix-revisions conn) (match (exec-query @@ -115,15 +115,15 @@ LIMIT 1") (() #f) ((result) result))) -(define (guix-revisions-cgit-url-bases conn guix-revision-ids) +(define (guix-revisions-commit-range-link-url-templates conn guix-revision-ids) (map car (exec-query conn (simple-format #f " -SELECT cgit_url_base +SELECT commit_range_link_url_template FROM git_repositories -WHERE cgit_url_base IS NOT NULL AND id IN ( +WHERE commit_range_link_url_template IS NOT NULL AND id IN ( SELECT git_repository_id FROM guix_revisions WHERE id IN (VALUES ~A));" diff --git a/guix-data-service/poll-git-repository.scm b/guix-data-service/poll-git-repository.scm index e9eb44f..b10250e 100644 --- a/guix-data-service/poll-git-repository.scm +++ b/guix-data-service/poll-git-repository.scm @@ -71,10 +71,12 @@ #:unwind? #t) (and=> - (fifth (select-git-repository conn git-repository-id)) - (lambda (poll-interval) - (sleep poll-interval) - (loop))))))))) + (select-git-repository conn git-repository-id) + (lambda (details) + (and=> (assq-ref details 'poll-interval) + (lambda (poll-interval) + (sleep poll-interval) + (loop))))))))))) (define* (just-update-cached-checkout url #:key @@ -117,11 +119,11 @@ ;; I just want to update the cached checkout though, so trying to ;; checkout some revision is unnecessary, hence ;; just-update-cached-checkout - (just-update-cached-checkout (second git-repository-details)) + (just-update-cached-checkout (assq-ref git-repository-details 'url)) (let* ((repository-directory (url-cache-directory - (second git-repository-details))) + (assq-ref git-repository-details 'url))) (included-branches excluded-branches diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm index 3ac09eb..0635122 100644 --- a/guix-data-service/substitutes.scm +++ b/guix-data-service/substitutes.scm @@ -224,31 +224,39 @@ "exception when querying substitutes: ~A\n" exn)) (lambda () - (with-postgresql-connection - "substitute-query-thread" - (lambda (conn) - (for-each - (match-lambda - ((git-repository-id rest ...) - (when (git-repository-query-substitutes? conn git-repository-id) - (for-each - (match-lambda - ((branch-name rest ...) - (and=> (latest-processed-commit-for-branch - conn - (number->string git-repository-id) - branch-name) - (lambda (commit) - (query-build-server-substitutes - conn - #f ;; All build servers - (list commit) - #f))))) - (all-branches-with-most-recent-commit - conn - git-repository-id))))) - (all-git-repositories conn)))) + (with-exception-handler + (lambda (exn) + (backtrace) + (raise-exception exn)) + (lambda () + (with-postgresql-connection + "substitute-query-thread" + (lambda (conn) + (for-each + (lambda (git-repository-details) + (let ((git-repository-id + (assq-ref git-repository-details 'id))) + (when (git-repository-query-substitutes? + conn + git-repository-id) + (for-each + (match-lambda + ((branch-name rest ...) + (and=> (latest-processed-commit-for-branch + conn + (number->string git-repository-id) + branch-name) + (lambda (commit) + (query-build-server-substitutes + conn + #f ;; All build servers + (list commit) + #f))))) + (all-branches-with-most-recent-commit + conn + git-repository-id))))) + (all-git-repositories conn)))) - (simple-format #t "finished checking substitutes, now sleeping\n") - (sleep (* 60 30))) + (simple-format #t "finished checking substitutes, now sleeping\n") + (sleep (* 60 30))))) #:unwind? #t))))) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index dbb4975..da6b73a 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -399,24 +399,24 @@ #:extra-headers http-headers-for-unchanging-content)) (else (fibers-let ((lint-warnings-locale-options - (map - (match-lambda - ((locale) - locale)) - (with-resource-from-pool (connection-pool) conn - (lint-warning-message-locales-for-revision - conn - (assq-ref query-parameters 'target_commit))))) - (cgit-url-bases - (with-resource-from-pool (connection-pool) conn - (guix-revisions-cgit-url-bases - conn - (list base-revision-id - target-revision-id))))) + (map + (match-lambda + ((locale) + locale)) + (with-resource-from-pool (connection-pool) conn + (lint-warning-message-locales-for-revision + conn + (assq-ref query-parameters 'target_commit))))) + (commit-range-link-url-templates + (with-resource-from-pool (connection-pool) conn + (guix-revisions-commit-range-link-url-templates + conn + (list base-revision-id + target-revision-id))))) (render-html #:sxml (compare query-parameters 'revision - cgit-url-bases + commit-range-link-url-templates new-packages removed-packages version-changes @@ -555,7 +555,7 @@ (target_commit . ,(second target-revision-details))) 'datetime (with-resource-from-pool (connection-pool) conn - (guix-revisions-cgit-url-bases + (guix-revisions-commit-range-link-url-templates conn (list base-revision-id target-revision-id))) diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm index 9f89b78..6c43f8e 100644 --- a/guix-data-service/web/compare/html.scm +++ b/guix-data-service/web/compare/html.scm @@ -24,6 +24,7 @@ #:use-module (texinfo) #:use-module (texinfo html) #:use-module (guix-data-service utils) + #:use-module (guix-data-service model git-repository) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) #:use-module (guix-data-service web html-utils) @@ -75,7 +76,7 @@ (define (compare query-parameters mode - cgit-url-bases + commit-range-link-url-templates new-packages removed-packages version-changes @@ -120,12 +121,12 @@ " and " (a (@ (href ,(string-append "/revision/" target-commit))) (samp ,(string-take target-commit 8) "…"))) - ,@(if (apply string=? cgit-url-bases) - `((a (@ (href ,(string-append - (first cgit-url-bases) - "log/?qt=range&q=" - base-commit ".." target-commit))) - "(View cgit)")) + ,@(if (apply string=? commit-range-link-url-templates) + `((a (@ (href ,(git-repository-commit-range-link-template->url + (first commit-range-link-url-templates) + base-commit + target-commit))) + "(View)")) '())))) (div (@ (class "col-sm-5")) @@ -1217,24 +1218,25 @@ enough builds to determine a change"))) (define (render-location git-repositories commit-hash data) (map - (match-lambda - ((id label url cgit-url-base) - (if - (and cgit-url-base - (not (string-null? cgit-url-base))) - (match data - ((('file . file) - ('line . line) - ('column_number . column-number)) - `(a (@ (href - ,(string-append - cgit-url-base "tree/" - file "?id=" commit-hash - "#n" (number->string line)))) - ,file - " (line: " ,line - ", column: " ,column-number ")"))) - '()))) + (lambda (git-repository-details) + (let ((file-link-url-template + (assq-ref git-repository-details + 'file-link-url-template))) + (if file-link-url-template + (match data + ((('file . file) + ('line . line) + ('column_number . column-number)) + `(a (@ (href + ,(git-repository-file-link-template->url + file-link-url-template + commit-hash + file + (number->string line)))) + ,file + " (line: " ,line + ", column: " ,column-number ")"))) + '()))) git-repositories)) (define cells diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 1c2c589..35055b5 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -809,7 +809,7 @@ (cons git-repository-details (all-branches-with-most-recent-commit - conn (first git-repository-details)))) + conn (assq-ref git-repository-details 'id)))) (all-git-repositories conn)))))) (('GET "builds") (delegate-to build-controller)) diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index ceb7b0c..60a148b 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -16,6 +16,7 @@ ;;; . (define-module (guix-data-service web repository controller) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (web uri) #:use-module (web request) @@ -59,11 +60,14 @@ (render-json `((repositories . ,(list->vector - (map (match-lambda - ((id label url cgit-base-url _) - `((id . ,id) - (label . ,label) - (url . ,url)))) + (map (lambda (details) + (filter-map + (match-lambda + ((key . val) + (if (memq key '(id label url)) + (cons key val) + #f))) + details)) git-repositories)))))) (else (render-html @@ -72,7 +76,7 @@ (('GET "repository" id) (match (with-resource-from-pool (connection-pool) conn (select-git-repository conn id)) - ((label url cgit-url-base fetch-with-authentication? poll-interval) + (git-repository-details (fibers-let ((branches (with-resource-from-pool (connection-pool) conn (all-branches-with-most-recent-commit @@ -83,9 +87,13 @@ mime-types) ((application/json) (render-json - `((id . ,id) - (label . ,label) - (url . ,url) + `(,@(filter-map + (match-lambda + ((key . val) + (if (memq key '(id label url)) + (cons key val) + #f))) + git-repository-details) (branches . ,(list->vector (map (match-lambda @@ -98,7 +106,8 @@ #:sxml (view-git-repository (string->number id) - label url cgit-url-base + (assq-ref git-repository-details 'label) + (assq-ref git-repository-details 'url) branches)))))) (#f (case (most-appropriate-mime-type diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm index 464ce27..b420f44 100644 --- a/guix-data-service/web/repository/html.scm +++ b/guix-data-service/web/repository/html.scm @@ -47,27 +47,27 @@ (@ (class "col-md-12")) (h1 ,page-header))) ,@(map - (match-lambda - ((id label url cgit-base-url) - `(div - (@ (class "row")) - (div - (@ (class "col-md-12")) - (h3 ,url) - (a (@ (href ,(string-append "/repository/" (number->string id)))) - "View repository") - (dl - (@ (class "dl-horizontal")) - (dt "Label") - (dd ,label) - (dt "URL") - (dd ,url) - (dt "cgit base URL") - (dd ,cgit-base-url)))))) + (lambda (details) + (let ((id (assq-ref details 'id)) + (label (assq-ref details 'label)) + (url (assq-ref details 'url))) + `(div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (h3 ,url) + (a (@ (href ,(string-append "/repository/" id))) + "View repository") + (dl + (@ (class "dl-horizontal")) + (dt "Label") + (dd ,label) + (dt "URL") + (dd ,url)))))) git-repositories))))) (define* (view-git-repository git-repository-id - label url cgit-url-base + label url branches-with-most-recent-commits) (define page-header (string-append "Repository " (string-drop url 8))) diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm index 412eb6e..04133ad 100644 --- a/guix-data-service/web/revision/html.scm +++ b/guix-data-service/web/revision/html.scm @@ -23,6 +23,7 @@ #:use-module (texinfo html) #:use-module (json) #:use-module (guix-data-service database) + #:use-module (guix-data-service model git-repository) #:use-module (guix-data-service model utils) #:use-module (guix-data-service web util) #:use-module (guix-data-service web html-utils) @@ -132,13 +133,14 @@ (@ (class "col-sm-12")) ,(append-map (match-lambda - (((id label url cgit-url-base) . branches) + ((git-repository-details . branches) (map (match-lambda ((branch-name datetime) `(a (@ (class "btn btn-default btn-lg pull-right") (href ,(simple-format #f "/repository/~A/branch/~A/package/~A" - id branch-name name))) + (assq-ref git-repository-details 'id) + branch-name name))) ,(simple-format #f "View ~A branch version history" branch-name)))) branches))) @@ -255,20 +257,21 @@ (not (null? git-repositories))) `((dt "Location") (dd ,@(map - (match-lambda - ((id label url cgit-url-base) - (if - (and cgit-url-base - (not (string-null? cgit-url-base))) - `(a (@ (href - ,(string-append - cgit-url-base "tree/" - file "?id=" revision-commit-hash - "#n" line))) - ,file - " (line: " ,line - ", column: " ,column-number ")") - '()))) + (lambda (git-repository-details) + (let ((file-link-url-template + (assq-ref git-repository-details + 'file-link-url-template))) + (if file-link-url-template + `(a (@ (href + ,(git-repository-file-link-template->url + file-link-url-template + revision-commit-hash + file + line))) + ,file + " (line: " ,line + ", column: " ,column-number ")") + '()))) git-repositories))) '()) ,@(if (> (vector-length licenses) 0) @@ -356,26 +359,27 @@ `((ul (@ (class "list-unstyled")) ,@(map - (match-lambda - ((id label url cgit-url-base) - (let ((output - `(,file - " " - (span - (@ (style "white-space: nowrap")) - "(line: " ,line-number - ", column: " ,column-number ")")))) - (if - (and cgit-url-base - (not (string-null? cgit-url-base))) - `(li - (a (@ (href - ,(string-append - cgit-url-base "tree/" - file "?id=" revision-commit-hash - "#n" line-number))) - ,@output)) - `(li ,@output))))) + (lambda (git-repository-details) + (let ((file-link-url-template + (assq-ref git-repository-details + 'file-link-url-template)) + (output + `(,file + " " + (span + (@ (style "white-space: nowrap")) + "(line: " ,line-number + ", column: " ,column-number ")")))) + (if file-link-url-template + `(li + (a (@ (href + ,(git-repository-file-link-template->url + file-link-url-template + revision-commit-hash + file + line-number))) + ,@output)) + `(li ,@output)))) git-repositories))) '()))))) lint-warnings)))))))))) @@ -385,26 +389,33 @@ `((h3 "Git repositories") ,@(map (match-lambda - (((id label url cgit-url-base) . branches) + ((git-repository-details . branches) `((a (@ (href ,(string-append - "/repository/" id))) - (h4 ,url)) + "/repository/" + (number->string + (assq-ref git-repository-details 'id))))) + (h4 ,(assq-ref git-repository-details 'url))) ,@(map (match-lambda ((name datetime) `(div - (a (@ (href ,(string-append "/repository/" id - "/branch/" name))) + (a (@ (href ,(string-append + "/repository/" + (number->string + (assq-ref git-repository-details 'id)) + "/branch/" name))) ,name) " at " ,datetime - ,@(if (string-null? cgit-url-base) - '() - `(" " - (a (@ (href ,(string-append - cgit-url-base - "commit/?id=" - commit-hash))) - "(View cgit)")))))) + ,@(let ((commit-link-url-template + (assq-ref git-repository-details + 'commit-link-url-template))) + (if commit-link-url-template + `(" " + (a (@ (href ,(git-repository-commit-link-template->url + commit-link-url-template + commit-hash))) + "(View)")) + '()))))) branches)))) git-repositories-and-branches))) @@ -692,23 +703,24 @@ (not (string-null? location-file))) `((ul ,@(map - (match-lambda - ((id label url cgit-url-base) - (if - (and cgit-url-base - (not (string-null? cgit-url-base))) - `(li - (a (@ (href - ,(string-append - cgit-url-base "tree/" - location-file "?id=" revision-commit-hash - "#n" location-line))) - ,location-file - " (line: " ,location-line - ", column: " ,location-column-number ")")) - `(li ,location-file - " (line: " ,location-line - ", column: " ,location-column-number ")")))) + (lambda (git-repository-details) + (let ((file-link-url-template + (assq-ref git-repository-details + 'file-link-url-template))) + (if file-link-url-template + `(li + (a (@ (href + ,(git-repository-file-link-template->url + file-link-url-template + revision-commit-hash + location-file + location-line))) + ,location-file + " (line: " ,location-line + ", column: " ,location-column-number ")")) + `(li ,location-file + " (line: " ,location-line + ", column: " ,location-column-number ")")))) git-repositories))) '()))) '()) @@ -930,20 +942,21 @@ ,(stexi->shtml (texi-fragment->stexi description))) (td ,@(map - (match-lambda - ((id label url cgit-url-base) - (if - (and cgit-url-base - (not (string-null? cgit-url-base))) - `(a (@ (href - ,(string-append - cgit-url-base "tree/" - file "?id=" commit-hash - "#n" (number->string line)))) - ,file - " (line: " ,line - ", column: " ,column-number ")") - '()))) + (lambda (git-repository-details) + (let ((file-link-url-template + (assq-ref git-repository-details + 'file-link-url-template))) + (if file-link-url-template + `(a (@ (href + ,(git-repository-file-link-template->url + file-link-url-template + commit-hash + file + (number->string line)))) + ,file + " (line: " ,line + ", column: " ,column-number ")") + '()))) git-repositories)) (td (a (@ (href ,derivation-file-name)) ,(display-store-item-short derivation-file-name))) @@ -2471,26 +2484,27 @@ figure { `((ul (@ (class "list-unstyled")) ,@(map - (match-lambda - ((id label url cgit-url-base) - (let ((output - `(,file - " " - (span - (@ (style "white-space: nowrap")) - "(line: " ,line-number - ", column: " ,column-number ")")))) - (if - (and cgit-url-base - (not (string-null? cgit-url-base))) - `(li - (a (@ (href - ,(string-append - cgit-url-base "tree/" - file "?id=" revision-commit-hash - "#n" line-number))) - ,@output)) - `(li ,@output))))) + (lambda (git-repository-details) + (let ((file-link-url-template + (assq-ref git-repository-details + 'file-link-url-template)) + (output + `(,file + " " + (span + (@ (style "white-space: nowrap")) + "(line: " ,line-number + ", column: " ,column-number ")")))) + (if file-link-url-template + `(li + (a (@ (href + ,(git-repository-file-link-template->url + file-link-url-template + revision-commit-hash + file + (number->string line-number)))) + ,@output)) + `(li ,@output)))) git-repositories))) '()))) '())))) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 543253d..632daee 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -309,22 +309,23 @@ "Jobs")))) ,@(map (match-lambda - (((repository-id label url cgit-url-base poll-interval) . branches-with-most-recent-commits) + ((git-repository-details . branches-with-most-recent-commits) `(div (@ (class "row")) (div (@ (class "col-sm-12")) (h3 (@ (style "display: inline-block;")) - ,url) - ,@(if (string-null? cgit-url-base) - '() - `((a (@ (style "padding-left: 0.8em;") - (href ,cgit-url-base)) - "(View cgit)"))) + ,(assq-ref git-repository-details 'url)) + ,@(or (and=> (assq-ref git-repository-details 'link-url) + (lambda (link-url) + `((a (@ (style "padding-left: 0.8em;") + (href ,link-url)) + "(View)")))) + '()) ,(if (null? branches-with-most-recent-commits) '(p "No branches") (table/branches-with-most-recent-commits - repository-id + (assq-ref git-repository-details 'id) (filter (lambda (data) (not (string-null? (second data)))) branches-with-most-recent-commits))))))) diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in index 238483d..527ff5a 100644 --- a/scripts/guix-data-service.in +++ b/scripts/guix-data-service.in @@ -212,13 +212,14 @@ (for-each (lambda (git-repository-details) - (when (fifth git-repository-details) - (simple-format #t "starting thread to poll ~A (~A)\n" - (second git-repository-details) - (third git-repository-details)) + (let ((id (assq-ref git-repository-details 'id))) + (when (assq-ref git-repository-details + 'poll-interval) + (simple-format #t "starting thread to poll ~A (~A)\n" + id + (assq-ref git-repository-details 'url)) - (start-thread-to-poll-git-repository - (first git-repository-details)))) + (start-thread-to-poll-git-repository id)))) (with-postgresql-connection "poll-startup" all-git-repositories)) diff --git a/sqitch/deploy/git_repository_link_fields.sql b/sqitch/deploy/git_repository_link_fields.sql new file mode 100644 index 0000000..d468441 --- /dev/null +++ b/sqitch/deploy/git_repository_link_fields.sql @@ -0,0 +1,13 @@ +-- Deploy guix-data-service:git_repository_link_fields to pg + +BEGIN; + +ALTER TABLE git_repositories RENAME COLUMN cgit_url_base TO link_url; + +ALTER TABLE git_repositories ADD COLUMN commit_link_url_template varchar; + +ALTER TABLE git_repositories ADD COLUMN commit_range_link_url_template varchar; + +ALTER TABLE git_repositories ADD COLUMN file_link_url_template varchar; + +COMMIT; diff --git a/sqitch/revert/git_repository_link_fields.sql b/sqitch/revert/git_repository_link_fields.sql new file mode 100644 index 0000000..fc6db96 --- /dev/null +++ b/sqitch/revert/git_repository_link_fields.sql @@ -0,0 +1,7 @@ +-- Revert guix-data-service:git_repository_link_fields from pg + +BEGIN; + +-- XXX Add DDLs here. + +COMMIT; diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan index c5469e8..723700f 100644 --- a/sqitch/sqitch.plan +++ b/sqitch/sqitch.plan @@ -101,3 +101,4 @@ git_repositories_job_priority 2024-03-07T09:39:27Z Chris # Add git build_server_build_id_index 2024-09-07T17:42:28Z Chris # Add index on builds.build_server_build_id alter_build_servers_id_default 2024-12-15T20:48:51Z Chris # Alter build_servers id default build_background_processing_queue 2025-05-14T14:18:14Z Chris # Add build_background_processing_queue +git_repository_link_fields 2025-05-23T14:42:24Z Chris # Change git repository link related fields diff --git a/sqitch/verify/git_repository_link_fields.sql b/sqitch/verify/git_repository_link_fields.sql new file mode 100644 index 0000000..cf967d0 --- /dev/null +++ b/sqitch/verify/git_repository_link_fields.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:git_repository_link_fields on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK;