Allow specifying the fields on the packages page

This is mostly for the JSON output, as it allows much more information to be
included.

3 files changed, 189 insertions, 32 deletions

diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm
index 39fa64d..1579469 100644
--- a/guix-data-service/model/package.scm
+++ b/guix-data-service/model/package.scm
@@ -35,10 +35,23 @@
   (define query
     (string-append "
 WITH data AS (
-  SELECT packages.name, packages.version, package_metadata.synopsis
+  SELECT packages.name, packages.version, package_metadata.synopsis,
+    package_metadata.description, package_metadata.home_page,
+    locations.file, locations.line, locations.column_number,
+    (SELECT JSON_AGG((license_data.*))
+     FROM (
+       SELECT licenses.name, licenses.uri, licenses.comment
+       FROM licenses
+       INNER JOIN license_sets ON licenses.id = ANY(license_sets.license_ids)
+       WHERE license_sets.id = package_metadata.license_set_id
+       ORDER BY licenses.name
+     ) AS license_data
+    ) AS licenses
   FROM packages
   INNER JOIN package_metadata
     ON packages.package_metadata_id = 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
@@ -78,10 +91,24 @@ WHERE data.name IN (SELECT name FROM package_names);"))
      "
 SELECT packages.name,
        packages.version,
-       package_metadata.synopsis
+       package_metadata.synopsis,
+       package_metadata.description,
+       package_metadata.home_page,
+       locations.file, locations.line, locations.column_number,
+       (SELECT JSON_AGG((license_data.*))
+        FROM (
+          SELECT licenses.name, licenses.uri, licenses.comment
+          FROM licenses
+          INNER JOIN license_sets ON licenses.id = ANY(license_sets.license_ids)
+          WHERE license_sets.id = package_metadata.license_set_id
+          ORDER BY licenses.name
+        ) AS license_data
+       ) AS licenses
 FROM packages
 INNER JOIN package_metadata
   ON packages.package_metadata_id = 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
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 6b4167d..67db909 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -25,7 +25,11 @@
   #:use-module (srfi srfi-26)
   #:use-module (web request)
   #:use-module (web uri)
+  #:use-module (texinfo)
+  #:use-module (texinfo html)
+  #:use-module (texinfo plain-text)
   #:use-module (squee)
+  #:use-module (json)
   #:use-module (guix-data-service comparison)
   #:use-module (guix-data-service model git-branch)
   #:use-module (guix-data-service model git-repository)
@@ -38,6 +42,7 @@
   #:use-module (guix-data-service model build)
   #:use-module (guix-data-service jobs load-new-guix-revision)
   #:use-module (guix-data-service web render)
+  #:use-module (guix-data-service web sxml)
   #:use-module (guix-data-service web query-parameters)
   #:use-module (guix-data-service web util)
   #:use-module (guix-data-service web view html)
@@ -105,6 +110,14 @@
                packages-count
                derivations-counts))))))
 
