diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index a6aa198..b7788cb 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -584,19 +584,115 @@ (derivation-differences-data conn base-derivation target-derivation))))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - '((error . "unimplemented")) ; TODO - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare/derivation - query-parameters - data) - #:extra-headers http-headers-for-unchanging-content))))))) + (let ((outputs (assq-ref data 'outputs)) + (inputs (assq-ref data 'inputs)) + (sources (assq-ref data 'sources)) + (system (assq-ref data 'system)) + (builder (assq-ref data 'builder)) + (args (assq-ref data 'arguments)) + (environment-variables (assq-ref data 'environment-variables)) + (get-derivation-data + (lambda (items) + (map + (match-lambda + ((name path hash-alg hash recursive) + `(,@(if (null? name) + '() + `((name . ,name))) + ,@(if (null? path) + '() + `((path . ,path)) + ) + ,@(if (or (null? hash-alg) (not (string? hash-alg))) + '() + `((hash-algorithm . ,hash-alg)) + ) + ,@(if (or (null? hash) (not (string? hash))) + '() + `((hash . ,hash)) + ) + ,@(if (null? recursive) + '() + `((recursive . ,(string=? recursive "t")))))) + ((derivation output) + `(,@(if (null? derivation) + '() + `((derivation . ,derivation))) + ,@(if (null? output) + '() + `((output . ,output))))) + ((derivation) + `(,@(if (null? derivation) + '() + `((derivation . ,derivation)))))) + (or items '()))))) + + (let ((base-system (assq-ref system 'base)) + (target-system (assq-ref system 'target)) + (common-system (assq-ref system 'common)) + + (base-builder (assq-ref builder 'base)) + (target-builder (assq-ref builder 'target)) + (common-builder (assq-ref builder 'common)) + + (base-args (assq-ref args 'base)) + (target-args (assq-ref args 'target)) + (common-args (assq-ref args 'common))) + + (let ((matched-outputs (append-map get-derivation-data + (list (assq-ref outputs 'base) + (assq-ref outputs 'target) + (assq-ref outputs 'common)))) + (matched-inputs (append-map get-derivation-data + (list (assq-ref inputs 'base) + (assq-ref inputs 'target)))) + (matched-sources (append-map get-derivation-data + (list (assq-ref sources 'base) + (assq-ref sources 'target) + (assq-ref sources 'common))))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((revision + . ((base + . ((derivation . ,base-derivation))) + (target + . ((derivation . ,target-derivation))))) + (outputs + . ,((lambda (l) (cond + ((= (length l) 3) `((base . ,(first l)) + (target . ,(second l)) + (common . ,(third l)))) + ((= (length l) 2) `((base . ,(first l)) + (target . ,(second l)))) + (else `((common . ,(first l)))))) + matched-outputs)) + (inputs + . ((base . ,(first matched-inputs)) + (target . ,(second matched-inputs)))) + (source + . ((base . ,(first matched-sources)) + (target . ,(second matched-sources)) + (common . ,(third matched-sources)))) + (system + . ((common . ,common-system))) + (builder-and-arguments + . ((builder . ,common-builder) + (arguments + . ((base . ,(list->vector + base-args)) + (target . ,(list->vector + target-args)))))) + (environment-variables . ,environment-variables)) + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare/derivation + query-parameters + data) + #:extra-headers http-headers-for-unchanging-content)))))))))) (define (render-compare/package-derivations mime-types query-parameters)