cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Move away from cgit to more flexible linking to repositories

Browse source
This commit is contained in:
Christopher Baines 2025-05-24 22:55:35 +01:00
parent 36f30551cb
commit 5717ce82ce
19 changed files with 405 additions and 262 deletions
Download patch file Download diff file Expand all files Collapse all files

5
guix-data-service/branch-updated-emails.scm
View file

@ -83,7 +83,7 @@
(select-git-repository conn git-repository-id)) (select-git-repository conn git-repository-id))
(channel-for-commit (channel-for-commit
(channel (name 'guix) (channel (name 'guix)
(url (second git-repository-details)) (url (assq-ref git-repository-details 'url))
(commit x-git-newrev))) (commit x-git-newrev)))
(channel-instance (channel-instance
;; Obtain a session level lock here, to avoid conflicts with ;; Obtain a session level lock here, to avoid conflicts with
@ -100,7 +100,8 @@
(latest-channel-instances store (latest-channel-instances store
(list channel-for-commit) (list channel-for-commit)
#:authenticate? #:authenticate?
(fourth git-repository-details))))))))) (assq-ref git-repository-details
'fetch-with-authentication?)))))))))
(when (string=? (channel-instance-commit channel-instance) (when (string=? (channel-instance-commit channel-instance)
x-git-newrev) x-git-newrev)

4
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -2548,9 +2548,9 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
(let* ((git-repository-fields (let* ((git-repository-fields
(select-git-repository conn git-repository-id)) (select-git-repository conn git-repository-id))
(git-repository-url (git-repository-url
(second git-repository-fields)) (assq-ref git-repository-fields 'url))
(fetch-with-authentication? (fetch-with-authentication?
(fourth git-repository-fields)) (assq-ref git-repository-fields 'fetch-with-authentication?))
(channel-for-commit (channel-for-commit
(channel (name 'guix) (channel (name 'guix)
(url git-repository-url) (url git-repository-url)

16
guix-data-service/model/git-branch.scm
View file

@ -21,6 +21,7 @@
#:use-module (squee) #:use-module (squee)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (guix-data-service model utils) #:use-module (guix-data-service model utils)
#:use-module (guix-data-service model git-repository)
#:export (git-branch-for-repository-and-name #:export (git-branch-for-repository-and-name
insert-git-branch-entry insert-git-branch-entry
git-branches-for-commit 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 (git-branches-with-repository-details-for-commit conn commit)
(define query (define query
" "
SELECT git_repositories.id, git_repositories.label, SELECT git_repositories.id, git_branches.name, git_commits.datetime
git_repositories.url, git_repositories.cgit_url_base,
git_branches.name, git_commits.datetime
FROM git_commits FROM git_commits
INNER JOIN git_branches INNER JOIN git_branches
ON git_commits.git_branch_id = git_branches.id 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 ON git_branches.git_repository_id = git_repositories.id
WHERE git_commits.commit = $1") WHERE git_commits.commit = $1")
(group-list-by-first-n-fields (map
4 (match-lambda
(exec-query conn query (list commit)))) (((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* (latest-processed-commit-for-branch conn repository-id branch-name)
(define query (define query

137
guix-data-service/model/git-repository.scm
View file

@ -18,6 +18,7 @@
(define-module (guix-data-service model git-repository) (define-module (guix-data-service model git-repository)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 string-fun)
#:use-module (json) #:use-module (json)
#:use-module (squee) #:use-module (squee)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
@ -34,28 +35,78 @@
git-repository-url->git-repository-id git-repository-url->git-repository-id
git-repositories-containing-commit 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) (define (all-git-repositories conn)
(map (map
(match-lambda git-repository->alist
((id label url cgit-base-url poll-interval)
(list (string->number id)
label
url
cgit-base-url
(and=> poll-interval string->number))))
(exec-query (exec-query
conn conn
" "
SELECT id, label, url, cgit_url_base, poll_interval SELECT * FROM git_repositories ORDER BY id ASC")))
FROM git_repositories ORDER BY id ASC")))
(define (select-git-repository conn id) (define (select-git-repository conn id)
(match (exec-query (match (exec-query
conn conn
" "
SELECT label, url, cgit_url_base, fetch_with_authentication, poll_interval SELECT *
FROM git_repositories FROM git_repositories
WHERE id = $1" WHERE id = $1"
(list (if (number? id) (list (if (number? id)
@ -63,12 +114,8 @@ WHERE id = $1"
id))) id)))
(() (()
#f) #f)
(((label url cgit_url_base fetch_with_authentication poll-interval)) ((fields)
(list label (git-repository->alist fields))))
url
cgit_url_base
(string=? fetch_with_authentication "t")
(and=> poll-interval string->number)))))
(define (specify-git-repositories repositories) (define (specify-git-repositories repositories)
(with-postgresql-connection (with-postgresql-connection
@ -78,14 +125,16 @@ WHERE id = $1"
conn conn
(lambda (conn) (lambda (conn)
(let* ((existing-ids (let* ((existing-ids
(map first (all-git-repositories conn))) (map (lambda (details)
(assq-ref details 'id))
(all-git-repositories conn)))
(target-ids (target-ids
(map (lambda (repo) (map (lambda (repo)
(or (assq-ref repo 'id) (or (assq-ref repo 'id)
(error "repository missing id"))) (error "repository missing id")))
repositories)) repositories))
(repositories-to-delete (repositories-to-delete
(lset-difference equal? (lset-difference =
existing-ids existing-ids
target-ids))) target-ids)))
(for-each (for-each
@ -128,17 +177,6 @@ WHERE id = $1"
(((url)) url))) (((url)) url)))
(define (select-includes-and-excluded-branches-for-git-repository conn id) (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 (match (exec-query-with-null-handling
conn conn
" "
@ -240,7 +278,7 @@ ORDER BY 1 DESC NULLS FIRST, 2 DESC LIMIT 10;")
(define (git-repositories-containing-commit conn commit) (define (git-repositories-containing-commit conn commit)
(define query (define query
" "
SELECT id, label, url, cgit_url_base SELECT *
FROM git_repositories WHERE id IN ( FROM git_repositories WHERE id IN (
SELECT git_repository_id SELECT git_repository_id
FROM git_branches FROM git_branches
@ -249,4 +287,39 @@ FROM git_repositories WHERE id IN (
WHERE commit = $1 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)))

8
guix-data-service/model/guix-revision.scm
View file

@ -28,7 +28,7 @@
guix-commit-exists? guix-commit-exists?
guix-revision-exists? guix-revision-exists?
select-guix-revision-for-branch-and-datetime select-guix-revision-for-branch-and-datetime
guix-revisions-cgit-url-bases)) guix-revisions-commit-range-link-url-templates))
(define (count-guix-revisions conn) (define (count-guix-revisions conn)
(match (exec-query (match (exec-query
@ -115,15 +115,15 @@ LIMIT 1")
(() #f) (() #f)
((result) result))) ((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 (map
car car
(exec-query (exec-query
conn conn
(simple-format #f " (simple-format #f "
SELECT cgit_url_base SELECT commit_range_link_url_template
FROM git_repositories 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 SELECT git_repository_id
FROM guix_revisions FROM guix_revisions
WHERE id IN (VALUES ~A));" WHERE id IN (VALUES ~A));"

14
guix-data-service/poll-git-repository.scm
View file

@ -71,10 +71,12 @@
#:unwind? #t) #:unwind? #t)
(and=> (and=>
(fifth (select-git-repository conn git-repository-id)) (select-git-repository conn git-repository-id)
(lambda (poll-interval) (lambda (details)
(sleep poll-interval) (and=> (assq-ref details 'poll-interval)
(loop))))))))) (lambda (poll-interval)
(sleep poll-interval)
(loop)))))))))))
(define* (just-update-cached-checkout url (define* (just-update-cached-checkout url
#:key #:key
@ -117,11 +119,11 @@
;; I just want to update the cached checkout though, so trying to ;; I just want to update the cached checkout though, so trying to
;; checkout some revision is unnecessary, hence ;; checkout some revision is unnecessary, hence
;; just-update-cached-checkout ;; 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 (let* ((repository-directory
(url-cache-directory (url-cache-directory
(second git-repository-details))) (assq-ref git-repository-details 'url)))
(included-branches (included-branches
excluded-branches excluded-branches

60
guix-data-service/substitutes.scm
View file

@ -224,31 +224,39 @@
"exception when querying substitutes: ~A\n" "exception when querying substitutes: ~A\n"
exn)) exn))
(lambda () (lambda ()
(with-postgresql-connection (with-exception-handler
"substitute-query-thread" (lambda (exn)
(lambda (conn) (backtrace)
(for-each (raise-exception exn))
(match-lambda (lambda ()
((git-repository-id rest ...) (with-postgresql-connection
(when (git-repository-query-substitutes? conn git-repository-id) "substitute-query-thread"
(for-each (lambda (conn)
(match-lambda (for-each
((branch-name rest ...) (lambda (git-repository-details)
(and=> (latest-processed-commit-for-branch (let ((git-repository-id
conn (assq-ref git-repository-details 'id)))
(number->string git-repository-id) (when (git-repository-query-substitutes?
branch-name) conn
(lambda (commit) git-repository-id)
(query-build-server-substitutes (for-each
conn (match-lambda
#f ;; All build servers ((branch-name rest ...)
(list commit) (and=> (latest-processed-commit-for-branch
#f))))) conn
(all-branches-with-most-recent-commit (number->string git-repository-id)
conn branch-name)
git-repository-id))))) (lambda (commit)
(all-git-repositories conn)))) (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") (simple-format #t "finished checking substitutes, now sleeping\n")
(sleep (* 60 30))) (sleep (* 60 30)))))
#:unwind? #t))))) #:unwind? #t)))))

32
guix-data-service/web/compare/controller.scm
View file

@ -399,24 +399,24 @@
#:extra-headers http-headers-for-unchanging-content)) #:extra-headers http-headers-for-unchanging-content))
(else (else
(fibers-let ((lint-warnings-locale-options (fibers-let ((lint-warnings-locale-options
(map (map
(match-lambda (match-lambda
((locale) ((locale)
locale)) locale))
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(lint-warning-message-locales-for-revision (lint-warning-message-locales-for-revision
conn conn
(assq-ref query-parameters 'target_commit))))) (assq-ref query-parameters 'target_commit)))))
(cgit-url-bases (commit-range-link-url-templates
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(guix-revisions-cgit-url-bases (guix-revisions-commit-range-link-url-templates
conn conn
(list base-revision-id (list base-revision-id
target-revision-id))))) target-revision-id)))))
(render-html (render-html
#:sxml (compare query-parameters #:sxml (compare query-parameters
'revision 'revision
cgit-url-bases commit-range-link-url-templates
new-packages new-packages
removed-packages removed-packages
version-changes version-changes
@ -555,7 +555,7 @@
(target_commit . ,(second target-revision-details))) (target_commit . ,(second target-revision-details)))
'datetime 'datetime
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(guix-revisions-cgit-url-bases (guix-revisions-commit-range-link-url-templates
conn conn
(list base-revision-id (list base-revision-id
target-revision-id))) target-revision-id)))

52
guix-data-service/web/compare/html.scm
View file

@ -24,6 +24,7 @@
#:use-module (texinfo) #:use-module (texinfo)
#:use-module (texinfo html) #:use-module (texinfo html)
#:use-module (guix-data-service utils) #: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 query-parameters)
#:use-module (guix-data-service web util) #:use-module (guix-data-service web util)
#:use-module (guix-data-service web html-utils) #:use-module (guix-data-service web html-utils)
@ -75,7 +76,7 @@
(define (compare query-parameters (define (compare query-parameters
mode mode
cgit-url-bases commit-range-link-url-templates
new-packages new-packages
removed-packages removed-packages
version-changes version-changes
@ -120,12 +121,12 @@
" and " " and "
(a (@ (href ,(string-append "/revision/" target-commit))) (a (@ (href ,(string-append "/revision/" target-commit)))
(samp ,(string-take target-commit 8) "…"))) (samp ,(string-take target-commit 8) "…")))
,@(if (apply string=? cgit-url-bases) ,@(if (apply string=? commit-range-link-url-templates)
`((a (@ (href ,(string-append `((a (@ (href ,(git-repository-commit-range-link-template->url
(first cgit-url-bases) (first commit-range-link-url-templates)
"log/?qt=range&q=" base-commit
base-commit ".." target-commit))) target-commit)))
"(View cgit)")) "(View)"))
'())))) '()))))
(div (div
(@ (class "col-sm-5")) (@ (class "col-sm-5"))
@ -1217,24 +1218,25 @@ enough builds to determine a change")))
(define (render-location git-repositories commit-hash (define (render-location git-repositories commit-hash
data) data)
(map (map
(match-lambda (lambda (git-repository-details)
((id label url cgit-url-base) (let ((file-link-url-template
(if (assq-ref git-repository-details
(and cgit-url-base 'file-link-url-template)))
(not (string-null? cgit-url-base))) (if file-link-url-template
(match data (match data
((('file . file) ((('file . file)
('line . line) ('line . line)
('column_number . column-number)) ('column_number . column-number))
`(a (@ (href `(a (@ (href
,(string-append ,(git-repository-file-link-template->url
cgit-url-base "tree/" file-link-url-template
file "?id=" commit-hash commit-hash
"#n" (number->string line)))) file
,file (number->string line))))
" (line: " ,line ,file
", column: " ,column-number ")"))) " (line: " ,line
'()))) ", column: " ,column-number ")")))
'())))
git-repositories)) git-repositories))
(define cells (define cells

2
guix-data-service/web/controller.scm
View file

@ -809,7 +809,7 @@
(cons (cons
git-repository-details git-repository-details
(all-branches-with-most-recent-commit (all-branches-with-most-recent-commit
conn (first git-repository-details)))) conn (assq-ref git-repository-details 'id))))
(all-git-repositories conn)))))) (all-git-repositories conn))))))
(('GET "builds") (('GET "builds")
(delegate-to build-controller)) (delegate-to build-controller))

29
guix-data-service/web/repository/controller.scm
View file

@ -16,6 +16,7 @@
;;; <http://www.gnu.org/licenses/>. ;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service web repository controller) (define-module (guix-data-service web repository controller)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (web uri) #:use-module (web uri)
#:use-module (web request) #:use-module (web request)
@ -59,11 +60,14 @@
(render-json (render-json
`((repositories `((repositories
. ,(list->vector . ,(list->vector
(map (match-lambda (map (lambda (details)
((id label url cgit-base-url _) (filter-map
`((id . ,id) (match-lambda
(label . ,label) ((key . val)
(url . ,url)))) (if (memq key '(id label url))
(cons key val)
#f)))
details))
git-repositories)))))) git-repositories))))))
(else (else
(render-html (render-html
@ -72,7 +76,7 @@
(('GET "repository" id) (('GET "repository" id)
(match (with-resource-from-pool (connection-pool) conn (match (with-resource-from-pool (connection-pool) conn
(select-git-repository conn id)) (select-git-repository conn id))
((label url cgit-url-base fetch-with-authentication? poll-interval) (git-repository-details
(fibers-let ((branches (fibers-let ((branches
(with-resource-from-pool (connection-pool) conn (with-resource-from-pool (connection-pool) conn
(all-branches-with-most-recent-commit (all-branches-with-most-recent-commit
@ -83,9 +87,13 @@
mime-types) mime-types)
((application/json) ((application/json)
(render-json (render-json
`((id . ,id) `(,@(filter-map
(label . ,label) (match-lambda
(url . ,url) ((key . val)
(if (memq key '(id label url))
(cons key val)
#f)))
git-repository-details)
(branches (branches
. ,(list->vector . ,(list->vector
(map (match-lambda (map (match-lambda
@ -98,7 +106,8 @@
#:sxml #:sxml
(view-git-repository (view-git-repository
(string->number id) (string->number id)
label url cgit-url-base (assq-ref git-repository-details 'label)
(assq-ref git-repository-details 'url)
branches)))))) branches))))))
(#f (#f
(case (most-appropriate-mime-type (case (most-appropriate-mime-type

36
guix-data-service/web/repository/html.scm
View file

@ -47,27 +47,27 @@
(@ (class "col-md-12")) (@ (class "col-md-12"))
(h1 ,page-header))) (h1 ,page-header)))
,@(map ,@(map
(match-lambda (lambda (details)
((id label url cgit-base-url) (let ((id (assq-ref details 'id))
`(div (label (assq-ref details 'label))
(@ (class "row")) (url (assq-ref details 'url)))
(div `(div
(@ (class "col-md-12")) (@ (class "row"))
(h3 ,url) (div
(a (@ (href ,(string-append "/repository/" (number->string id)))) (@ (class "col-md-12"))
"View repository") (h3 ,url)
(dl (a (@ (href ,(string-append "/repository/" id)))
(@ (class "dl-horizontal")) "View repository")
(dt "Label") (dl
(dd ,label) (@ (class "dl-horizontal"))
(dt "URL") (dt "Label")
(dd ,url) (dd ,label)
(dt "cgit base URL") (dt "URL")
(dd ,cgit-base-url)))))) (dd ,url))))))
git-repositories))))) git-repositories)))))
(define* (view-git-repository git-repository-id (define* (view-git-repository git-repository-id
label url cgit-url-base label url
branches-with-most-recent-commits) branches-with-most-recent-commits)
(define page-header (string-append "Repository " (string-drop url 8))) (define page-header (string-append "Repository " (string-drop url 8)))

214
guix-data-service/web/revision/html.scm
View file

@ -23,6 +23,7 @@
#:use-module (texinfo html) #:use-module (texinfo html)
#:use-module (json) #:use-module (json)
#:use-module (guix-data-service database) #: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 model utils)
#:use-module (guix-data-service web util) #:use-module (guix-data-service web util)
#:use-module (guix-data-service web html-utils) #:use-module (guix-data-service web html-utils)
@ -132,13 +133,14 @@
(@ (class "col-sm-12")) (@ (class "col-sm-12"))
,(append-map ,(append-map
(match-lambda (match-lambda
(((id label url cgit-url-base) . branches) ((git-repository-details . branches)
(map (match-lambda (map (match-lambda
((branch-name datetime) ((branch-name datetime)
`(a (@ (class "btn btn-default btn-lg pull-right") `(a (@ (class "btn btn-default btn-lg pull-right")
(href ,(simple-format (href ,(simple-format
#f "/repository/~A/branch/~A/package/~A" #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" ,(simple-format #f "View ~A branch version history"
branch-name)))) branch-name))))
branches))) branches)))
@ -255,20 +257,21 @@
(not (null? git-repositories))) (not (null? git-repositories)))
`((dt "Location") `((dt "Location")
(dd ,@(map (dd ,@(map
(match-lambda (lambda (git-repository-details)
((id label url cgit-url-base) (let ((file-link-url-template
(if (assq-ref git-repository-details
(and cgit-url-base 'file-link-url-template)))
(not (string-null? cgit-url-base))) (if file-link-url-template
`(a (@ (href `(a (@ (href
,(string-append ,(git-repository-file-link-template->url
cgit-url-base "tree/" file-link-url-template
file "?id=" revision-commit-hash revision-commit-hash
"#n" line))) file
,file line)))
" (line: " ,line ,file
", column: " ,column-number ")") " (line: " ,line
'()))) ", column: " ,column-number ")")
'())))
git-repositories))) git-repositories)))
'()) '())
,@(if (> (vector-length licenses) 0) ,@(if (> (vector-length licenses) 0)
@ -356,26 +359,27 @@
`((ul `((ul
(@ (class "list-unstyled")) (@ (class "list-unstyled"))
,@(map ,@(map
(match-lambda (lambda (git-repository-details)
((id label url cgit-url-base) (let ((file-link-url-template
(let ((output (assq-ref git-repository-details
`(,file 'file-link-url-template))
" " (output
(span `(,file
(@ (style "white-space: nowrap")) " "
"(line: " ,line-number (span
", column: " ,column-number ")")))) (@ (style "white-space: nowrap"))
(if "(line: " ,line-number
(and cgit-url-base ", column: " ,column-number ")"))))
(not (string-null? cgit-url-base))) (if file-link-url-template
`(li `(li
(a (@ (href (a (@ (href
,(string-append ,(git-repository-file-link-template->url
cgit-url-base "tree/" file-link-url-template
file "?id=" revision-commit-hash revision-commit-hash
"#n" line-number))) file
,@output)) line-number)))
`(li ,@output))))) ,@output))
`(li ,@output))))
git-repositories))) git-repositories)))
'()))))) '())))))
lint-warnings)))))))))) lint-warnings))))))))))
@ -385,26 +389,33 @@
`((h3 "Git repositories") `((h3 "Git repositories")
,@(map ,@(map
(match-lambda (match-lambda
(((id label url cgit-url-base) . branches) ((git-repository-details . branches)
`((a (@ (href ,(string-append `((a (@ (href ,(string-append
"/repository/" id))) "/repository/"
(h4 ,url)) (number->string
(assq-ref git-repository-details 'id)))))
(h4 ,(assq-ref git-repository-details 'url)))
,@(map ,@(map
(match-lambda (match-lambda
((name datetime) ((name datetime)
`(div `(div
(a (@ (href ,(string-append "/repository/" id (a (@ (href ,(string-append
"/branch/" name))) "/repository/"
(number->string
(assq-ref git-repository-details 'id))
"/branch/" name)))
,name) ,name)
" at " ,datetime " at " ,datetime
,@(if (string-null? cgit-url-base) ,@(let ((commit-link-url-template
'() (assq-ref git-repository-details
`(" " 'commit-link-url-template)))
(a (@ (href ,(string-append (if commit-link-url-template
cgit-url-base `(" "
"commit/?id=" (a (@ (href ,(git-repository-commit-link-template->url
commit-hash))) commit-link-url-template
"(View cgit)")))))) commit-hash)))
"(View)"))
'())))))
branches)))) branches))))
git-repositories-and-branches))) git-repositories-and-branches)))
@ -692,23 +703,24 @@
(not (string-null? location-file))) (not (string-null? location-file)))
`((ul `((ul
,@(map ,@(map
(match-lambda (lambda (git-repository-details)
((id label url cgit-url-base) (let ((file-link-url-template
(if (assq-ref git-repository-details
(and cgit-url-base 'file-link-url-template)))
(not (string-null? cgit-url-base))) (if file-link-url-template
`(li `(li
(a (@ (href (a (@ (href
,(string-append ,(git-repository-file-link-template->url
cgit-url-base "tree/" file-link-url-template
location-file "?id=" revision-commit-hash revision-commit-hash
"#n" location-line))) location-file
,location-file location-line)))
" (line: " ,location-line ,location-file
", column: " ,location-column-number ")")) " (line: " ,location-line
`(li ,location-file ", column: " ,location-column-number ")"))
" (line: " ,location-line `(li ,location-file
", column: " ,location-column-number ")")))) " (line: " ,location-line
", column: " ,location-column-number ")"))))
git-repositories))) git-repositories)))
'()))) '())))
'()) '())
@ -930,20 +942,21 @@
,(stexi->shtml ,(stexi->shtml
(texi-fragment->stexi description))) (texi-fragment->stexi description)))
(td ,@(map (td ,@(map
(match-lambda (lambda (git-repository-details)
((id label url cgit-url-base) (let ((file-link-url-template
(if (assq-ref git-repository-details
(and cgit-url-base 'file-link-url-template)))
(not (string-null? cgit-url-base))) (if file-link-url-template
`(a (@ (href `(a (@ (href
,(string-append ,(git-repository-file-link-template->url
cgit-url-base "tree/" file-link-url-template
file "?id=" commit-hash commit-hash
"#n" (number->string line)))) file
,file (number->string line))))
" (line: " ,line ,file
", column: " ,column-number ")") " (line: " ,line
'()))) ", column: " ,column-number ")")
'())))
git-repositories)) git-repositories))
(td (a (@ (href ,derivation-file-name)) (td (a (@ (href ,derivation-file-name))
,(display-store-item-short derivation-file-name))) ,(display-store-item-short derivation-file-name)))
@ -2471,26 +2484,27 @@ figure {
`((ul `((ul
(@ (class "list-unstyled")) (@ (class "list-unstyled"))
,@(map ,@(map
(match-lambda (lambda (git-repository-details)
((id label url cgit-url-base) (let ((file-link-url-template
(let ((output (assq-ref git-repository-details
`(,file 'file-link-url-template))
" " (output
(span `(,file
(@ (style "white-space: nowrap")) " "
"(line: " ,line-number (span
", column: " ,column-number ")")))) (@ (style "white-space: nowrap"))
(if "(line: " ,line-number
(and cgit-url-base ", column: " ,column-number ")"))))
(not (string-null? cgit-url-base))) (if file-link-url-template
`(li `(li
(a (@ (href (a (@ (href
,(string-append ,(git-repository-file-link-template->url
cgit-url-base "tree/" file-link-url-template
file "?id=" revision-commit-hash revision-commit-hash
"#n" line-number))) file
,@output)) (number->string line-number))))
`(li ,@output))))) ,@output))
`(li ,@output))))
git-repositories))) git-repositories)))
'()))) '())))
'())))) '()))))

17
guix-data-service/web/view/html.scm
View file

@ -309,22 +309,23 @@
"Jobs")))) "Jobs"))))
,@(map ,@(map
(match-lambda (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 `(div
(@ (class "row")) (@ (class "row"))
(div (div
(@ (class "col-sm-12")) (@ (class "col-sm-12"))
(h3 (@ (style "display: inline-block;")) (h3 (@ (style "display: inline-block;"))
,url) ,(assq-ref git-repository-details 'url))
,@(if (string-null? cgit-url-base) ,@(or (and=> (assq-ref git-repository-details 'link-url)
'() (lambda (link-url)
`((a (@ (style "padding-left: 0.8em;") `((a (@ (style "padding-left: 0.8em;")
(href ,cgit-url-base)) (href ,link-url))
"(View cgit)"))) "(View)"))))
'())
,(if (null? branches-with-most-recent-commits) ,(if (null? branches-with-most-recent-commits)
'(p "No branches") '(p "No branches")
(table/branches-with-most-recent-commits (table/branches-with-most-recent-commits
repository-id (assq-ref git-repository-details 'id)
(filter (lambda (data) (filter (lambda (data)
(not (string-null? (second data)))) (not (string-null? (second data))))
branches-with-most-recent-commits))))))) branches-with-most-recent-commits)))))))

13
scripts/guix-data-service.in
View file

@ -212,13 +212,14 @@
(for-each (for-each
(lambda (git-repository-details) (lambda (git-repository-details)
(when (fifth git-repository-details) (let ((id (assq-ref git-repository-details 'id)))
(simple-format #t "starting thread to poll ~A (~A)\n" (when (assq-ref git-repository-details
(second git-repository-details) 'poll-interval)
(third git-repository-details)) (simple-format #t "starting thread to poll ~A (~A)\n"
id
(assq-ref git-repository-details 'url))
(start-thread-to-poll-git-repository (start-thread-to-poll-git-repository id))))
(first git-repository-details))))
(with-postgresql-connection (with-postgresql-connection
"poll-startup" "poll-startup"
all-git-repositories)) all-git-repositories))

13
sqitch/deploy/git_repository_link_fields.sql Normal file
View file

@ -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;

7
sqitch/revert/git_repository_link_fields.sql Normal file
View file

@ -0,0 +1,7 @@
-- Revert guix-data-service:git_repository_link_fields from pg
BEGIN;
-- XXX Add DDLs here.
COMMIT;

1
sqitch/sqitch.plan
View file

@ -101,3 +101,4 @@ git_repositories_job_priority 2024-03-07T09:39:27Z Chris <chris@felis> # Add git
build_server_build_id_index 2024-09-07T17:42:28Z Chris <chris@felis> # Add index on builds.build_server_build_id build_server_build_id_index 2024-09-07T17:42:28Z Chris <chris@felis> # Add index on builds.build_server_build_id
alter_build_servers_id_default 2024-12-15T20:48:51Z Chris <chris@fang> # Alter build_servers id default alter_build_servers_id_default 2024-12-15T20:48:51Z Chris <chris@fang> # Alter build_servers id default
build_background_processing_queue 2025-05-14T14:18:14Z Chris <chris@fang> # Add build_background_processing_queue build_background_processing_queue 2025-05-14T14:18:14Z Chris <chris@fang> # Add build_background_processing_queue
git_repository_link_fields 2025-05-23T14:42:24Z Chris <chris@fang> # Change git repository link related fields

7
sqitch/verify/git_repository_link_fields.sql Normal file
View file

@ -0,0 +1,7 @@
-- Verify guix-data-service:git_repository_link_fields on pg
BEGIN;
-- XXX Add verifications here.
ROLLBACK;