+(define (texinfo->variants-alist s)
+  (let ((stexi (texi-fragment->stexi s)))
+    `((source . ,s)
+      (html   . ,(with-output-to-string
+                   (lambda ()
+                     (sxml->html (stexi->shtml stexi)))))
+      (plain . ,(stexi->plain-text stexi)))))
+
 (define (render-revision-packages mime-types
                                   conn
                                   commit-hash
@@ -121,10 +134,12 @@
                 (view-revision-packages commit-hash
                                         query-parameters
                                         '()
+                                        '()
                                         #f))))
 
       (let* ((search-query (assq-ref query-parameters 'search_query))
              (limit-results (assq-ref query-parameters 'limit_results))
+             (fields (assq-ref query-parameters 'field))
              (packages
               (if search-query
                   (search-packages-in-revision
@@ -137,6 +152,9 @@
                    commit-hash
                    #:limit-results limit-results
                    #:after-name (assq-ref query-parameters 'after_name))))
+             (git-repositories
+              (git-repositories-containing-commit conn
+                                                  commit-hash))
              (show-next-page?
               (and (not search-query)
                    (>= (length packages)
@@ -146,18 +164,48 @@
                mime-types)
           ((application/json)
            (render-json
-            `((packages . ,(list->vector
-                            (map (match-lambda
-                                   ((name version synopsis)
-                                    `((name . ,name)
-                                      (version . ,version)
-                                      (synopsis . ,synopsis))))
-                                 packages))))))
+            `((revision
+               . ((commit . ,commit-hash)))
+              (packages
+               . ,(list->vector
+                   (map (match-lambda
+                          ((name version synopsis description home-page
+                                 location-file location-line
+                                 location-column-number licenses)
+                           `((name . ,name)
+                             ,@(if (member "version" fields)
+                                   `((version . ,version))
+                                   '())
+                             ,@(if (member "synopsis" fields)
+                                   `((synopsis
+                                      . ,(texinfo->variants-alist synopsis)))
+                                   '())
+                             ,@(if (member "description" fields)
+                                   `((description
+                                      . ,(texinfo->variants-alist description)))
+                                   '())
+                             ,@(if (member "home-page" fields)
+                                   `((home-page . ,home-page))
+                                   '())
+                             ,@(if (member "location" fields)
+                                   `((location
+                                      . ((file   . ,location-file)
+                                         (line   . ,location-line)
+                                         (column . ,location-column-number))))
+                                   '())
+                             ,@(if (member "licenses" fields)
+                                   `((licenses
+                                      . ,(if (string-null? licenses)
+                                             #()
+                                             (json-string->scm licenses))))
+                                   '()))))
+                        packages))))))
           (else
            (apply render-html
                   (view-revision-packages commit-hash
                                           query-parameters
                                           packages
+                                          git-repositories
                                           show-next-page?)))))))
 
 (define (render-revision-package mime-types
@@ -486,6 +534,8 @@
              (parse-query-parameters
               request
               `((after_name     ,identity)
+                (field          ,identity #:multi-value
+                                #:default ("version" "synopsis"))
                 (search_query   ,identity)
                 (limit_results  ,parse-result-limit #:default 100)))
              ;; You can't specify a search query, but then also limit the
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 95f628a..05d3b60 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -27,6 +27,7 @@
   #:use-module (srfi srfi-19)
   #:use-module (texinfo)
   #:use-module (texinfo html)
+  #:use-module (json)
   #:export (index
             view-statistics
             view-revision-package-and-version
@@ -97,6 +98,7 @@
 
 (define* (form-horizontal-control label query-parameters
                                   #:key
+                                  name
                                   help-text
                                   required?
                                   options)
@@ -111,8 +113,9 @@
                        (string-downcase label)))
          (help-span-id (string-append
                         input-id "-help-text"))
-         (input-name (underscore-join-words
-                      (string-downcase label)))
+         (input-name (or name
+                         (underscore-join-words
+                          (string-downcase label))))
          (has-error? (invalid-query-parameter?
                       (assq-ref query-parameters
                                 (string->symbol input-name))))
@@ -144,12 +147,20 @@
                            value)
                           (_ '()))))
 
-                   (map (lambda (option-value)
-                          `(option
-                            (@ ,@(if (member option-value selected-options)
-                                     '((selected ""))
-                                     '()))
-                            ,(value->text option-value)))
+                   (map (match-lambda
+                          ((option-value)
+                           `(option
+                             (@ ,@(if (member option-value selected-options)
+                                      '((selected ""))
+                                      '()))
+                             ,(value->text option-value)))
+                          ((option-label . option-value)
+                           `(option
+                             (@ ,@(if (member option-value selected-options)
+                                      '((selected ""))
+                                      '())
+                                (value ,option-value))
+                             ,(value->text option-label))))
                         options)))
             `(input (@ (class "form-control")
                        (style "font-family: monospace;")
@@ -445,7 +456,17 @@
 (define (view-revision-packages revision-commit-hash
                                 query-parameters
                                 packages
+                                git-repositories
                                 show-next-page?)
+  (define field-options
+    (map
+     (lambda (field)
+       (cons field
+             (hyphenate-words
+              (string-downcase field))))
+     '("Version" "Synopsis" "Description"
+       "Home page" "Location" "Licenses")))
+
   (layout
    #:extra-headers
    '((cache-control . ((max-age . 60))))
@@ -475,6 +496,11 @@
             #:help-text
             "List packages where the name or synopsis match the query.")
           ,(form-horizontal-control
+            "Fields" query-parameters
+            #:name "field"
+            #:options field-options
+            #:help-text "Fields to return in the response.")
+          ,(form-horizontal-control
             "After name" query-parameters
             #:help-text
             "List packages that are alphabetically after the given name.")
@@ -496,23 +522,77 @@
          (thead
           (tr
            (th (@ (class "col-md-3")) "Name")
-           (th (@ (class "col-md-3")) "Version")
-           (th (@ (class "col-md-3")) "Synopsis")
+           ,@(filter-map
+              (match-lambda
+                ((label . value)
+                 (if (member value (assq-ref query-parameters 'field))
+                     `(th (@ (class "col-md-3")) ,label)
+                     #f)))
+              field-options)
            (th (@ (class "col-md-3")) "")))
          (tbody
-          ,@(map
-             (match-lambda
-               ((name version synopsis)
-                `(tr
-                  (td ,name)
-                  (td ,version)
-                  (td ,(stexi->shtml (texi-fragment->stexi synopsis)))
-                  (td (@ (class "text-right"))
-                      (a (@ (href ,(string-append
-                                    "/revision/" revision-commit-hash
-                                    "/package/" name "/" version)))
-                         "More information")))))
-             packages)))))
+          ,@(let ((fields (assq-ref query-parameters 'field)))
+              (map
+               (match-lambda
+                 ((name version synopsis description home-page
+                        location-file location-line
+                        location-column-number licenses)
+                  `(tr
+                    (td ,name)
+                    ,@(if (member "version" fields)
+                          `((td ,version))
+                          '())
+                    ,(if (member "synopsis" fields)
+                         `((td ,(stexi->shtml (texi-fragment->stexi synopsis))))
+                         '())
+                    ,(if (member "description" fields)
+                         `((td ,(stexi->shtml (texi-fragment->stexi description))))
+                         '())
+                    ,(if (member "home-page" fields)
+                         `((td ,home-page))
+                         '())
+                    ,(if (member "location" fields)
+                         `((td
+                            ,@(if (and location-file
+                                       (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 ")"))))
+                                        git-repositories)))
+                                  '())))
+                         '())
+                    ,(if (member "licenses" fields)
+                         `((td
+                            (ul
+                             (@ (class "list-inline"))
+                             ,@(map (lambda (license)
+                                      `(li (a (@ (href ,(assoc-ref license "uri")))
+                                              ,(assoc-ref license "name"))))
+                                    (vector->list
+                                     (json-string->scm licenses))))))
+                         '())
+                    (td (@ (class "text-right"))
+                        (a (@ (href ,(string-append
+                                      "/revision/" revision-commit-hash
+                                      "/package/" name "/" version)))
+                           "More information")))))
+               packages))))))
       ,@(if show-next-page?
             `((div
                (@ (class "row"))