From c7af970c677a8d97cb4841a748e343c03e0bc886 Mon Sep 17 00:00:00 2001 From: Luciana Brito Date: Sun, 11 Apr 2021 11:06:06 -0300 Subject: [PATCH 1/7] Include base-derivation and target-derivation on json of render-compare/derivation --- guix-data-service/web/compare/controller.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index a6aa198..355ce03 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -589,7 +589,12 @@ mime-types) ((application/json) (render-json - '((error . "unimplemented")) ; TODO + `((revision + . ((base + . ((derivation . ,base-derivation))) + (target + . ((derivation . ,target-derivation)))))) + ;'((error . "unimplemented")) ; TODO #:extra-headers http-headers-for-unchanging-content)) (else (render-html -- 2.30.2 From d91856c6b4a0e998288b2291f9a9f420f9916dc4 Mon Sep 17 00:00:00 2001 From: Luciana Brito Date: Mon, 12 Apr 2021 11:05:20 -0300 Subject: [PATCH 2/7] Include base and target outputs to json of render-compare/derivation --- guix-data-service/web/compare/controller.scm | 127 ++++++++++++++++--- 1 file changed, 109 insertions(+), 18 deletions(-) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index 355ce03..2f54310 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -584,24 +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 - `((revision - . ((base - . ((derivation . ,base-derivation))) - (target - . ((derivation . ,target-derivation)))))) - ;'((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)) + (build-and-args (assq-ref data 'build-and-args)) + (envronment-and-variables (assq-ref data 'envronment-and-variables)) + ) + (let ((base-outputs (assq-ref outputs 'base)) + (target-outputs (assq-ref outputs 'target)) + + (base-inputs (assq-ref inputs 'base)) + (target-inputs (assq-ref inputs 'target)) + + (base-sources (assq-ref sources 'base)) + (target-sources (assq-ref sources 'target)) + + (base-system (assq-ref system 'base)) + (target-system (assq-ref system 'target)) + + (base-build-and-args (assq-ref build-and-args 'base)) + (target-build-and-args (assq-ref build-and-args 'target)) + + (base-environment-and-variables (assq-ref envronment-and-variables 'base)) + (target-environment-and-variables (assq-ref envronment-and-variables 'target)) + + ) + + ;(let-values + ; (((base-derivation-output target-derivation-output) + ; (assq-ref data 'outputs))) + ; (let ((derivation-changes + ; (package-derivation-data-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 + `((revision + . ((base + . ((derivation . ,base-derivation))) + (target + . ((derivation . ,target-derivation))))) + (outputs . ((base . ,(list->vector + (map + (match-lambda + ((name path hash-alg hash recursive) + `(,@(if (null? name) + '() + `((name . ,name))) + ,@(if (null? path) + '() + `((path . ,path)) + ) + ,@(if (null? hash-alg) + '() + `((hash-algorithm . ,hash-alg)) + ) + ,@(if (null? hash) + '() + `((hash . ,hash)) + ) + ,@(if (null? recursive) + '() + `((recursive . ,recursive)) + ) + ;(change . ,change) + ))) + base-outputs))) + + (target . ,(list->vector + (map + (match-lambda + ((name path hash-alg hash recursive) + `(,@(if (null? name) + '() + `((name . ,name))) + ,@(if (null? path) + '() + `((path . ,path)) + ) + ,@(if (null? hash-alg) + '() + `((hash-algorithm . ,hash-alg)) + ) + ,@(if (null? hash) + '() + `((hash . ,hash)) + ) + ,@(if (null? recursive) + '() + `((recursive . ,recursive)) + ) + ;(change . ,change) + ))) + target-outputs)))) + + ) + ) + #: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) -- 2.30.2 From 3810e457e75a24ae1c1582a35956c6bc9e37c614 Mon Sep 17 00:00:00 2001 From: Luciana Brito Date: Mon, 12 Apr 2021 15:52:17 -0300 Subject: [PATCH 3/7] Include base and target outputs to json in same anonymous function of render-compare/derivation --- guix-data-service/web/compare/controller.scm | 84 +++++++------------- 1 file changed, 30 insertions(+), 54 deletions(-) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index 2f54310..7fa2fc0 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -630,62 +630,38 @@ . ((derivation . ,base-derivation))) (target . ((derivation . ,target-derivation))))) - (outputs . ((base . ,(list->vector - (map - (match-lambda - ((name path hash-alg hash recursive) - `(,@(if (null? name) - '() - `((name . ,name))) - ,@(if (null? path) - '() - `((path . ,path)) - ) - ,@(if (null? hash-alg) - '() - `((hash-algorithm . ,hash-alg)) - ) - ,@(if (null? hash) - '() - `((hash . ,hash)) - ) - ,@(if (null? recursive) - '() - `((recursive . ,recursive)) - ) + (outputs . ,(list->vector + (append-map + (lambda (items) + (map + (match-lambda + ((name path hash-alg hash recursive) + `(,@(if (null? name) + '() + `((name . ,name))) + ,@(if (null? path) + '() + `((path . ,path)) + ) + ,@(if (null? hash-alg) + '() + `((hash-algorithm . ,hash-alg)) + ) + ,@(if (null? hash) + '() + `((hash . ,hash)) + ) + ,@(if (null? recursive) + '() + `((recursive . ,recursive)) + ) ;(change . ,change) - ))) - base-outputs))) + ))) + (or items '()))) - (target . ,(list->vector - (map - (match-lambda - ((name path hash-alg hash recursive) - `(,@(if (null? name) - '() - `((name . ,name))) - ,@(if (null? path) - '() - `((path . ,path)) - ) - ,@(if (null? hash-alg) - '() - `((hash-algorithm . ,hash-alg)) - ) - ,@(if (null? hash) - '() - `((hash . ,hash)) - ) - ,@(if (null? recursive) - '() - `((recursive . ,recursive)) - ) - ;(change . ,change) - ))) - target-outputs)))) - - ) - ) + (list base-outputs + target-outputs)))) + );revision #:extra-headers http-headers-for-unchanging-content)) (else (render-html -- 2.30.2 From aa5292177bbe70564306cebdebff417754b807b6 Mon Sep 17 00:00:00 2001 From: Luciana Brito Date: Wed, 14 Apr 2021 14:04:21 -0300 Subject: [PATCH 4/7] Fix rendering for outputs on json from render-compare/derivation --- guix-data-service/web/compare/controller.scm | 231 +++++++++++++------ 1 file changed, 165 insertions(+), 66 deletions(-) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index 7fa2fc0..dcb0175 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -589,86 +589,185 @@ (inputs (assq-ref data 'inputs)) (sources (assq-ref data 'sources)) (system (assq-ref data 'system)) - (build-and-args (assq-ref data 'build-and-args)) - (envronment-and-variables (assq-ref data 'envronment-and-variables)) + (builder (assq-ref data 'builder)) + (args (assq-ref data 'arguments)) + (environment-variables (assq-ref data 'environment-variables)) ) - (let ((base-outputs (assq-ref outputs 'base)) - (target-outputs (assq-ref outputs 'target)) - + + (let (;(base-outputs (assq-ref outputs 'base)) + ;(target-outputs (assq-ref outputs 'target)) + ;(common-outputs (assq-ref outputs 'common)) + + (matched-outputs (append-map + (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"))))) + )) + (or items '()))) + (list (assq-ref outputs 'base) + (assq-ref outputs 'target) + (assq-ref outputs 'common)))) + (base-inputs (assq-ref inputs 'base)) (target-inputs (assq-ref inputs 'target)) (base-sources (assq-ref sources 'base)) (target-sources (assq-ref sources 'target)) + (common-sources (assq-ref sources 'common)) (base-system (assq-ref system 'base)) (target-system (assq-ref system 'target)) + (common-system (assq-ref system 'common)) - (base-build-and-args (assq-ref build-and-args 'base)) - (target-build-and-args (assq-ref build-and-args 'target)) + (base-builder (assq-ref builder 'base)) + (target-builder (assq-ref builder 'target)) + (common-builder (assq-ref builder 'common)) - (base-environment-and-variables (assq-ref envronment-and-variables 'base)) - (target-environment-and-variables (assq-ref envronment-and-variables 'target)) - + (base-args (assq-ref args 'base)) + (target-args (assq-ref args 'target)) + (common-args (assq-ref args 'common)) ) - ;(let-values - ; (((base-derivation-output target-derivation-output) - ; (assq-ref data 'outputs))) - ; (let ((derivation-changes - ; (package-derivation-data-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 - `((revision - . ((base - . ((derivation . ,base-derivation))) - (target - . ((derivation . ,target-derivation))))) - (outputs . ,(list->vector - (append-map - (lambda (items) - (map - (match-lambda - ((name path hash-alg hash recursive) - `(,@(if (null? name) - '() - `((name . ,name))) - ,@(if (null? path) - '() - `((path . ,path)) - ) - ,@(if (null? hash-alg) - '() - `((hash-algorithm . ,hash-alg)) - ) - ,@(if (null? hash) - '() - `((hash . ,hash)) - ) - ,@(if (null? recursive) - '() - `((recursive . ,recursive)) - ) - ;(change . ,change) - ))) - (or items '()))) + (match environment-variables + ((name . values) + (let ((environment-variables-name name) + (common-environment-variables (assq-ref values 'common)) + (base-environment-variables (assq-ref values 'base)) + (target-environment-variables (assq-ref values 'target)) + ) + + (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 . ,(list->vector + ; (append-map + ; (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) + ; '() + ;if there is other representation for "true" + ;this parse won't work + ; `((recursive . ,(string=? recursive "t"))) + ; ) + ; ))) + ; (or items '())) + ; );inner lambda - (list base-outputs - target-outputs)))) - );revision - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare/derivation - query-parameters - data) - #:extra-headers http-headers-for-unchanging-content))))))))) + ; (list base-outputs + ; target-outputs + ; common-outputs)))) + + (output + . ,((lambda (x) (cond + ((= (length x) 3) `((base . ,(first x)) + (target . ,(second x)) + (common . ,(third x)))) + ((= (length x) 2) `((base . ,(first x)) + (target . ,(second x)))) + (else `((common . ,(first x)))))) + + matched-outputs)) + + (inputs . ,(list->vector + (append-map + (lambda (items) + (map + (match-lambda + ((derivation output) + `(,@(if (null? derivation) + '() + `((derivation . ,derivation))) + ,@(if (null? output) + '() + `((output . ,output)))))) + (or items '()))) + (list base-inputs + target-inputs) + ))) + + (source + . ((base . ,base-sources))) + +; (sources . ,(list->vector +; (append-map +; (lambda (items) +; (map +; (match-lambda +; ((derivation) +; `(,@(if (null? derivation) +; '() +; `((derivation . ,derivation)))))) +; (or items '()))) +; (list base-sources +; target-sources +; common-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) + + + );revision + #: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) -- 2.30.2 From b61825ca583b1a3d598575f12aa8c6e279ca60ad Mon Sep 17 00:00:00 2001 From: Luciana Brito Date: Wed, 14 Apr 2021 15:37:19 -0300 Subject: [PATCH 5/7] Fix rendering for sources on json from remder-compare/derivation --- guix-data-service/web/compare/controller.scm | 169 +++++++------------ 1 file changed, 61 insertions(+), 108 deletions(-) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index dcb0175..bfec00c 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -594,46 +594,46 @@ (environment-variables (assq-ref data 'environment-variables)) ) - (let (;(base-outputs (assq-ref outputs 'base)) - ;(target-outputs (assq-ref outputs 'target)) - ;(common-outputs (assq-ref outputs 'common)) - - (matched-outputs (append-map - (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"))))) - )) - (or items '()))) - (list (assq-ref outputs 'base) - (assq-ref outputs 'target) - (assq-ref outputs 'common)))) + (let ((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 '()) + )) + ) - (base-inputs (assq-ref inputs 'base)) - (target-inputs (assq-ref inputs 'target)) - - (base-sources (assq-ref sources 'base)) - (target-sources (assq-ref sources 'target)) - (common-sources (assq-ref sources 'common)) - (base-system (assq-ref system 'base)) (target-system (assq-ref system 'target)) (common-system (assq-ref system 'common)) @@ -647,6 +647,19 @@ (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)))) + ) + (match environment-variables ((name . values) (let ((environment-variables-name name) @@ -665,42 +678,7 @@ . ((derivation . ,base-derivation))) (target . ((derivation . ,target-derivation))))) - ;(outputs . ,(list->vector - ; (append-map - ; (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) - ; '() - ;if there is other representation for "true" - ;this parse won't work - ; `((recursive . ,(string=? recursive "t"))) - ; ) - ; ))) - ; (or items '())) - ; );inner lambda - - ; (list base-outputs - ; target-outputs - ; common-outputs)))) - - (output + (outputs . ,((lambda (x) (cond ((= (length x) 3) `((base . ,(first x)) (target . ,(second x)) @@ -711,41 +689,16 @@ matched-outputs)) - (inputs . ,(list->vector - (append-map - (lambda (items) - (map - (match-lambda - ((derivation output) - `(,@(if (null? derivation) - '() - `((derivation . ,derivation))) - ,@(if (null? output) - '() - `((output . ,output)))))) - (or items '()))) - (list base-inputs - target-inputs) - ))) + (inputs + . ((base . ,(first matched-inputs)) + (target . ,(second matched-inputs)) + )) (source - . ((base . ,base-sources))) + . ((base . ,(first matched-sources)) + (target . ,(second matched-sources)) + (common . ,(third matched-sources)))) -; (sources . ,(list->vector -; (append-map -; (lambda (items) -; (map -; (match-lambda -; ((derivation) -; `(,@(if (null? derivation) -; '() -; `((derivation . ,derivation)))))) -; (or items '()))) -; (list base-sources -; target-sources -; common-sources))) -; ) - (system . ((common . ,common-system))) @@ -767,7 +720,7 @@ #:sxml (compare/derivation query-parameters data) - #:extra-headers http-headers-for-unchanging-content)))))))))))) + #:extra-headers http-headers-for-unchanging-content))))))))))))) (define (render-compare/package-derivations mime-types query-parameters) -- 2.30.2 From 2c8d95aea7ef3f2950bbb125c995e009f61edf12 Mon Sep 17 00:00:00 2001 From: Luciana Brito Date: Wed, 14 Apr 2021 16:28:43 -0300 Subject: [PATCH 6/7] Generate a complete json output for render-compare/derivation procedure for the derivation comparison page. --- guix-data-service/web/compare/controller.scm | 202 ++++++++----------- 1 file changed, 87 insertions(+), 115 deletions(-) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index bfec00c..b7788cb 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -584,57 +584,50 @@ (derivation-differences-data conn base-derivation target-derivation))))) - (let ((outputs (assq-ref data 'outputs)) - (inputs (assq-ref data 'inputs)) + (inputs (assq-ref data 'inputs)) (sources (assq-ref data 'sources)) - (system (assq-ref data 'system)) + (system (assq-ref data 'system)) (builder (assq-ref data 'builder)) - (args (assq-ref data 'arguments)) + (args (assq-ref data 'arguments)) (environment-variables (assq-ref data 'environment-variables)) - ) - - (let ((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 '()) - )) - ) - - (base-system (assq-ref system 'base)) + (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)) @@ -644,8 +637,7 @@ (base-args (assq-ref args 'base)) (target-args (assq-ref args 'target)) - (common-args (assq-ref args 'common)) - ) + (common-args (assq-ref args 'common))) (let ((matched-outputs (append-map get-derivation-data (list (assq-ref outputs 'base) @@ -655,72 +647,52 @@ (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)))) - ) - - (match environment-variables - ((name . values) - (let ((environment-variables-name name) - (common-environment-variables (assq-ref values 'common)) - (base-environment-variables (assq-ref values 'base)) - (target-environment-variables (assq-ref values 'target)) - ) - - (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 (x) (cond - ((= (length x) 3) `((base . ,(first x)) - (target . ,(second x)) - (common . ,(third x)))) - ((= (length x) 2) `((base . ,(first x)) - (target . ,(second x)))) - (else `((common . ,(first x)))))) - - 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) - - - );revision - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare/derivation - query-parameters - data) - #:extra-headers http-headers-for-unchanging-content))))))))))))) + (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) -- 2.30.2 From e8d99e4a422dc9ee01625e5a3206768ba09a2d54 Mon Sep 17 00:00:00 2001 From: Luciana Brito Date: Thu, 15 Apr 2021 12:47:46 -0300 Subject: [PATCH 7/7] Improve json output for render-data/derivation --- guix-data-service/web/compare/controller.scm | 213 +++++++++---------- 1 file changed, 103 insertions(+), 110 deletions(-) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index b7788cb..882652a 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -583,116 +583,109 @@ (lambda (conn) (derivation-differences-data conn base-derivation - target-derivation))))) - (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)))))))))) + target-derivation)))) + (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 '()))))) + + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (let* ((outputs (assq-ref data 'outputs)) + (base-outputs (append-map get-derivation-data (list (assq-ref outputs 'base)))) + (target-outputs (append-map get-derivation-data (list (assq-ref outputs 'target)))) + (common-outputs (append-map get-derivation-data (list (assq-ref outputs 'common)))) + + (inputs (assq-ref data 'inputs)) + (base-inputs (append-map get-derivation-data (list (assq-ref inputs 'base)))) + (target-inputs (append-map get-derivation-data (list (assq-ref inputs 'target)))) + + (sources (assq-ref data 'sources)) + (base-sources (append-map get-derivation-data (list (assq-ref sources 'base)))) + (target-sources (append-map get-derivation-data (list (assq-ref sources 'target)))) + (common-sources (append-map get-derivation-data (list (assq-ref sources 'common)))) + + (system (assq-ref data 'system)) + (base-system (assq-ref system 'base)) + (target-system (assq-ref system 'target)) + (common-system (assq-ref system 'common)) + + (builder (assq-ref data 'builder)) + (base-builder (assq-ref builder 'base)) + (target-builder (assq-ref builder 'target)) + (common-builder (assq-ref builder 'common)) + + (args (assq-ref data 'arguments)) + (base-args (assq-ref args 'base)) + (target-args (assq-ref args 'target)) + (common-args (assq-ref args 'common)) + (environment-variables (assq-ref data 'environment-variables))) + (render-json + `((base + . ((derivation . ,base-derivation))) + (target + . ((derivation . ,target-derivation))) + (outputs + . ((base . ,(list->vector base-outputs)) + (target . ,(list->vector target-outputs)) + (common . ,(list->vector common-outputs)))) + (inputs + . ((base . ,(list->vector base-inputs)) + (target . ,(list->vector target-inputs)))) + (sources + . ((base . ,(list->vector base-sources)) + (target . ,(list->vector target-sources)) + (common . ,(list->vector common-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) -- 2.30.2