aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service')
-rw-r--r--guix-data-service/model/git-repository.scm13
-rw-r--r--guix-data-service/model/location.scm54
-rw-r--r--guix-data-service/model/package-metadata.scm71
-rw-r--r--guix-data-service/web/controller.scm8
-rw-r--r--guix-data-service/web/view/html.scm27
5 files changed, 148 insertions, 25 deletions
diff --git a/guix-data-service/model/git-repository.scm b/guix-data-service/model/git-repository.scm
index 5f35cd3..16c57bf 100644
--- a/guix-data-service/model/git-repository.scm
+++ b/guix-data-service/model/git-repository.scm
@@ -4,6 +4,7 @@
#:export (all-git-repositories
git-repository-id->url
git-repository-url->git-repository-id
+ git-repositories-containing-commit
guix-revisions-and-jobs-for-git-repository))
@@ -56,3 +57,15 @@ ORDER BY 1 DESC NULLS FIRST, 2 DESC LIMIT 10;")
conn
query
(list git-repository-id)))
+
+(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
+ WHERE commit = $1
+)")
+
+ (exec-query conn query (list commit)))
diff --git a/guix-data-service/model/location.scm b/guix-data-service/model/location.scm
new file mode 100644
index 0000000..1a01b9a
--- /dev/null
+++ b/guix-data-service/model/location.scm
@@ -0,0 +1,54 @@
+;;; 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/>.
+
+(define-module (guix-data-service model location)
+ #:use-module (ice-9 match)
+ #:use-module (guix utils)
+ #:use-module (squee)
+ #:export (location->location-id))
+
+(define select-existing-location
+ (string-append
+ "SELECT id "
+ "FROM locations "
+ "WHERE file = $1 AND line = $2 AND column_number = $3"))
+
+(define insert-location
+ (string-append
+ "INSERT INTO locations "
+ "(file, line, column_number) VALUES "
+ "($1, $2, $3) "
+ "RETURNING id"))
+
+(define (location->location-id conn location)
+ (match location
+ (($ <location> file line column)
+ (match (exec-query conn
+ select-existing-location
+ (list file
+ (number->string line)
+ (number->string column)))
+ (((id))
+ (string->number id))
+ (()
+ (string->number
+ (caar
+ (exec-query conn
+ insert-location
+ (list file
+ (number->string line)
+ (number->string column))))))))))
diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm
index 8578bb1..644050e 100644
--- a/guix-data-service/model/package-metadata.scm
+++ b/guix-data-service/model/package-metadata.scm
@@ -7,36 +7,64 @@
#:use-module (rnrs bytevectors)
#:use-module (guix base16)
#:use-module (guix inferior)
+ #:use-module (guix-data-service model location)
#:use-module (guix-data-service model utils)
#:export (select-package-metadata-by-revision-name-and-version
inferior-packages->package-metadata-ids))
(define (select-package-metadata package-metadata-values)
- (string-append "SELECT id, package_metadata.synopsis, "
- "package_metadata.description, package_metadata.home_page "
+ (define fields
+ '("synopsis" "description" "home_page" "location_id"))
+
+ (string-append "SELECT id, " (string-join (map
+ (lambda (name)
+ (string-append
+ "package_metadata." name))
+ fields)
+ ", ") " "
"FROM package_metadata "
"JOIN (VALUES "
- (string-join (map (lambda (field-values)
- (apply
- simple-format
- #f "(~A, ~A, ~A)"
- (map value->quoted-string-or-null
- field-values)))
- package-metadata-values)
+ (string-join (map
+ (match-lambda
+ ((synopsis description home-page location-id)
+ (apply
+ simple-format
+ #f
+ (string-append
+ "("
+ (string-join
+ (list-tabulate
+ (length fields)
+ (lambda (n) "~A"))
+ ",")
+ ")")
+ (list
+ (value->quoted-string-or-null synopsis)
+ (value->quoted-string-or-null description)
+ (value->quoted-string-or-null home-page)
+ location-id))))
+ package-metadata-values)
",")
- ") AS vals (synopsis, description, home_page) "
- "ON package_metadata.synopsis = vals.synopsis AND "
- "package_metadata.description = vals.description AND "
- "package_metadata.home_page = vals.home_page"))
+ ") AS vals (" (string-join fields ", ") ") "
+ "ON "
+ (string-join
+ (map (lambda (field)
+ (string-append
+ "package_metadata." field " = vals." field))
+ fields)
+ " AND ")))
(define (select-package-metadata-by-revision-name-and-version
conn revision-commit-hash name version)
(define query "
SELECT package_metadata.synopsis, package_metadata.description,
- package_metadata.home_page
+ package_metadata.home_page,
+ locations.file, locations.line, locations.column_number
FROM package_metadata
INNER JOIN packages
ON package_metadata.id = packages.package_metadata_id
+LEFT OUTER JOIN locations
+ ON package_metadata.location_id = locations.id
WHERE packages.id IN (
SELECT package_derivations.package_id
FROM package_derivations
@@ -54,16 +82,18 @@ WHERE packages.id IN (
(define (insert-package-metadata metadata-rows)
(string-append "INSERT INTO package_metadata "
- "(synopsis, description, home_page) "
+ "(synopsis, description, home_page, location_id) "
"VALUES "
(string-join
(map (match-lambda
- ((synopsis description home_page)
+ ((synopsis description home_page location_id)
(string-append
"("
(value->quoted-string-or-null synopsis) ","
(value->quoted-string-or-null description) ","
- (value->quoted-string-or-null home_page) ")")))
+ (value->quoted-string-or-null home_page) ","
+ (number->string location_id)
+ ")")))
metadata-rows)
",")
" RETURNING id"
@@ -75,14 +105,17 @@ WHERE packages.id IN (
(map (lambda (package)
(list (inferior-package-synopsis package)
(inferior-package-description package)
- (inferior-package-home-page package)))
+ (inferior-package-home-page package)
+ (location->location-id
+ conn
+ (inferior-package-location package))))
packages))
(let* ((existing-package-metadata-entries
(exec-query->vhash conn
(select-package-metadata package-metadata)
(lambda (results)
- (cdr (take results 4)))
+ (cdr (take results 5)))
first)) ;; id))
(missing-package-metadata-entries
(delete-duplicates
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 584392a..6b4167d 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -176,7 +176,10 @@
conn
commit-hash
name
- version)))
+ version))
+ (git-repositories
+ (git-repositories-containing-commit conn
+ commit-hash)))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -202,7 +205,8 @@
name
version
metadata
- derivations))))))
+ derivations
+ git-repositories))))))
(define (render-compare-unknown-commit mime-types
conn
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 079b23d..ecc2e83 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -302,7 +302,7 @@
(define (view-revision-package-and-version revision-commit-hash name version
package-metadata
- derivations)
+ derivations git-repositories)
(layout
#:extra-headers
'((cache-control . ((max-age . 60))))
@@ -327,7 +327,7 @@
(div
(@ (class "col-sm-12"))
,(match package-metadata
- (((synopsis description home-page))
+ (((synopsis description home-page file line column-number))
`(dl
(@ (class "dl-horizontal"))
(dt "Synopsis")
@@ -335,8 +335,27 @@
(dt "Description")
(dd ,(stexi->shtml (texi-fragment->stexi description)))
(dt "Home page")
- (dd (a (@ (href ,home-page))
- ,home-page)))))))
+ (dd (a (@ (href ,home-page)) ,home-page))
+ ,@(if (and file (not (string-null? file))
+ (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 ")")
+ '())))
+ git-repositories)))
+ '()))))))
(div
(@ (class "row"))
(div
generated by cgit v1.2.3 (git 2.25.4) at 2024-07-04 07:45:42 +0000