diff options
Diffstat (limited to 'guix-data-service/web/controller.scm')
| -rw-r--r-- | guix-data-service/web/controller.scm | 451 |
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)) |