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.

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))))))