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, 3 insertions, 448 deletions

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 769d2dd..b5df73b 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -53,6 +53,7 @@
   #:use-module (guix-data-service web revision controller)
   #:use-module (guix-data-service web jobs controller)
   #:use-module (guix-data-service web view html)
+  #:use-module (guix-data-service web compare controller)
   #:use-module (guix-data-service web revision controller)
   #:use-module (guix-data-service web repository controller)
   #:export (controller))
@@ -91,383 +92,6 @@
            value)))
    alist))
 
-(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))))))))
-
 (define (render-derivation conn derivation-file-name)
   (let ((derivation (select-derivation-by-file-name conn
                                                     derivation-file-name)))
@@ -515,19 +139,6 @@
                                      derivations))
         #:extra-headers http-headers-for-unchanging-content)))))
 
-(define (parse-commit conn)
-  (lambda (s)
-    (if (guix-commit-exists? conn s)
-        s
-        (make-invalid-query-parameter
-         s "unknown commit"))))
-
-(define (parse-system s)
-  s)
-
-(define (parse-build-status s)
-  s)
-
 (define handle-static-assets
   (if assets-dir-in-store?
       (static-asset-from-store-renderer)
@@ -627,64 +238,8 @@
        (if (string-suffix? ".drv" path)
            (render-derivation conn path)
            (render-store-item conn path))))
-    (('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)))
+    (('GET "compare" _ ...)             (delegate-to compare-controller))
+    (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
     (('GET "jobs")         (delegate-to jobs-controller))
     (('GET "jobs" "queue") (delegate-to jobs-controller))
     (('GET "job" job-id)   (delegate-to jobs-controller))