2019-12-26 11:16:55 +01:00
|
|
|
;;; Guix Data Service -- Information about Guix over time
|
|
|
|
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
|
|
|
|
;;;
|
|
|
|
;;; This program is free software: you can redistribute it and/or
|
|
|
|
;;; modify it under the terms of the GNU Affero General Public License
|
|
|
|
;;; as published by the Free Software Foundation, either version 3 of
|
|
|
|
;;; the License, or (at your option) any later version.
|
|
|
|
;;;
|
|
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
|
;;; Affero General Public License for more details.
|
|
|
|
;;;
|
|
|
|
;;; You should have received a copy of the GNU Affero General Public
|
|
|
|
;;; License along with this program. If not, see
|
|
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
|
2019-05-05 14:35:48 +02:00
|
|
|
(define-module (guix-data-service model git-repository)
|
|
|
|
#:use-module (ice-9 match)
|
2019-06-20 00:12:20 +02:00
|
|
|
#:use-module (json)
|
2019-05-05 14:35:48 +02:00
|
|
|
#:use-module (squee)
|
2020-02-08 13:03:41 +01:00
|
|
|
#:use-module (guix-data-service model utils)
|
2019-05-05 14:35:48 +02:00
|
|
|
#:export (all-git-repositories
|
2019-07-19 22:22:15 +02:00
|
|
|
select-git-repository
|
2022-09-09 13:39:38 +02:00
|
|
|
git-repository-query-substitutes?
|
2019-05-05 14:35:48 +02:00
|
|
|
git-repository-id->url
|
2020-02-08 13:03:41 +01:00
|
|
|
select-includes-and-excluded-branches-for-git-repository
|
2020-02-01 13:59:41 +01:00
|
|
|
count-git-repositories-with-x-git-repo-header-values
|
2020-01-11 18:25:08 +01:00
|
|
|
git-repository-x-git-repo-header->git-repository-id
|
2019-05-05 14:35:48 +02:00
|
|
|
git-repository-url->git-repository-id
|
2019-05-13 22:02:53 +02:00
|
|
|
git-repositories-containing-commit
|
2019-05-05 14:35:48 +02:00
|
|
|
|
|
|
|
guix-revisions-and-jobs-for-git-repository))
|
|
|
|
|
|
|
|
(define (all-git-repositories conn)
|
2019-09-05 16:40:39 +02:00
|
|
|
(map
|
|
|
|
(match-lambda
|
|
|
|
((id label url cgit-base-url)
|
|
|
|
(list (string->number id)
|
|
|
|
label
|
|
|
|
url
|
|
|
|
cgit-base-url)))
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
(string-append
|
|
|
|
"SELECT id, label, url, cgit_url_base FROM git_repositories ORDER BY id ASC"))))
|
2019-05-05 14:35:48 +02:00
|
|
|
|
2019-07-19 22:22:15 +02:00
|
|
|
(define (select-git-repository conn id)
|
|
|
|
(match (exec-query
|
|
|
|
conn
|
2020-10-07 19:50:13 +02:00
|
|
|
"SELECT label, url, cgit_url_base, fetch_with_authentication FROM git_repositories WHERE id = $1"
|
2019-07-19 22:22:15 +02:00
|
|
|
(list id))
|
|
|
|
(()
|
|
|
|
#f)
|
2020-10-07 19:50:13 +02:00
|
|
|
(((label url cgit_url_base fetch_with_authentication))
|
|
|
|
(list label
|
|
|
|
url
|
|
|
|
cgit_url_base
|
|
|
|
(string=? fetch_with_authentication "t")))))
|
2019-07-19 22:22:15 +02:00
|
|
|
|
2022-09-09 13:39:38 +02:00
|
|
|
(define (git-repository-query-substitutes? conn id)
|
|
|
|
(match (exec-query
|
|
|
|
conn
|
|
|
|
"SELECT query_substitutes FROM git_repositories WHERE id = $1"
|
|
|
|
(list (simple-format #f "~A" id)))
|
|
|
|
(((query_substitutes))
|
|
|
|
(string=? query_substitutes "t"))))
|
|
|
|
|
2019-05-05 14:35:48 +02:00
|
|
|
(define (git-repository-id->url conn id)
|
|
|
|
(match
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
(string-append
|
|
|
|
"SELECT url FROM git_repositories WHERE id = $1;")
|
|
|
|
(list id))
|
|
|
|
(((url)) url)))
|
|
|
|
|
2020-02-08 13:03:41 +01:00
|
|
|
(define (select-includes-and-excluded-branches-for-git-repository conn id)
|
|
|
|
(match (exec-query
|
|
|
|
conn
|
|
|
|
"
|
|
|
|
SELECT included_branches, excluded_branches
|
|
|
|
FROM git_repositories WHERE id = $1"
|
|
|
|
(list (number->string id)))
|
|
|
|
(((included_branches excluded_branches))
|
|
|
|
(values
|
2021-01-02 11:06:27 +01:00
|
|
|
(if (or (eq? #f included_branches)
|
|
|
|
(string-null? included_branches))
|
2020-02-08 13:03:41 +01:00
|
|
|
'()
|
|
|
|
(parse-postgresql-array-string included_branches))
|
2021-01-02 11:06:27 +01:00
|
|
|
(if (or (eq? excluded_branches #f)
|
|
|
|
(string-null? excluded_branches))
|
2020-02-08 13:03:41 +01:00
|
|
|
'()
|
|
|
|
(parse-postgresql-array-string excluded_branches))))))
|
|
|
|
|
2020-02-01 13:59:41 +01:00
|
|
|
(define (count-git-repositories-with-x-git-repo-header-values conn)
|
|
|
|
(match (exec-query
|
|
|
|
conn
|
|
|
|
"SELECT COUNT(*) FROM git_repositories WHERE x_git_repo_header IS NOT NULL")
|
|
|
|
(((count))
|
|
|
|
(string->number count))))
|
|
|
|
|
2020-01-11 18:25:08 +01:00
|
|
|
(define (git-repository-x-git-repo-header->git-repository-id conn header)
|
|
|
|
(match
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
(string-append
|
|
|
|
"SELECT id FROM git_repositories WHERE x_git_repo_header = $1;")
|
|
|
|
(list header))
|
|
|
|
(() #f)
|
|
|
|
(((id))
|
|
|
|
(string->number id))))
|
|
|
|
|
2019-05-05 14:35:48 +02:00
|
|
|
(define (git-repository-url->git-repository-id conn url)
|
|
|
|
(let ((existing-id
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
(string-append
|
|
|
|
"SELECT id FROM git_repositories WHERE url = '" url "'"))))
|
2019-09-04 19:24:22 +02:00
|
|
|
(string->number
|
|
|
|
(match existing-id
|
|
|
|
(((id)) id)
|
|
|
|
(()
|
|
|
|
(caar
|
|
|
|
(exec-query conn
|
|
|
|
(string-append
|
|
|
|
"INSERT INTO git_repositories "
|
|
|
|
"(url) "
|
|
|
|
"VALUES "
|
|
|
|
"('" url "') "
|
|
|
|
"RETURNING id"))))))))
|
2019-05-05 14:35:48 +02:00
|
|
|
|
|
|
|
(define (guix-revisions-and-jobs-for-git-repository conn git-repository-id)
|
|
|
|
(define query
|
|
|
|
"
|
2019-06-20 00:12:20 +02:00
|
|
|
SELECT NULL AS id, load_new_guix_revision_jobs.id AS job_id,
|
|
|
|
(
|
|
|
|
SELECT json_agg(event)
|
|
|
|
FROM load_new_guix_revision_job_events
|
|
|
|
WHERE load_new_guix_revision_jobs.id = load_new_guix_revision_job_events.job_id
|
|
|
|
) AS job_events, commit, source
|
2019-05-05 14:35:48 +02:00
|
|
|
FROM load_new_guix_revision_jobs
|
2019-06-13 20:19:04 +02:00
|
|
|
WHERE git_repository_id = $1 AND succeeded_at IS NULL AND NOT EXISTS (
|
|
|
|
SELECT 1 FROM load_new_guix_revision_job_events
|
|
|
|
WHERE event = 'failure' AND job_id = load_new_guix_revision_jobs.id
|
|
|
|
)
|
2019-06-20 00:12:20 +02:00
|
|
|
UNION ALL
|
|
|
|
SELECT id, NULL, NULL, commit, NULL
|
2019-05-05 14:35:48 +02:00
|
|
|
FROM guix_revisions
|
|
|
|
WHERE git_repository_id = $1
|
|
|
|
ORDER BY 1 DESC NULLS FIRST, 2 DESC LIMIT 10;")
|
|
|
|
|
2019-06-20 00:12:20 +02:00
|
|
|
(map
|
|
|
|
(match-lambda
|
|
|
|
((id job_id job_events commit source)
|
|
|
|
(list id
|
|
|
|
job_id
|
2021-01-02 11:06:27 +01:00
|
|
|
(if (or (eq? #f job_events)
|
|
|
|
(string-null? job_events))
|
2019-06-20 00:12:20 +02:00
|
|
|
'()
|
|
|
|
(vector->list (json-string->scm job_events)))
|
|
|
|
commit source)))
|
|
|
|
(exec-query
|
|
|
|
conn
|
|
|
|
query
|
|
|
|
(list git-repository-id))))
|
2019-05-13 22:02:53 +02:00
|
|
|
|
|
|
|
(define (git-repositories-containing-commit conn commit)
|
|
|
|
(define query
|
|
|
|
"
|
|
|
|
SELECT id, label, url, cgit_url_base
|
|
|
|
FROM git_repositories WHERE id IN (
|
|
|
|
SELECT git_repository_id
|
|
|
|
FROM git_branches
|
2022-05-23 20:10:25 +02:00
|
|
|
INNER JOIN git_commits
|
|
|
|
ON git_branches.id = git_commits.git_branch_id
|
2019-05-13 22:02:53 +02:00
|
|
|
WHERE commit = $1
|
|
|
|
)")
|
|
|
|
|
|
|
|
(exec-query conn query (list commit)))
|