Add some super crude JSON pages

Provide JSON versions of the existing HTML compare and
compare/derivations pages. Refactor the code and extract some
functions to make this a little less painful.

guix-data-service/web/controller.scm

@@ -51,11 +51,7 @@
   ;;     (render-html (error-page message))))
   )
 
-(define (controller request body conn)
+(define (with-base-and-target-commits request conn f)
-  (match-lambda
-    ((GET)
-     (apply render-html (index (most-recent-n-guix-revisions conn 10))))
-    ((GET "compare")
   (let ((base-commit (-> request
                          request-uri
                          uri-query
@@ -66,10 +62,22 @@
                            uri-query
                            parse-query-string
                            (cut assoc-ref <> "target_commit"))))
-       (let ((base-revision-id (commit->revision-id conn base-commit))
+    (f base-commit
-             (target-revision-id (commit->revision-id conn target-commit)))
+       (commit->revision-id conn base-commit)
+       target-commit
+       (commit->revision-id conn target-commit))))
+
+(define (render-compare-unknown-commit content-type
+                                       conn
+                                       base-commit
+                                       base-revision-id
+                                       target-commit
+                                       target-revision-id)
   (cond
-          ((not (and base-revision-id target-revision-id))
+   ((eq? content-type 'json)
+    (render-json
+     '((compare . #t))))
+   (else
     (apply render-html
            (compare-unknown-commit base-commit
                                    target-commit
@@ -78,8 +86,14 @@
                                    (select-job-for-commit conn
                                                           base-commit)
                                    (select-job-for-commit conn
-                                                                 target-commit))))
+                                                          target-commit))))))
-          (else
+
+(define (render-compare content-type
+                        conn
+                        base-commit
+                        base-revision-id
+                        target-commit
+                        target-revision-id)
   (let-values
       (((base-packages-vhash target-packages-vhash)
         (package-data->package-data-vhashes
@@ -98,53 +112,128 @@
            (other-changes
             (package-data-other-changes base-packages-vhash
                                         target-packages-vhash)))
+      (cond
+       ((eq? content-type 'json)
+        (render-json
+         `((new-packages . ,new-packages)
+           (removed-packages . ,removed-packages)
+           (version-changes . ,version-changes)
+           (other-changes . ,other-changes))))
+       (else
         (apply render-html
                (compare base-commit
                         target-commit
                         new-packages
                         removed-packages
                         version-changes
-                               other-changes)))))))))
+                        other-changes)))))))
-    ((GET "compare" "derivations")
+
-     (let ((base-commit (-> request
+(define (render-compare/derivations content-type
-                            request-uri
+                                    conn
-                            uri-query
+                                    base-commit
-                            parse-query-string
+                                    base-revision-id
-                            (cut assoc-ref <> "base_commit")))
-           (target-commit (-> request
-                              request-uri
-                              uri-query
-                              parse-query-string
-                              (cut assoc-ref <> "target_commit"))))
-       (let ((base-revision-id (commit->revision-id conn base-commit))
-             (target-revision-id (commit->revision-id conn target-commit)))
-         (cond
-          ((not (and base-revision-id target-revision-id))
-           (apply render-html
-                  (compare-unknown-commit base-commit
                                     target-commit
-                                          (if base-revision-id #t #f)
+                                    target-revision-id)
-                                          (if target-revision-id #t #f)
-                                          (select-job-for-commit conn
-                                                                 base-commit)
-                                          (select-job-for-commit conn
-                                                                 target-commit))))
-          (else
   (let-values
       (((base-packages-vhash target-packages-vhash)
         (package-data->package-data-vhashes
          (package-differences-data conn
                                    base-revision-id
                                    target-revision-id))))
+    (let ((base-derivations
+           (package-data-vhash->derivations
+            conn
+            base-packages-vhash))
+          (target-derivations
+           (package-data-vhash->derivations
+            conn
+            target-packages-vhash)))
+    (cond
+     ((eq? content-type 'json)
+      (render-json
+       `((base . ((commit . ,base-commit)
+                  (derivations . ,base-derivations)))
+         (target . ((commit . ,target-commit)
+                    (derivations . ,target-derivations))))))
+     (else
       (apply render-html
              (compare/derivations
               base-commit
               target-commit
-                       (package-data-vhash->derivations
+              base-derivations
+              target-derivations)))))))
+
+(define (controller request body conn)
+  (match-lambda
+    ((GET)
+     (apply render-html (index (most-recent-n-guix-revisions conn 10))))
+    ((GET "compare")
+     (with-base-and-target-commits
+      request conn
+      (lambda (base-commit base-revision-id target-commit target-revision-id)
+        (if (not (and base-revision-id target-revision-id))
+            (render-compare-unknown-commit 'html
                                            conn
-                        base-packages-vhash)
+                                           base-commit
-                       (package-data-vhash->derivations
+                                           base-revision-id
+                                           target-commit
+                                           target-revision-id)
+            (render-compare 'html
                             conn
-                        target-packages-vhash)))))))))
+                            base-commit
+                            base-revision-id
+                            target-commit
+                            target-revision-id)))))
+    ((GET "compare.json")
+     (with-base-and-target-commits
+      request conn
+      (lambda (base-commit base-revision-id target-commit target-revision-id)
+        (if (not (and base-revision-id target-revision-id))
+            (render-compare-unknown-commit 'json
+                                           conn
+                                           base-commit
+                                           base-revision-id
+                                           target-commit
+                                           target-revision-id)
+            (render-compare 'json
+                            conn
+                            base-commit
+                            base-revision-id
+                            target-commit
+                            target-revision-id)))))
+    ((GET "compare" "derivations")
+     (with-base-and-target-commits
+      request conn
+      (lambda (base-commit base-revision-id target-commit target-revision-id)
+        (if (not (and base-revision-id target-revision-id))
+            (render-compare-unknown-commit 'html
+                                           conn
+                                           base-commit
+                                           base-revision-id
+                                           target-commit
+                                           target-revision-id)
+            (render-compare/derivations 'html
+                                        conn
+                                        base-commit
+                                        base-revision-id
+                                        target-commit
+                                        target-revision-id)))))
+    ((GET "compare" "derivations.json")
+     (with-base-and-target-commits
+      request conn
+      (lambda (base-commit base-revision-id target-commit target-revision-id)
+        (if (not (and base-revision-id target-revision-id))
+            (render-compare-unknown-commit 'json
+                                           conn
+                                           base-commit
+                                           base-revision-id
+                                           target-commit
+                                           target-revision-id)
+            (render-compare/derivations 'json
+                                        conn
+                                        base-commit
+                                        base-revision-id
+                                        target-commit
+                                        target-revision-id)))))
     ((GET path ...)
      (render-static-asset request))))