aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-data-service/web/controller.scm267
1 files changed, 178 insertions, 89 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index e671082..6052a97 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -51,100 +51,189 @@
;; (render-html (error-page message))))
)
+(define (with-base-and-target-commits request conn f)
+ (let ((base-commit (-> request
+ request-uri
+ uri-query
+ parse-query-string
+ (cut assoc-ref <> "base_commit")))
+ (target-commit (-> request
+ request-uri
+ uri-query
+ parse-query-string
+ (cut assoc-ref <> "target_commit"))))
+ (f base-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
+ ((eq? content-type 'json)
+ (render-json
+ '((compare . #t))))
+ (else
+ (apply render-html
+ (compare-unknown-commit base-commit
+ target-commit
+ (if base-revision-id #t #f)
+ (if target-revision-id #t #f)
+ (select-job-for-commit conn
+ base-commit)
+ (select-job-for-commit conn
+ target-commit))))))
+
+(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
+ (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))
+ (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)))))))
+
+(define (render-compare/derivations 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
+ (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
+ 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")
- (let ((base-commit (-> request
- request-uri
- uri-query
- parse-query-string
- (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)
- (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* ((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))
- (other-changes
- (package-data-other-changes base-packages-vhash
- target-packages-vhash)))
- (apply render-html
- (compare base-commit
- target-commit
- new-packages
- removed-packages
- version-changes
- other-changes)))))))))
+ (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 'html
+ conn
+ 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")
- (let ((base-commit (-> request
- request-uri
- uri-query
- parse-query-string
- (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)
- (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))))
- (apply render-html
- (compare/derivations
- base-commit
- target-commit
- (package-data-vhash->derivations
- conn
- base-packages-vhash)
- (package-data-vhash->derivations
- conn
- target-packages-vhash)))))))))
+ (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))))