diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm index f048c0d..e68f3f1 100644 --- a/guix-data-service/database.scm +++ b/guix-data-service/database.scm @@ -48,6 +48,10 @@ NULL? exec-query-with-null-handling)) +;; TODO This isn't exported for some reason +(define pg-conn-finish + (@@ (squee) pg-conn-finish)) + (define %database-metrics-registry (make-parameter #f)) diff --git a/guix-data-service/metrics.scm b/guix-data-service/metrics.scm index 143fa7e..ca1d97a 100644 --- a/guix-data-service/metrics.scm +++ b/guix-data-service/metrics.scm @@ -107,25 +107,25 @@ WHERE relname NOT LIKE 'package_derivations_by_guix_revision_range_git_branch_%' last-vacuum last-autovacuum last-analyze last-autoanalyze vacuum-count autovacuum-count analyze-count autoanalyze-count) `((name . ,relname) - (seq-scan . ,(string->number seq-scan)) - (seq-tup-read . ,(string->number seq-tup-read)) - (idx-scan . ,(string->number idx-scan)) - (idx-tup-fetch . ,(string->number idx-tup-fetch)) - (n-tup-ins . ,(string->number n-tup-ins)) - (n-tup-upd . ,(string->number n-tup-upd)) - (n-tup-del . ,(string->number n-tup-del)) - (n-tup-hot-upd . ,(string->number n-tup-hot-upd)) - (n-live-tup . ,(string->number n-live-tup)) - (n-dead-tup . ,(string->number n-dead-tup)) - (n-mod-since-analyze . ,(string->number n-mod-since-analyze)) - (last-vacuum . ,(string->number last-vacuum)) - (last-autovacuum . ,(string->number last-autovacuum)) - (last-analyze . ,(string->number last-analyze)) - (last-autoanalyze . ,(string->number last-autoanalyze)) - (vacuum-count . ,(string->number vacuum-count)) - (autovacuum-count . ,(string->number autovacuum-count)) - (analyze-count . ,(string->number analyze-count)) - (autoanalyze-count . ,(string->number autoanalyze-count))))) + (seq-scan . ,seq-scan) + (seq-tup-read . ,seq-tup-read) + (idx-scan . ,idx-scan) + (idx-tup-fetch . ,idx-tup-fetch) + (n-tup-ins . ,n-tup-ins) + (n-tup-upd . ,n-tup-upd) + (n-tup-del . ,n-tup-del) + (n-tup-hot-upd . ,n-tup-hot-upd) + (n-live-tup . ,n-live-tup) + (n-dead-tup . ,n-dead-tup) + (n-mod-since-analyze . ,n-mod-since-analyze) + (last-vacuum . ,last-vacuum) + (last-autovacuum . ,last-autovacuum) + (last-analyze . ,last-analyze) + (last-autoanalyze . ,last-autoanalyze) + (vacuum-count . ,vacuum-count) + (autovacuum-count . ,autovacuum-count) + (analyze-count . ,analyze-count) + (autoanalyze-count . ,autoanalyze-count)))) (exec-query conn query))) (define (fetch-pg-stat-user-indexes-metrics conn) @@ -153,10 +153,10 @@ WHERE pg_stat_user_indexes.schemaname = 'guix_data_service' `((name . ,indexname) (table-name . ,tablename) (tablespace . ,tablespace) - (idx-scan . ,(string->number idx_scan)) - (idx-tup-read . ,(string->number idx_tup_read)) - (idx-tup-fetch . ,(string->number idx_tup_fetch)) - (bytes . ,(string->number size_in_bytes))))) + (idx-scan . ,idx_scan) + (idx-tup-read . ,idx_tup_read) + (idx-tup-fetch . ,idx_tup_fetch) + (bytes . ,size_in_bytes)))) (exec-query conn query))) (define (fetch-pg-stats-metrics conn) diff --git a/guix-data-service/model/nar.scm b/guix-data-service/model/nar.scm index 41e08fc..9f607be 100644 --- a/guix-data-service/model/nar.scm +++ b/guix-data-service/model/nar.scm @@ -18,8 +18,6 @@ (define-module (guix-data-service model nar) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) - #:use-module (srfi srfi-43) - #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (web uri) #:use-module (squee) @@ -58,36 +56,26 @@ (or (narinfo-deriver narinfo) NULL))))) narinfos)) - (let* ((nar-ids - new-ids + (let ((nar-ids + (vector->list (insert-missing-data-and-return-all-ids conn "nars" '(store_path hash_algorithm hash size system deriver) - (list->vector data))) - (new-narinfos - (filter-map - (lambda (nar-id narinfo) - (if (vector-any (lambda (x) - (= x nar-id)) - new-ids) - (cons nar-id narinfo) - #f)) - (vector->list nar-ids) - narinfos))) + (list->vector data))))) (let ((reference-data (concatenate - (map (match-lambda - ((nar-id . narinfo) - (map (lambda (reference) - (simple-format - #f - "(~A, ~A)" - nar-id - (quote-string reference))) - (narinfo-references narinfo)))) - new-narinfos)))) + (map (lambda (nar-id narinfo) + (map (lambda (reference) + (simple-format + #f + "(~A, ~A)" + nar-id + (quote-string reference))) + (narinfo-references narinfo))) + nar-ids + narinfos)))) (unless (null? reference-data) (exec-query conn @@ -95,7 +83,9 @@ " INSERT INTO nar_references (nar_id, reference) VALUES " - (string-join reference-data ", "))))) + (string-join reference-data ", ") + " +ON CONFLICT DO NOTHING")))) (exec-query conn @@ -105,51 +95,55 @@ INSERT INTO nar_urls (nar_id, url, compression, file_size) VALUES " (string-join (concatenate - (map (match-lambda - ((nar-id . narinfo) - (map (lambda (uri compression file-size) - (simple-format - #f - "(~A, ~A, ~A, ~A)" - nar-id - (quote-string - (uri->string uri)) - (quote-string compression) - (or file-size "NULL"))) - (narinfo-uris narinfo) - (narinfo-compressions narinfo) - (narinfo-file-sizes narinfo)))) - new-narinfos)) - ", "))) + (map (lambda (nar-id narinfo) + (map (lambda (uri compression file-size) + (simple-format + #f + "(~A, ~A, ~A, ~A)" + nar-id + (quote-string + (uri->string uri)) + (quote-string compression) + (or file-size "NULL"))) + (narinfo-uris narinfo) + (narinfo-compressions narinfo) + (narinfo-file-sizes narinfo))) + nar-ids + narinfos)) + ", ") + " +ON CONFLICT DO NOTHING")) - (for-each (match-lambda - ((nar-id . narinfo) - (let ((narinfo-signature-data-id - (narinfo-signature->data-id conn narinfo))) + (for-each (lambda (nar-id narinfo) + (let ((narinfo-signature-data-id + (narinfo-signature->data-id conn narinfo))) - (exec-query - conn - (string-append - " + (exec-query + conn + (string-append + " INSERT INTO narinfo_signatures (nar_id, narinfo_signature_data_id) VALUES " - (simple-format - #f - "(~A,~A)" - nar-id - narinfo-signature-data-id))) + (simple-format + #f + "(~A,~A)" + nar-id + narinfo-signature-data-id) + " +ON CONFLICT DO NOTHING")) - (exec-query - conn - (string-append - " + (exec-query + conn + (string-append + " INSERT INTO narinfo_fetch_records (narinfo_signature_data_id, build_server_id) VALUES ($1, $2)") - (list (number->string narinfo-signature-data-id) - (number->string build-server-id)))))) - new-narinfos) + (list (number->string narinfo-signature-data-id) + (number->string build-server-id))))) + nar-ids + narinfos) - (vector->list nar-ids))) + nar-ids)) (define (sexp->json-string sexp) (define (transform x) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index 2c94904..8d7583f 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -628,7 +628,7 @@ (render-html #:sxml (compare/derivation query-parameters - #f)))) + '())))) (let ((base-derivation (assq-ref query-parameters 'base_derivation)) (target-derivation (assq-ref query-parameters 'target_derivation))) diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm index e92f74f..8711574 100644 --- a/guix-data-service/web/compare/html.scm +++ b/guix-data-service/web/compare/html.scm @@ -483,194 +483,191 @@ "View JSON"))))) (div (@ (class "row")) - ,@(if - data - `((div - (@ (class "col-sm-12")) - (h2 "Outputs") - ,@(let ((outputs (assq-ref data 'outputs))) - `((table + (div + (@ (class "col-sm-12")) + (h2 "Outputs") + ,@(let ((outputs (assq-ref data 'outputs))) + `((table + (@ (class "table")) + (thead + (tr + (th "") + (th "Name") + (th "Path") + (th "Hash algorithm") + (th "Hash") + (th "Recursive"))) + (tbody + ,@(append-map + (lambda (label items) + (map + (lambda (alist) + `(tr + (td ,label) + (td ,(assq-ref alist 'output-name)) + (td (a (@ (href ,(assq-ref alist 'path))) + ,(display-store-item (assq-ref alist 'path)))) + (td ,(assq-ref alist 'hash-algorithm)) + (td ,(assq-ref alist 'hash)) + (td ,(assq-ref alist 'recursive)))) + (or (and=> items vector->list) '()))) + (list base target "Common") + (list (assq-ref outputs 'base) + (assq-ref outputs 'target) + (assq-ref outputs 'common))))))) + (h2 "Inputs") + ,@(let ((inputs (assq-ref data 'inputs))) + `((table + (@ (class "table")) + (thead + (tr + (th "") + (th "Derivation") + (th "Outputs"))) + (tbody + ,@(append-map + (lambda (label items) + (map + (lambda (alist) + `(tr + (td ,label) + (td (a (@ (href ,(assq-ref alist 'derivation_file_name))) + ,(display-store-item (assq-ref alist 'derivation_file_name)))) + (td ,(assq-ref alist 'derivation_output_name)))) + (or (and=> items vector->list) '()))) + (list base target) + (list (assq-ref inputs 'base) + (assq-ref inputs 'target))))))) + (p "Common inputs are omitted.") + (h2 "Sources") + ,@(let ((sources (assq-ref data 'sources))) + `((table + (@ (class "table")) + (thead + (tr + (th "") + (th "Derivation"))) + (tbody + ,@(append-map + (lambda (label items) + (map + (lambda (alist) + `(tr + (td ,label) + (td (a (@ (href ,(assq-ref alist 'store_path))) + ,(display-store-item (assq-ref alist 'store_path)))))) + (or (and=> items vector->list) '()))) + (list base target "Common") + (list (assq-ref sources 'base) + (assq-ref sources 'target) + (assq-ref sources 'common))))))) + (h2 "System") + ,@(let ((system (assq-ref data 'system))) + (let ((common-system (assq-ref system 'common))) + (if common-system + (list common-system) + `(table (@ (class "table")) (thead (tr (th "") - (th "Name") - (th "Path") - (th "Hash algorithm") - (th "Hash") - (th "Recursive"))) + (th "System"))) (tbody - ,@(append-map - (lambda (label items) - (map - (lambda (alist) - `(tr - (td ,label) - (td ,(assq-ref alist 'output-name)) - (td (a (@ (href ,(assq-ref alist 'path))) - ,(display-store-item (assq-ref alist 'path)))) - (td ,(assq-ref alist 'hash-algorithm)) - (td ,(assq-ref alist 'hash)) - (td ,(assq-ref alist 'recursive)))) - (or (and=> items vector->list) '()))) - (list base target "Common") - (list (assq-ref outputs 'base) - (assq-ref outputs 'target) - (assq-ref outputs 'common))))))) - (h2 "Inputs") - ,@(let ((inputs (assq-ref data 'inputs))) - `((table - (@ (class "table")) - (thead - (tr - (th "") - (th "Derivation") - (th "Outputs"))) - (tbody - ,@(append-map - (lambda (label items) - (map - (lambda (alist) - `(tr - (td ,label) - (td (a (@ (href ,(assq-ref alist 'derivation_file_name))) - ,(display-store-item (assq-ref alist 'derivation_file_name)))) - (td ,(assq-ref alist 'derivation_output_name)))) - (or (and=> items vector->list) '()))) - (list base target) - (list (assq-ref inputs 'base) - (assq-ref inputs 'target))))))) - (p "Common inputs are omitted.") - (h2 "Sources") - ,@(let ((sources (assq-ref data 'sources))) - `((table - (@ (class "table")) - (thead - (tr - (th "") - (th "Derivation"))) - (tbody - ,@(append-map - (lambda (label items) - (map - (lambda (alist) - `(tr - (td ,label) - (td (a (@ (href ,(assq-ref alist 'store_path))) - ,(display-store-item (assq-ref alist 'store_path)))))) - (or (and=> items vector->list) '()))) - (list base target "Common") - (list (assq-ref sources 'base) - (assq-ref sources 'target) - (assq-ref sources 'common))))))) - (h2 "System") - ,@(let ((system (assq-ref data 'system))) - (let ((common-system (assq-ref system 'common))) - (if common-system - (list common-system) - `(table - (@ (class "table")) - (thead + ,@(let ((base-system (assq-ref system 'base)) + (target-system (assq-ref system 'target))) + `((tr + (td ,base) + (td ,base-system)) + (tr + (td ,target) + (td ,target-system))))))))) + (h2 "Builder and arguments") + ,(let ((builder (assq-ref data 'builder)) + (arguments (assq-ref data 'arguments))) + (let ((common-builder (assq-ref builder 'common)) + (common-args (assq-ref arguments 'common))) + (if (and common-builder + common-args) + `(table + (@ (class "table")) + (thead + (th "Builder") + (th "Arguments")) + (tbody + (tr + (td ,(display-possible-store-item common-builder)) + (td (ol + ,@(map (lambda (arg) + `(li ,(display-possible-store-item arg))) + common-args)))))) + `(table + (@ (class "table")) + (thead + (tr + (th "") + (th "Builder") + (th "Arguments"))) + (tbody + ,@(let ((base-builder (assq-ref builder 'base)) + (target-builder (assq-ref builder 'target)) + (base-args (assq-ref arguments 'base)) + (target-args (assq-ref arguments 'target))) + `((tr + (td ,base) + (td ,(display-possible-store-item + (or base-builder + common-builder))) + (td (ol + ,@(map (lambda (arg) + `(li ,(display-possible-store-item arg))) + (or (and=> common-args vector->list) + (vector->list base-args)))))) (tr - (th "") - (th "System"))) - (tbody - ,@(let ((base-system (assq-ref system 'base)) - (target-system (assq-ref system 'target))) - `((tr - (td ,base) - (td ,base-system)) - (tr - (td ,target) - (td ,target-system))))))))) - (h2 "Builder and arguments") - ,(let ((builder (assq-ref data 'builder)) - (arguments (assq-ref data 'arguments))) - (let ((common-builder (assq-ref builder 'common)) - (common-args (assq-ref arguments 'common))) - (if (and common-builder - common-args) - `(table - (@ (class "table")) - (thead - (th "Builder") - (th "Arguments")) - (tbody - (tr - (td ,(display-possible-store-item common-builder)) - (td (ol - ,@(map (lambda (arg) - `(li ,(display-possible-store-item arg))) - common-args)))))) - `(table - (@ (class "table")) - (thead - (tr - (th "") - (th "Builder") - (th "Arguments"))) - (tbody - ,@(let ((base-builder (assq-ref builder 'base)) - (target-builder (assq-ref builder 'target)) - (base-args (assq-ref arguments 'base)) - (target-args (assq-ref arguments 'target))) - `((tr - (td ,base) - (td ,(display-possible-store-item - (or base-builder - common-builder))) - (td (ol - ,@(map (lambda (arg) - `(li ,(display-possible-store-item arg))) - (or (and=> common-args vector->list) - (vector->list base-args)))))) - (tr - (td ,target) - (td ,(display-possible-store-item - (or target-builder - common-builder))) - (td (ol - ,@(map (lambda (arg) - `(li ,(display-possible-store-item arg))) - (or (and=> common-args vector->list) - (vector->list target-args))))))))))))) - (h2 "Environment variables") - ,(let ((environment-variables (assq-ref data 'environment-variables))) - `(table - (@ (class "table")) - (thead - (th "Name")) - (tbody - ,@(append-map - (match-lambda - ((name . values) - (let ((common-value (assq-ref values 'common))) - (if common-value - `((tr - (td ,name) - (td ,(display-possible-store-item common-value)))) - (let ((base-value (assq-ref values 'base)) - (target-value (assq-ref values 'target))) - (if (and base-value target-value) - `((tr - (td (@ (rowspan 2)) - ,name) - (td ,base ,(display-possible-store-item - base-value))) - (tr - (td ,target ,(display-possible-store-item - target-value)))) - `((tr - (td ,name) - (td ,@(if base-value - (list base - (display-possible-store-item - base-value)) - (list target - (display-possible-store-item - target-value)))))))))))) - environment-variables)))))) - '())))))) + (td ,target) + (td ,(display-possible-store-item + (or target-builder + common-builder))) + (td (ol + ,@(map (lambda (arg) + `(li ,(display-possible-store-item arg))) + (or (and=> common-args vector->list) + (vector->list target-args))))))))))))) + (h2 "Environment variables") + ,(let ((environment-variables (assq-ref data 'environment-variables))) + `(table + (@ (class "table")) + (thead + (th "Name")) + (tbody + ,@(append-map + (match-lambda + ((name . values) + (let ((common-value (assq-ref values 'common))) + (if common-value + `((tr + (td ,name) + (td ,(display-possible-store-item common-value)))) + (let ((base-value (assq-ref values 'base)) + (target-value (assq-ref values 'target))) + (if (and base-value target-value) + `((tr + (td (@ (rowspan 2)) + ,name) + (td ,base ,(display-possible-store-item + base-value))) + (tr + (td ,target ,(display-possible-store-item + target-value)))) + `((tr + (td ,name) + (td ,@(if base-value + (list base + (display-possible-store-item + base-value)) + (list target + (display-possible-store-item + target-value)))))))))))) + environment-variables)))))))))) (define* (compare/package-derivations query-parameters mode diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 0841ae1..5fe9c1d 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -347,13 +347,11 @@ (for-each (match-lambda ((stat . value) - (and=> (assq-ref resource-pool-metrics stat) - (lambda (metric) - (metric-set - metric - value - #:label-values - `((pool_name . ,name))))))) + (metric-set + (assq-ref resource-pool-metrics stat) + value + #:label-values + `((pool_name . ,name))))) (with-exception-handler (lambda (exn) (simple-format @@ -498,8 +496,7 @@ (render-html #:sxml (general-not-found "Derivation not found" - "Derivations can differ, but produce the same outputs, so try querying by -output, rather than derivation file name.") + "No derivation found with this file name.") #:code 404)))) (define (render-json-derivation derivation-file-name) diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index a64d314..9adb25f 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -933,94 +933,87 @@ (define has-replacement? (assq-ref query-parameters 'has_replacement)) - (fibers-let - ((metadata - (with-resource-from-pool (connection-pool) conn - (select-package-metadata-by-revision-name-and-version - conn - commit-hash - name - version - locale - #:replacement? has-replacement?))) - (derivations - (with-resource-from-pool (connection-pool) conn - (map - (lambda (derivation-details) - (append - derivation-details - (list + (fibers-let ((metadata + (with-resource-from-pool (connection-pool) conn + (select-package-metadata-by-revision-name-and-version + conn + commit-hash + name + version + locale + #:replacement? has-replacement?))) + (derivations + (with-resource-from-pool (connection-pool) conn (map - (match-lambda - ((name path hash-algorithm hash recursive?) - `((name . ,name) - (path . ,path) - (hash_algorithm . ,hash-algorithm) - (hash . ,hash) - (recursive? . ,recursive?) - (nars - . ,(list->vector - (map (match-lambda - ((hash-algorithm hash size - urls signatures) - `((hash . ((algorithm . ,hash-algorithm) - (value . ,hash))) - (size . ,size)))) - (select-nars-for-output - conn - path))))))) - (select-derivation-outputs-by-derivation-file-name + (lambda (derivation-details) + (append + derivation-details + (list + (map + (match-lambda + ((name path hash-algorithm hash recursive?) + `((name . ,name) + (path . ,path) + (hash_algorithm . ,hash-algorithm) + (hash . ,hash) + (recursive? . ,recursive?) + (nars + . ,(list->vector + (map (match-lambda + ((hash-algorithm hash size + urls signatures) + `((hash . ((algorithm . ,hash-algorithm) + (value . ,hash))) + (size . ,size)))) + (select-nars-for-output + conn + path))))))) + (select-derivation-outputs-by-derivation-file-name + conn + (third derivation-details)))))) + (select-derivations-by-revision-name-and-version conn - (third derivation-details)))))) - (select-derivations-by-revision-name-and-version - conn - commit-hash - name - version)))) - (git-repositories - (with-resource-from-pool (connection-pool) conn - (git-repositories-containing-commit conn - commit-hash))) - (lint-warnings - (with-resource-from-pool (connection-pool) conn - (select-lint-warnings-by-revision-package-name-and-version - conn - commit-hash - name - version - #:locale locale)))) + commit-hash + name + version)))) + (git-repositories + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit conn + commit-hash))) + (lint-warnings + (with-resource-from-pool (connection-pool) conn + (select-lint-warnings-by-revision-package-name-and-version + conn + commit-hash + name + version + #:locale locale)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) ((application/json) - (if (null? metadata) - (render-json - `((name . ,name) - (version . ,version) - (error . "package not found")) - #:code 404) - (render-json - `((name . ,name) - (version . ,version) - ,@(match metadata - (((synopsis synopsis-locale description description-locale home-page file line column-number - licenses)) - `((synopsis . ,(texinfo->variants-alist synopsis synopsis-locale)) - (description . ,(texinfo->variants-alist description description-locale)) - (location - . ((file . ,file) - (line . ,line) - (column . ,column-number))) - (home-page . ,home-page)))) - (derivations . ,(list->vector - (map (match-lambda - ((system target file-name status outputs) - `((system . ,system) - (target . ,target) - (derivation . ,file-name) - (outputs . ,(list->vector outputs))))) - derivations)))) - #:extra-headers http-headers-for-unchanging-content))) + (render-json + `((name . ,name) + (version . ,version) + ,@(match metadata + (((synopsis synopsis-locale description description-locale home-page file line column-number + licenses)) + `((synopsis . ,(texinfo->variants-alist synopsis synopsis-locale)) + (description . ,(texinfo->variants-alist description description-locale)) + (location + . ((file . ,file) + (line . ,line) + (column . ,column-number))) + (home-page . ,home-page)))) + (derivations . ,(list->vector + (map (match-lambda + ((system target file-name status outputs) + `((system . ,system) + (target . ,target) + (derivation . ,file-name) + (outputs . ,(list->vector outputs))))) + derivations)))) + #:extra-headers http-headers-for-unchanging-content)) (else (render-html #:sxml (view-revision-package-and-version commit-hash @@ -1036,9 +1029,6 @@ #:header-link header-link #:version-history-link version-history-link) - #:code (if (null? metadata) - 404 - 200) #:extra-headers http-headers-for-unchanging-content))))) (define* (render-revision-package-derivations mime-types diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm index 45d1fc5..04133ad 100644 --- a/guix-data-service/web/revision/html.scm +++ b/guix-data-service/web/revision/html.scm @@ -243,8 +243,6 @@ (div (@ (class "col-sm-12")) ,(match package-metadata - (() - "Package not found at this version") (((synopsis synopsis-locale description description-locale home-page file line column-number licenses)) `(dl diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm index e453643..b1075a0 100644 --- a/guix-data-service/web/server.scm +++ b/guix-data-service/web/server.scm @@ -325,8 +325,8 @@ port. Also, the port used can be changed by passing the --port option.\n" (or (resource-pool-timeout-error? exn) (resource-pool-too-many-waiters-error? exn)))) (case (most-appropriate-mime-type - '(text/html application/json) - mime-types) + mime-types + '(text/html application/json)) ((application/json) (apply values diff --git a/guix-data-service/web/util.scm b/guix-data-service/web/util.scm index 79ca69a..6c0caa7 100644 --- a/guix-data-service/web/util.scm +++ b/guix-data-service/web/util.scm @@ -33,8 +33,8 @@ uri-encode-filename)) -(define (most-appropriate-mime-type supported-mime-types - accepted-mime-types) +(define (most-appropriate-mime-type accepted-mime-types + supported-mime-types) (or ;; Pick the first supported mime-type (find (lambda (accepted-mime-type) diff --git a/guix-dev.scm b/guix-dev.scm index 856706d..57c9c55 100644 --- a/guix-dev.scm +++ b/guix-dev.scm @@ -44,6 +44,39 @@ (gnu packages ruby) (srfi srfi-1)) +(define guile-knots + (let ((commit "d18b5b8d5de5beff3b9f84cfb359b73a4dcf2070") + (revision "1")) + (package + (name "guile-knots") + (version (git-version "0" revision commit)) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://git.cbaines.net/git/guile/knots") + (commit commit))) + (sha256 + (base32 + "0ygf0m6y6mf53pgq5i7agv4a54fkml2akg3ws55jj79v5ndy3lnb")) + (file-name (string-append name "-" version "-checkout")))) + (build-system gnu-build-system) + (native-inputs + (list pkg-config + autoconf + automake + guile-next + guile-lib + guile-fibers-next)) + (inputs + (list guile-next)) + (propagated-inputs + (list guile-fibers-next)) + (home-page "https://git.cbaines.net/guile/knots") + (synopsis "Patterns and functionality to use with Guile Fibers") + (description + "") + (license license:gpl3+)))) + (package (name "guix-data-service") (version "0.0.0")