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;