diff options
Diffstat (limited to 'guix-data-service/web/controller.scm')
| -rw-r--r-- | guix-data-service/web/controller.scm | 448 |
1 files changed, 3 insertions, 445 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 7ad097f..5aecd9d 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -28,7 +28,6 @@ #:use-module (web uri) #:use-module (texinfo) #:use-module (texinfo html) - #:use-module (texinfo plain-text) #:use-module (squee) #:use-module (json) #:use-module (guix-data-service config) @@ -51,6 +50,7 @@ #:use-module (guix-data-service web sxml) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) + #:use-module (guix-data-service web revision controller) #:use-module (guix-data-service web jobs controller) #:use-module (guix-data-service web view html) #:export (controller)) @@ -89,375 +89,6 @@ value))) alist)) -(define* (render-view-revision mime-types - conn - commit-hash - #:key path-base - (header-text - `("Revision " (samp ,commit-hash)))) - (let ((packages-count - (count-packages-in-revision conn commit-hash)) - (git-repositories-and-branches - (git-branches-with-repository-details-for-commit conn commit-hash)) - (derivations-counts - (count-packages-derivations-in-revision conn commit-hash)) - (jobs-and-events - (select-jobs-and-events-for-commit conn commit-hash)) - (lint-warning-counts - (lint-warning-count-by-lint-checker-for-revision conn commit-hash))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((packages_count . ,(caar packages-count)) - (derivations_counts . ,(list->vector - (map (match-lambda - ((system target derivation_count) - `((system . ,system) - (target . ,target) - (derivation_count . ,derivation_count)))) - derivations-counts))) - (lint_warning_counts . ,(map (match-lambda - ((name description network-dependent count) - `(,name . ((description . ,description) - (network_dependent . ,(string=? network-dependent "t")) - (count . ,(string->number count)))))) - lint-warning-counts))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (view-revision - commit-hash - packages-count - git-repositories-and-branches - derivations-counts - jobs-and-events - lint-warning-counts - #:path-base path-base - #:header-text header-text) - #:extra-headers http-headers-for-unchanging-content))))) - -(define (texinfo->variants-alist s) - (let ((stexi (texi-fragment->stexi s))) - `((source . ,s) - (html . ,(with-output-to-string - (lambda () - (sxml->html (stexi->shtml stexi))))) - (plain . ,(stexi->plain-text stexi))))) - -(define (render-unknown-revision mime-types conn commit-hash) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - '((unknown_commit . ,commit-hash)) - #:code 404)) - (else - (render-html - #:code 404 - #:sxml (unknown-revision - commit-hash - (select-job-for-commit - conn commit-hash) - (git-branches-with-repository-details-for-commit conn commit-hash) - (select-jobs-and-events-for-commit conn commit-hash)))))) - - -(define* (render-revision-packages mime-types - conn - commit-hash - query-parameters - #:key - (path-base "/revision/") - (header-text - `("Revision " (samp ,commit-hash))) - (header-link - (string-append "/revision/" commit-hash))) - (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 (view-revision-packages commit-hash - query-parameters - '() - '() - #f - #:path-base path-base - #:header-text header-text - #:header-link header-link)))) - - (let* ((search-query (assq-ref query-parameters 'search_query)) - (limit-results (or (assq-ref query-parameters 'limit_results) - 99999)) ; TODO There shouldn't be a limit - (fields (assq-ref query-parameters 'field)) - (packages - (if search-query - (search-packages-in-revision - conn - commit-hash - search-query - #:limit-results limit-results) - (select-packages-in-revision - conn - commit-hash - #:limit-results limit-results - #:after-name (assq-ref query-parameters 'after_name)))) - (git-repositories - (git-repositories-containing-commit conn - commit-hash)) - (show-next-page? - (and (not search-query) - (>= (length packages) - limit-results)))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((revision - . ((commit . ,commit-hash))) - (packages - . ,(list->vector - (map (match-lambda - ((name version synopsis description home-page - location-file location-line - location-column-number licenses) - `((name . ,name) - ,@(if (member "version" fields) - `((version . ,version)) - '()) - ,@(if (member "synopsis" fields) - `((synopsis - . ,(texinfo->variants-alist synopsis))) - '()) - ,@(if (member "description" fields) - `((description - . ,(texinfo->variants-alist description))) - '()) - ,@(if (member "home-page" fields) - `((home-page . ,home-page)) - '()) - ,@(if (member "location" fields) - `((location - . ((file . ,location-file) - (line . ,location-line) - (column . ,location-column-number)))) - '()) - ,@(if (member "licenses" fields) - `((licenses - . ,(if (string-null? licenses) - #() - (json-string->scm licenses)))) - '())))) - packages)))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (view-revision-packages commit-hash - query-parameters - packages - git-repositories - show-next-page? - #:path-base path-base - #:header-text header-text - #:header-link header-link) - #:extra-headers http-headers-for-unchanging-content)))))) - -(define* (render-revision-package mime-types - conn - commit-hash - name - #:key - (path-base "/revision/") - (header-text - `("Revision " - (samp ,commit-hash))) - (header-link - (string-append - "/revision/" commit-hash))) - (let ((package-versions - (select-package-versions-for-revision conn - commit-hash - name)) - (git-repositories-and-branches - (git-branches-with-repository-details-for-commit conn - commit-hash))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((versions . ,(list->vector package-versions))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (view-revision-package commit-hash - name - package-versions - git-repositories-and-branches - #:path-base path-base - #:header-text header-text - #:header-link header-link) - #:extra-headers http-headers-for-unchanging-content))))) - -(define* (render-revision-package-version mime-types - conn - commit-hash - name - version - #:key - (header-text - `("Revision " - (samp ,commit-hash))) - (header-link - (string-append - "/revision/" commit-hash))) - (let ((metadata - (select-package-metadata-by-revision-name-and-version - conn - commit-hash - name - version)) - (derivations - (select-derivations-by-revision-name-and-version - conn - commit-hash - name - version)) - (git-repositories - (git-repositories-containing-commit conn - commit-hash)) - (lint-warnings - (select-lint-warnings-by-revision-package-name-and-version - conn - commit-hash - name - version))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((name . ,name) - (version . ,version) - ,@(match metadata - (((synopsis description home-page)) - `((synopsis . ,synopsis) - (description . ,description) - (home-page . ,home-page)))) - (derivations . ,(list->vector - (map (match-lambda - ((system target file-name status) - `((system . ,system) - (target . ,target) - (derivation . ,file-name)))) - derivations)))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (view-revision-package-and-version commit-hash - name - version - metadata - derivations - git-repositories - lint-warnings - #:header-text header-text - #:header-link header-link) - #:extra-headers http-headers-for-unchanging-content))))) - -(define* (render-revision-lint-warnings mime-types - conn - commit-hash - query-parameters - #:key - (path-base "/revision/") - (header-text - `("Revision " (samp ,commit-hash))) - (header-link - (string-append "/revision/" commit-hash))) - (define lint-checker-options - (map (match-lambda - ((name description network-dependent) - (cons (string-append name ": " description ) - name))) - (lint-checkers-for-revision conn commit-hash))) - - (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 (view-revision-lint-warnings commit-hash - query-parameters - '() - lint-checker-options - #:path-base path-base - #:header-text header-text - #:header-link header-link)))) - - (let* ((package-query (assq-ref query-parameters 'package_query)) - (linters (assq-ref query-parameters 'linter)) - (message-query (assq-ref query-parameters 'message_query)) - (fields (assq-ref query-parameters 'field)) - (git-repositories - (git-repositories-containing-commit conn - commit-hash)) - (lint-warnings - (lint-warnings-for-guix-revision conn commit-hash - #:package-query package-query - #:linters linters - #:message-query message-query))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((revision - . ((commit . ,commit-hash))) - (lint_warnings - . ,(list->vector - (map (match-lambda - ((id lint-checker-name lint-checker-description - lint-checker-network-dependent - package-name package-version - file line-number column-number - message) - `((package . ((name . ,package-name) - (version . ,package-version))) - ,@(if (member "message" fields) - `((message . ,message)) - '()) - ,@(if (member "location" fields) - `((location . ((file . ,file) - (line-number . ,line-number) - (column-number . ,column-number)))) - '())))) - lint-warnings)))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (view-revision-lint-warnings commit-hash - query-parameters - lint-warnings - git-repositories - lint-checker-options - #:path-base path-base - #:header-text header-text - #:header-link header-link) - #:extra-headers http-headers-for-unchanging-content)))))) - (define (render-compare mime-types conn query-parameters) @@ -983,81 +614,8 @@ (render-html #:sxml (view-statistics (count-guix-revisions conn) (count-derivations conn)))) - (('GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash) - (render-view-revision mime-types - conn - commit-hash - #:path-base path) - (render-unknown-revision mime-types - conn - commit-hash))) - (('GET "revision" commit-hash "packages") - (if (guix-commit-exists? conn commit-hash) - (let ((parsed-query-parameters - (guard-against-mutually-exclusive-query-parameters - (parse-query-parameters - request - `((after_name ,identity) - (field ,identity #:multi-value - #:default ("version" "synopsis")) - (search_query ,identity) - (limit_results ,parse-result-limit - #:no-default-when (all_results) - #:default 100) - (all_results ,parse-checkbox-value))) - ;; You can't specify a search query, but then also limit the - ;; results by filtering for after a particular package name - '((after_name search_query) - (limit_results all_results))))) - - (render-revision-packages mime-types - conn - commit-hash - parsed-query-parameters - #:path-base path)) - (render-unknown-revision mime-types - conn - commit-hash))) - (('GET "revision" commit-hash "package" name) - (if (guix-commit-exists? conn commit-hash) - (render-revision-package mime-types - conn - commit-hash - name) - (render-unknown-revision mime-types - conn - commit-hash))) - (('GET "revision" commit-hash "package" name version) - (if (guix-commit-exists? conn commit-hash) - (render-revision-package-version mime-types - conn - commit-hash - name - version) - (render-unknown-revision mime-types - conn - commit-hash))) - (('GET "revision" commit-hash "lint-warnings") - (if (guix-commit-exists? conn commit-hash) - (let ((parsed-query-parameters - (parse-query-parameters - request - `((package_query ,identity) - (linter ,identity #:multi-value) - (message_query ,identity) - (field ,identity #:multi-value - #:default ("linter" - "message" - "location")))))) - - (render-revision-lint-warnings mime-types - conn - commit-hash - parsed-query-parameters - #:path-base path)) - (render-unknown-revision mime-types - conn - commit-hash))) + (('GET "revision" args ...) + (delegate-to revision-controller)) (('GET "repository" id) (match (select-git-repository conn id) ((label url cgit-url-base) |