aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2021-03-14 21:48:43 +0000
committerChristopher Baines <mail@cbaines.net>2021-03-14 21:48:43 +0000
commit663bd1411a0aaea38dd8ce6d12d5c16f17f74a30 (patch)
treee1713d8b7e701e6c33d4f4a0e43b9202eebdaf33 /guix-data-service
parentfbaa37328cdc62e39a7cc39e27f8e35bf1bee054 (diff)
downloaddata-service-663bd1411a0aaea38dd8ce6d12d5c16f17f74a30.tar
data-service-663bd1411a0aaea38dd8ce6d12d5c16f17f74a30.tar.gz
Add a /package/NAME page
This might be useful for working out when a non-master branch contains a newer version of a package, or someone has sent in a patch for a newer version already.
Diffstat (limited to 'guix-data-service')
-rw-r--r--guix-data-service/model/package.scm47
-rw-r--r--guix-data-service/web/controller.scm3
-rw-r--r--guix-data-service/web/package/controller.scm62
-rw-r--r--guix-data-service/web/package/html.scm63
4 files changed, 174 insertions, 1 deletions
diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm
index 7d58a8e..82d8ef3 100644
--- a/guix-data-service/model/package.scm
+++ b/guix-data-service/model/package.scm
@@ -34,7 +34,9 @@
package-derivations-for-branch
package-outputs-for-branch
- any-package-synopsis-or-descriptions-translations?))
+ any-package-synopsis-or-descriptions-translations?
+
+ branches-by-package-version))
(define (select-existing-package-entries package-entries)
(string-append "SELECT id, packages.name, packages.version, "
@@ -532,3 +534,46 @@ ORDER BY first_datetime DESC, package_version DESC")
(or (string=? synopsis-locale locale)
(string=? description-locale locale))))
packages))
+
+(define (branches-by-package-version conn package-name system target)
+ (define query
+ "
+WITH branches AS (
+ SELECT DISTINCT ON (git_repository_id, name) git_repository_id, name, commit
+ FROM git_branches
+ WHERE commit <> ''
+ ORDER BY git_repository_id, name, datetime DESC
+)
+SELECT packages.version,
+ JSON_AGG(
+ json_build_object(
+ 'git_repository_id', branches.git_repository_id,
+ 'name', branches.name
+ )
+ )
+FROM branches
+INNER JOIN guix_revisions
+ ON branches.git_repository_id = guix_revisions.git_repository_id
+ AND branches.commit = guix_revisions.commit
+INNER JOIN guix_revision_package_derivations
+ ON guix_revision_package_derivations.revision_id = guix_revisions.id
+INNER JOIN package_derivations
+ ON package_derivations.id = guix_revision_package_derivations.package_derivation_id
+ AND package_derivations.system = $2
+ AND package_derivations.target = $3
+INNER JOIN packages
+ ON package_derivations.package_id = packages.id
+WHERE packages.name = $1
+GROUP BY packages.version
+ORDER BY packages.version DESC")
+
+ (list->vector
+ (map (match-lambda
+ ((version
+ branches-json)
+ `((version . ,version)
+ (branches . ,(json-string->scm branches-json)))))
+ (exec-query
+ conn
+ query
+ (list package-name system target)))))
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 6adc093..5e10e41 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -69,6 +69,7 @@
#:use-module (guix-data-service web compare controller)
#:use-module (guix-data-service web revision controller)
#:use-module (guix-data-service web repository controller)
+ #:use-module (guix-data-service web package controller)
#:export (%show-error-details
controller))
@@ -646,6 +647,8 @@
(delegate-to repository-controller))
(('GET "repository" _ ...)
(delegate-to repository-controller))
+ (('GET "package" _ ...)
+ (delegate-to package-controller))
(('GET "gnu" "store" filename)
;; These routes are a little special, as the extensions aren't used for
;; content negotiation, so just use the path from the request
diff --git a/guix-data-service/web/package/controller.scm b/guix-data-service/web/package/controller.scm
new file mode 100644
index 0000000..465c2a3
--- /dev/null
+++ b/guix-data-service/web/package/controller.scm
@@ -0,0 +1,62 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2021 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 web package controller)
+ #:use-module (ice-9 match)
+ #:use-module (web uri)
+ #:use-module (web request)
+ #:use-module (guix-data-service utils)
+ #:use-module (guix-data-service database)
+ #:use-module (guix-data-service web render)
+ #:use-module (guix-data-service web query-parameters)
+ #:use-module (guix-data-service web util)
+ #:use-module (guix-data-service model package)
+ #:use-module (guix-data-service web package html)
+ #:export (package-controller))
+
+(define (package-controller request
+ method-and-path-components
+ mime-types
+ body)
+ (match method-and-path-components
+ (('GET "package" name)
+ (let ((parsed-query-parameters
+ (parse-query-parameters
+ request
+ `((system ,parse-system #:default "x86_64-linux")
+ (target ,parse-target #:default "")))))
+ (letpar& ((package-versions-with-branches
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (branches-by-package-version conn name
+ (assq-ref parsed-query-parameters
+ 'system)
+ (assq-ref parsed-query-parameters
+ 'target))))))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((name . ,name)
+ (versions . ,package-versions-with-branches))))
+ (else
+ (render-html
+ #:sxml
+ (view-package name package-versions-with-branches)))))))))
+
+
diff --git a/guix-data-service/web/package/html.scm b/guix-data-service/web/package/html.scm
new file mode 100644
index 0000000..0d9b078
--- /dev/null
+++ b/guix-data-service/web/package/html.scm
@@ -0,0 +1,63 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2021 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 web package html)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 match)
+ #:use-module (guix-data-service web html-utils)
+ #:use-module (guix-data-service web view html)
+ #:export (view-package))
+
+(define* (view-package name package-version-with-branches)
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (h1 "Package: " ,name)))
+ ,@(map
+ (match-lambda
+ ((('version . version)
+ ('branches . branches))
+ `(div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (h3 ,version)
+ (ul
+ (@ (class "list-inline"))
+ ,@(map
+ (lambda (branch)
+ `((li
+ (a
+ (@
+ (href
+ ,(simple-format
+ #f
+ "/repository/~A/branch/~A/latest-processed-revision/package/~A/~A"
+ (assoc-ref branch "git_repository_id")
+ (assoc-ref branch "name")
+ name
+ version)))
+ ,(assoc-ref branch "name")))))
+ (vector->list branches)))))))
+ (vector->list package-version-with-branches))))))