Extract the comparison pages out from the main modules

In to their own modules. This should help make the code more understandable,
and allow future refactoring for readability.

1 files changed, 494 insertions, 0 deletions

diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm
new file mode 100644
index 0000000..7c75767
--- /dev/null
+++ b/guix-data-service/web/compare/controller.scm
@@ -0,0 +1,494 @@
+;;; 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 web compare controller)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 match)
+  #:use-module (guix-data-service web util)
+  #:use-module (guix-data-service web render)
+  #:use-module (guix-data-service web query-parameters)
+  #:use-module (guix-data-service model utils)
+  #:use-module (guix-data-service comparison)
+  #:use-module (guix-data-service model guix-revision)
+  #:use-module (guix-data-service model derivation)
+  #:use-module (guix-data-service model build-status)
+  #:use-module (guix-data-service web compare html)
+  #:export (compare-controller))
+
+(define cache-control-default-max-age
+  (* 60 60 24)) ; One day
+
+(define http-headers-for-unchanging-content
+  `((cache-control
+     . (public
+        (max-age . ,cache-control-default-max-age)))))
+
+(define (parse-system s)
+  s)
+
+(define (parse-build-status s)
+  s)
+
+(define (parse-commit conn)
+  (lambda (s)
+    (if (guix-commit-exists? conn s)
+        s
+        (make-invalid-query-parameter
+         s "unknown commit"))))
+
+(define (compare-controller request
+                            method-and-path-components
+                            mime-types
+                            body
+                            conn)
+  (match method-and-path-components
+    (('GET "compare")
+     (let* ((parsed-query-parameters
+             (parse-query-parameters
+              request
+              `((base_commit   ,(parse-commit conn) #:required)
+                (target_commit ,(parse-commit conn) #:required)))))
+       (render-compare mime-types
+                       conn
+                       parsed-query-parameters)))
+    (('GET "compare-by-datetime")
+     (let* ((parsed-query-parameters
+             (parse-query-parameters
+              request
+              `((base_branch     ,identity #:required)
+                (base_datetime   ,parse-datetime #:required)
+                (target_branch   ,identity #:required)
+                (target_datetime ,parse-datetime #:required)))))
+       (render-compare-by-datetime mime-types
+                                   conn
+                                   parsed-query-parameters)))
+    (('GET "compare" "derivations")
+     (let* ((parsed-query-parameters
+             (parse-query-parameters
+              request
+              `((base_commit   ,(parse-commit conn) #:required)
+                (target_commit ,(parse-commit conn) #:required)
+                (system        ,parse-system #:multi-value)
+                (target        ,parse-system #:multi-value)
+                (build_status  ,parse-build-status #:multi-value)))))
+       (render-compare/derivations mime-types
+                                   conn
+                                   parsed-query-parameters)))
+    (('GET "compare-by-datetime" "derivations")
+     (let* ((parsed-query-parameters
+             (guard-against-mutually-exclusive-query-parameters
+              (parse-query-parameters
+               request
+               `((base_branch     ,identity #:required)
+                 (base_datetime   ,parse-datetime #:required)
+                 (target_branch   ,identity #:required)
+                 (target_datetime ,parse-datetime #:required)
+                 (system          ,parse-system #:multi-value)
+                 (target          ,parse-system #:multi-value)
+                 (build_status    ,parse-build-status #:multi-value)))
+              '((base_commit base_datetime)
+                (target_commit target_datetime)))))
+       (render-compare-by-datetime/derivations mime-types
+                                               conn
+                                               parsed-query-parameters)))
+    (('GET "compare" "packages")
+     (let* ((parsed-query-parameters
+             (parse-query-parameters
+              request
+              `((base_commit   ,(parse-commit conn) #:required)
+                (target_commit ,(parse-commit conn) #:required)))))
+       (render-compare/packages mime-types
+                                conn
+                                parsed-query-parameters)))))
+
+(define (render-compare mime-types
+                        conn
+                        query-parameters)
+  (if (any-invalid-query-parameters? query-parameters)
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          '((error . "invalid query"))))
+        (else
+         (render-html
+          #:sxml (compare-invalid-parameters
+                  query-parameters
+                  (match (assq-ref query-parameters 'base_commit)
+                    (($ <invalid-query-parameter> value)
+                     (select-job-for-commit conn value))
+                    (_ #f))
+                  (match (assq-ref query-parameters 'target_commit)
+                    (($ <invalid-query-parameter> value)
+                     (select-job-for-commit conn value))
+                    (_ #f))))))
+
+      (let ((base-revision-id (commit->revision-id
+                               conn
+                               (assq-ref query-parameters 'base_commit)))
+            (target-revision-id (commit->revision-id
+                                 conn
+                                 (assq-ref query-parameters 'target_commit))))
+        (let-values
+            (((base-packages-vhash target-packages-vhash)
+              (package-data->package-data-vhashes
+               (package-differences-data conn
+                                         base-revision-id
+                                         target-revision-id))))
+          (let* ((new-packages
+                  (package-data-vhashes->new-packages base-packages-vhash
+                                                      target-packages-vhash))
+                 (removed-packages
+                  (package-data-vhashes->removed-packages base-packages-vhash
+                                                          target-packages-vhash))
+                 (version-changes
+                  (package-data-version-changes base-packages-vhash
+                                                target-packages-vhash))
+                 (lint-warnings-data
+                  (group-list-by-first-n-fields
+                   2
+                   (lint-warning-differences-data conn
+                                                  base-revision-id
+                                                  target-revision-id))))
+            (case (most-appropriate-mime-type
+                   '(application/json text/html)
+                   mime-types)
+              ((application/json)
+               (render-json
+                `((new-packages . ,(list->vector new-packages))
+                  (removed-packages . ,(list->vector removed-packages))
+                  (version-changes . ,(list->vector
+                                       (map
+                                        (match-lambda
+                                          ((name data ...)
+                                           `((name . ,name)
+                                             ,@data)))
+                                        version-changes))))
+                #:extra-headers http-headers-for-unchanging-content))
+              (else
+               (render-html
+                #:sxml (compare query-parameters
+                                (guix-revisions-cgit-url-bases
+                                 conn
+                                 (list base-revision-id
+                                       target-revision-id))
+                                new-packages
+                                removed-packages
+                                version-changes
+                                lint-warnings-data)
+                #:extra-headers http-headers-for-unchanging-content))))))))
+
+(define (render-compare-by-datetime mime-types
+                                    conn
+                                    query-parameters)
+  (if (any-invalid-query-parameters? query-parameters)
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          '((error . "invalid query"))))
+        (else
+         (render-html
+          #:sxml (compare-invalid-parameters
+                  query-parameters
+                  (match (assq-ref query-parameters 'base_commit)
+                    (($ <invalid-query-parameter> value)
+                     (select-job-for-commit conn value))
+                    (_ #f))
+                  (match (assq-ref query-parameters 'target_commit)
+                    (($ <invalid-query-parameter> value)
+                     (select-job-for-commit conn value))
+                    (_ #f))))))
+
+      (let ((base-branch     (assq-ref query-parameters 'base_branch))
+            (base-datetime   (assq-ref query-parameters 'base_datetime))
+            (target-branch   (assq-ref query-parameters 'target_branch))
+            (target-datetime (assq-ref query-parameters 'target_datetime)))
+        (let* ((base-revision-details
+                (select-guix-revision-for-branch-and-datetime conn
+                                                              base-branch
+                                                              base-datetime))
+               (base-revision-id
+                (first base-revision-details))
+               (target-revision-details
+                (select-guix-revision-for-branch-and-datetime conn
+                                                              target-branch
+                                                              target-datetime))
+               (target-revision-id
+                (first target-revision-details)))
+          (let-values
+              (((base-packages-vhash target-packages-vhash)
+                (package-data->package-data-vhashes
+                 (package-differences-data conn
+                                           base-revision-id
+                                           target-revision-id))))
+            (let* ((new-packages
+                    (package-data-vhashes->new-packages base-packages-vhash
+                                                        target-packages-vhash))
+                   (removed-packages
+                    (package-data-vhashes->removed-packages base-packages-vhash
+                                                            target-packages-vhash))
+                   (version-changes
+                    (package-data-version-changes base-packages-vhash
+                                                  target-packages-vhash))
+                   (lint-warnings-data
+                    (group-list-by-first-n-fields
+                     2
+                     (lint-warning-differences-data conn
+                                                    base-revision-id
+                                                    target-revision-id))))
+              (case (most-appropriate-mime-type
+                     '(application/json text/html)
+                     mime-types)
+                ((application/json)
+                 (render-json
+                  `((new-packages . ,(list->vector new-packages))
+                    (removed-packages . ,(list->vector removed-packages))
+                    (version-changes . ,(list->vector
+                                         (map
+                                          (match-lambda
+                                            ((name data ...)
+                                             `((name . ,name)
+                                               ,@data)))
+                                          version-changes))))
+                  #:extra-headers http-headers-for-unchanging-content))
+                (else
+                 (render-html
+                  #:sxml (compare `(,@query-parameters
+                                    (base_commit . ,(second base-revision-details))
+                                    (target_commit . ,(second target-revision-details)))
+                                  (guix-revisions-cgit-url-bases
+                                   conn
+                                   (list base-revision-id
+                                         target-revision-id))
+                                  new-packages
+                                  removed-packages
+                                  version-changes
+                                  lint-warnings-data)
+                  #:extra-headers http-headers-for-unchanging-content)))))))))
+
+(define (render-compare/derivations mime-types
+                                    conn
+                                    query-parameters)
+  (define (derivations->alist derivations)
+    (map (match-lambda
+           ((file-name system target buildstatus)
+            `((file_name . ,file-name)
+              (system . ,system)
+              (target . ,target)
+              (build_status . ,(if (string=? buildstatus "")
+                                   "unknown"
+                                   buildstatus)))))
+         derivations))
+
+  (if (any-invalid-query-parameters? query-parameters)
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          '((error . "invalid query"))))
+        (else
+         (render-html
+          #:sxml (compare/derivations
+                  query-parameters
+                  (valid-systems conn)
+                  build-status-strings
+                  '()))))
+
+      (let ((base-commit    (assq-ref query-parameters 'base_commit))
+            (target-commit  (assq-ref query-parameters 'target_commit))
+            (systems        (assq-ref query-parameters 'system))
+            (targets        (assq-ref query-parameters 'target))
+            (build-statuses (assq-ref query-parameters 'build_status)))
+        (let*
+            ((data
+              (package-differences-data conn
+                                        (commit->revision-id conn base-commit)
+                                        (commit->revision-id conn target-commit)
+                                        #:systems systems
+                                        #:targets targets))
+             (names-and-versions
+              (package-data->names-and-versions data)))
+          (let-values
+              (((base-packages-vhash target-packages-vhash)
+                (package-data->package-data-vhashes data)))
+            (let ((derivation-changes
+                   (package-data-derivation-changes names-and-versions
+                                                    base-packages-vhash
+                                                    target-packages-vhash)))
+              (case (most-appropriate-mime-type
+                     '(application/json text/html)
+                     mime-types)
+                ((application/json)
+                 (render-json
+                  derivation-changes
+                  #:extra-headers http-headers-for-unchanging-content))
+                (else
+                 (render-html
+                  #:sxml (compare/derivations
+                          query-parameters
+                          (valid-systems conn)
+                          build-status-strings
+                          derivation-changes)
+                  #:extra-headers http-headers-for-unchanging-content)))))))))
+
+(define (render-compare-by-datetime/derivations mime-types
+                                                conn
+                                                query-parameters)
+  (define (derivations->alist derivations)
+    (map (match-lambda
+           ((file-name system target buildstatus)
+            `((file_name . ,file-name)
+              (system . ,system)
+              (target . ,target)
+              (build_status . ,(if (string=? buildstatus "")
+                                   "unknown"
+                                   buildstatus)))))
+         derivations))
+
+  (if (any-invalid-query-parameters? query-parameters)
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          '((error . "invalid query"))))
+        (else
+         (render-html
+          #:sxml (compare-by-datetime/derivations
+                  query-parameters
+                  (valid-systems conn)
+                  build-status-strings
+                  '()))))
+
+      (let ((base-branch     (assq-ref query-parameters 'base_branch))
+            (base-datetime   (assq-ref query-parameters 'base_datetime))
+            (target-branch   (assq-ref query-parameters 'target_branch))
+            (target-datetime (assq-ref query-parameters 'target_datetime))
+            (systems         (assq-ref query-parameters 'system))
+            (targets         (assq-ref query-parameters 'target))
+            (build-statuses  (assq-ref query-parameters 'build_status)))
+        (let*
+            ((base-revision-details
+              (select-guix-revision-for-branch-and-datetime conn
+                                                            base-branch
+                                                            base-datetime))
+             (target-revision-details
+              (select-guix-revision-for-branch-and-datetime conn
+                                                            target-branch
+                                                            target-datetime))
+             (data
+              (package-differences-data conn
+                                        (first base-revision-details)
+                                        (first target-revision-details)
+                                        #:systems systems
+                                        #:targets targets))
+             (names-and-versions
+              (package-data->names-and-versions data)))
+          (let-values
+              (((base-packages-vhash target-packages-vhash)
+                (package-data->package-data-vhashes data)))
+            (let ((derivation-changes
+                   (package-data-derivation-changes names-and-versions
+                                                    base-packages-vhash
+                                                    target-packages-vhash)))
+              (case (most-appropriate-mime-type
+                     '(application/json text/html)
+                     mime-types)
+                ((application/json)
+                 (render-json
+                  derivation-changes
+                  #:extra-headers http-headers-for-unchanging-content))
+                (else
+                 (render-html
+                  #:sxml (compare-by-datetime/derivations
+                          query-parameters
+                          (valid-systems conn)
+                          build-status-strings
+                          base-revision-details
+                          target-revision-details
+                          derivation-changes)
+                  #:extra-headers http-headers-for-unchanging-content)))))))))
+
+(define (render-compare/packages mime-types
+                                 conn
+                                 query-parameters)
+  (define (package-data-vhash->json vh)
+    (delete-duplicates
+     (vhash-fold (lambda (name data result)
+                   (cons `((name . ,name)
+                           (version . ,(car data)))
+                         result))
+                 '()
+                 vh)))
+
+  (if (any-invalid-query-parameters? query-parameters)
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          '((error . "invalid query"))))
+        (else
+         (render-html
+          #:sxml (compare-invalid-parameters
+                  query-parameters
+                  (match (assq-ref query-parameters 'base_commit)
+                    (($ <invalid-query-parameter> value)
+                     (select-job-for-commit conn value))
+                    (_ #f))
+                  (match (assq-ref query-parameters 'target_commit)
+                    (($ <invalid-query-parameter> value)
+                     (select-job-for-commit conn value))
+                    (_ #f))))))
+
+      (let ((base-commit    (assq-ref query-parameters 'base_commit))
+            (target-commit  (assq-ref query-parameters 'target_commit)))
+        (let ((base-revision-id (commit->revision-id conn base-commit))
+              (target-revision-id (commit->revision-id conn target-commit)))
+
+          (let-values
+              (((base-packages-vhash target-packages-vhash)
+                (package-data->package-data-vhashes
+                 (package-differences-data conn
+                                           base-revision-id
+                                           target-revision-id))))
+            (case (most-appropriate-mime-type
+                   '(application/json text/html)
+                   mime-types)
+              ((application/json)
+               (render-json
+                `((base
+                   . ((commit . ,base-commit)
+                      (packages . ,(list->vector
+                                    (package-data-vhash->json base-packages-vhash)))))
+                  (target
+                   . ((commit . ,target-commit)
+                      (packages . ,(list->vector
+                                    (package-data-vhash->json target-packages-vhash))))))
+                #:extra-headers http-headers-for-unchanging-content))
+              (else
+               (render-html
+                #:sxml (compare/packages
+                        query-parameters
+                        base-packages-vhash
+                        target-packages-vhash)
+                #:extra-headers http-headers-for-unchanging-content))))))))