cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Compare commits

base: cbaines:0113843a7289ec76da54edb03c62da83a07244da
Branches Tags
cbaines:trunk
cbaines:rework-revision-processing
...
compare: cbaines:72fe3b4e473f07bddf2c268aa5886def8ca4b2de
Branches Tags
cbaines:rework-revision-processing
cbaines:trunk

10 commits
0113843a72 ... 72fe3b4e47

Author SHA1 Message Date
Christopher Baines
72fe3b4e47 Suggest why derivations might not be found 2026-01-03 20:39:27 +00:00
Christopher Baines
f77b6bb318 Remove pg-conn-finish definition 
This is now exported.
 2025-11-26 09:47:30 +00:00
Christopher Baines
0a7873c0d5 Remove the guile-knots package definition from guix-dev.scm 
This is in Guix.
 2025-11-26 09:46:16 +00:00
Christopher Baines
75f62f351f Fix string metric values 2025-11-20 15:43:16 +00:00
Christopher Baines
eb9ec4acd0 Handle unknown resource pool stats 2025-11-20 14:09:40 +00:00
Christopher Baines
9a03cdff18 Handle package versions not being found 2025-11-13 12:45:50 +00:00
Christopher Baines
571ed55c9f Fix indentation 2025-11-13 12:39:31 +00:00
Christopher Baines
0611684b0d Flip the most-appropriate-mime-type arguments 
As all the calls are wrong.
 2025-11-13 12:16:09 +00:00
Christopher Baines
b71214083d Avoid inserting duplicate nars 
The nar_urls table has a unique index, so drop the ON CONFLICT DO NOTHING
bits.
 2025-11-13 12:09:53 +00:00
Christopher Baines
eb75964e76 Handle query parameter errors on the fix derivation page 2025-11-05 08:42:39 +00:00
11 changed files with 369 additions and 382 deletions
Download patch file Download diff file Expand all files Collapse all files

4
guix-data-service/database.scm
View file

@ -48,10 +48,6 @@
NULL? NULL?
exec-query-with-null-handling)) 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 (define %database-metrics-registry
(make-parameter #f)) (make-parameter #f))

46
guix-data-service/metrics.scm
View file

@ -107,25 +107,25 @@ WHERE relname NOT LIKE 'package_derivations_by_guix_revision_range_git_branch_%'
last-vacuum last-autovacuum last-analyze last-autoanalyze last-vacuum last-autovacuum last-analyze last-autoanalyze
vacuum-count autovacuum-count analyze-count autoanalyze-count) vacuum-count autovacuum-count analyze-count autoanalyze-count)
`((name . ,relname) `((name . ,relname)
(seq-scan . ,seq-scan) (seq-scan . ,(string->number seq-scan))
(seq-tup-read . ,seq-tup-read) (seq-tup-read . ,(string->number seq-tup-read))
(idx-scan . ,idx-scan) (idx-scan . ,(string->number idx-scan))
(idx-tup-fetch . ,idx-tup-fetch) (idx-tup-fetch . ,(string->number idx-tup-fetch))
(n-tup-ins . ,n-tup-ins) (n-tup-ins . ,(string->number n-tup-ins))
(n-tup-upd . ,n-tup-upd) (n-tup-upd . ,(string->number n-tup-upd))
(n-tup-del . ,n-tup-del) (n-tup-del . ,(string->number n-tup-del))
(n-tup-hot-upd . ,n-tup-hot-upd) (n-tup-hot-upd . ,(string->number n-tup-hot-upd))
(n-live-tup . ,n-live-tup) (n-live-tup . ,(string->number n-live-tup))
(n-dead-tup . ,n-dead-tup) (n-dead-tup . ,(string->number n-dead-tup))
(n-mod-since-analyze . ,n-mod-since-analyze) (n-mod-since-analyze . ,(string->number n-mod-since-analyze))
(last-vacuum . ,last-vacuum) (last-vacuum . ,(string->number last-vacuum))
(last-autovacuum . ,last-autovacuum) (last-autovacuum . ,(string->number last-autovacuum))
(last-analyze . ,last-analyze) (last-analyze . ,(string->number last-analyze))
(last-autoanalyze . ,last-autoanalyze) (last-autoanalyze . ,(string->number last-autoanalyze))
(vacuum-count . ,vacuum-count) (vacuum-count . ,(string->number vacuum-count))
(autovacuum-count . ,autovacuum-count) (autovacuum-count . ,(string->number autovacuum-count))
(analyze-count . ,analyze-count) (analyze-count . ,(string->number analyze-count))
(autoanalyze-count . ,autoanalyze-count)))) (autoanalyze-count . ,(string->number autoanalyze-count)))))
(exec-query conn query))) (exec-query conn query)))
(define (fetch-pg-stat-user-indexes-metrics conn) (define (fetch-pg-stat-user-indexes-metrics conn)
@ -153,10 +153,10 @@ WHERE pg_stat_user_indexes.schemaname = 'guix_data_service'
`((name . ,indexname) `((name . ,indexname)
(table-name . ,tablename) (table-name . ,tablename)
(tablespace . ,tablespace) (tablespace . ,tablespace)
(idx-scan . ,idx_scan) (idx-scan . ,(string->number idx_scan))
(idx-tup-read . ,idx_tup_read) (idx-tup-read . ,(string->number idx_tup_read))
(idx-tup-fetch . ,idx_tup_fetch) (idx-tup-fetch . ,(string->number idx_tup_fetch))
(bytes . ,size_in_bytes)))) (bytes . ,(string->number size_in_bytes)))))
(exec-query conn query))) (exec-query conn query)))
(define (fetch-pg-stats-metrics conn) (define (fetch-pg-stats-metrics conn)

120
guix-data-service/model/nar.scm
View file

@ -18,6 +18,8 @@
(define-module (guix-data-service model nar) (define-module (guix-data-service model nar)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-43)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (web uri) #:use-module (web uri)
#:use-module (squee) #:use-module (squee)
@ -56,26 +58,36 @@
(or (narinfo-deriver narinfo) NULL))))) (or (narinfo-deriver narinfo) NULL)))))
narinfos)) narinfos))
(let ((nar-ids (let* ((nar-ids
(vector->list new-ids
(insert-missing-data-and-return-all-ids (insert-missing-data-and-return-all-ids
conn conn
"nars" "nars"
'(store_path hash_algorithm hash size system deriver) '(store_path hash_algorithm hash size system deriver)
(list->vector data))))) (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)))
(let ((reference-data (let ((reference-data
(concatenate (concatenate
(map (lambda (nar-id narinfo) (map (match-lambda
(map (lambda (reference) ((nar-id . narinfo)
(simple-format (map (lambda (reference)
#f (simple-format
"(~A, ~A)" #f
nar-id "(~A, ~A)"
(quote-string reference))) nar-id
(narinfo-references narinfo))) (quote-string reference)))
nar-ids (narinfo-references narinfo))))
narinfos)))) new-narinfos))))
(unless (null? reference-data) (unless (null? reference-data)
(exec-query (exec-query
conn conn
@ -83,9 +95,7 @@
" "
INSERT INTO nar_references (nar_id, reference) INSERT INTO nar_references (nar_id, reference)
VALUES " VALUES "
(string-join reference-data ", ") (string-join reference-data ", ")))))
"
ON CONFLICT DO NOTHING"))))
(exec-query (exec-query
conn conn
@ -95,55 +105,51 @@ INSERT INTO nar_urls (nar_id, url, compression, file_size)
VALUES " VALUES "
(string-join (string-join
(concatenate (concatenate
(map (lambda (nar-id narinfo) (map (match-lambda
(map (lambda (uri compression file-size) ((nar-id . narinfo)
(simple-format (map (lambda (uri compression file-size)
#f (simple-format
"(~A, ~A, ~A, ~A)" #f
nar-id "(~A, ~A, ~A, ~A)"
(quote-string nar-id
(uri->string uri)) (quote-string
(quote-string compression) (uri->string uri))
(or file-size "NULL"))) (quote-string compression)
(narinfo-uris narinfo) (or file-size "NULL")))
(narinfo-compressions narinfo) (narinfo-uris narinfo)
(narinfo-file-sizes narinfo))) (narinfo-compressions narinfo)
nar-ids (narinfo-file-sizes narinfo))))
narinfos)) new-narinfos))
", ") ", ")))
"
ON CONFLICT DO NOTHING"))
(for-each (lambda (nar-id narinfo) (for-each (match-lambda
(let ((narinfo-signature-data-id ((nar-id . narinfo)
(narinfo-signature->data-id conn narinfo))) (let ((narinfo-signature-data-id
(narinfo-signature->data-id conn narinfo)))
(exec-query (exec-query
conn conn
(string-append (string-append
" "
INSERT INTO narinfo_signatures (nar_id, narinfo_signature_data_id) INSERT INTO narinfo_signatures (nar_id, narinfo_signature_data_id)
VALUES " VALUES "
(simple-format (simple-format
#f #f
"(~A,~A)" "(~A,~A)"
nar-id nar-id
narinfo-signature-data-id) narinfo-signature-data-id)))
"
ON CONFLICT DO NOTHING"))
(exec-query (exec-query
conn conn
(string-append (string-append
" "
INSERT INTO narinfo_fetch_records (narinfo_signature_data_id, build_server_id) INSERT INTO narinfo_fetch_records (narinfo_signature_data_id, build_server_id)
VALUES ($1, $2)") VALUES ($1, $2)")
(list (number->string narinfo-signature-data-id) (list (number->string narinfo-signature-data-id)
(number->string build-server-id))))) (number->string build-server-id))))))
nar-ids new-narinfos)
narinfos)
nar-ids)) (vector->list nar-ids)))
(define (sexp->json-string sexp) (define (sexp->json-string sexp)
(define (transform x) (define (transform x)

2
guix-data-service/web/compare/controller.scm
View file

@ -628,7 +628,7 @@
(render-html (render-html
#:sxml (compare/derivation #:sxml (compare/derivation
query-parameters query-parameters
'())))) #f))))
(let ((base-derivation (assq-ref query-parameters 'base_derivation)) (let ((base-derivation (assq-ref query-parameters 'base_derivation))
(target-derivation (assq-ref query-parameters 'target_derivation))) (target-derivation (assq-ref query-parameters 'target_derivation)))

361
guix-data-service/web/compare/html.scm
View file

@ -483,191 +483,194 @@
"View JSON"))))) "View JSON")))))
(div (div
(@ (class "row")) (@ (class "row"))
(div ,@(if
(@ (class "col-sm-12")) data
(h2 "Outputs") `((div
,@(let ((outputs (assq-ref data 'outputs))) (@ (class "col-sm-12"))
`((table (h2 "Outputs")
(@ (class "table")) ,@(let ((outputs (assq-ref data 'outputs)))
(thead `((table
(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")) (@ (class "table"))
(thead (thead
(tr (tr
(th "") (th "")
(th "System"))) (th "Name")
(th "Path")
(th "Hash algorithm")
(th "Hash")
(th "Recursive")))
(tbody (tbody
,@(let ((base-system (assq-ref system 'base)) ,@(append-map
(target-system (assq-ref system 'target))) (lambda (label items)
`((tr (map
(td ,base) (lambda (alist)
(td ,base-system)) `(tr
(tr (td ,label)
(td ,target) (td ,(assq-ref alist 'output-name))
(td ,target-system))))))))) (td (a (@ (href ,(assq-ref alist 'path)))
(h2 "Builder and arguments") ,(display-store-item (assq-ref alist 'path))))
,(let ((builder (assq-ref data 'builder)) (td ,(assq-ref alist 'hash-algorithm))
(arguments (assq-ref data 'arguments))) (td ,(assq-ref alist 'hash))
(let ((common-builder (assq-ref builder 'common)) (td ,(assq-ref alist 'recursive))))
(common-args (assq-ref arguments 'common))) (or (and=> items vector->list) '())))
(if (and common-builder (list base target "Common")
common-args) (list (assq-ref outputs 'base)
`(table (assq-ref outputs 'target)
(@ (class "table")) (assq-ref outputs 'common)))))))
(thead (h2 "Inputs")
(th "Builder") ,@(let ((inputs (assq-ref data 'inputs)))
(th "Arguments")) `((table
(tbody (@ (class "table"))
(tr (thead
(td ,(display-possible-store-item common-builder)) (tr
(td (ol (th "")
,@(map (lambda (arg) (th "Derivation")
`(li ,(display-possible-store-item arg))) (th "Outputs")))
common-args)))))) (tbody
`(table ,@(append-map
(@ (class "table")) (lambda (label items)
(thead (map
(tr (lambda (alist)
(th "") `(tr
(th "Builder") (td ,label)
(th "Arguments"))) (td (a (@ (href ,(assq-ref alist 'derivation_file_name)))
(tbody ,(display-store-item (assq-ref alist 'derivation_file_name))))
,@(let ((base-builder (assq-ref builder 'base)) (td ,(assq-ref alist 'derivation_output_name))))
(target-builder (assq-ref builder 'target)) (or (and=> items vector->list) '())))
(base-args (assq-ref arguments 'base)) (list base target)
(target-args (assq-ref arguments 'target))) (list (assq-ref inputs 'base)
`((tr (assq-ref inputs 'target)))))))
(td ,base) (p "Common inputs are omitted.")
(td ,(display-possible-store-item (h2 "Sources")
(or base-builder ,@(let ((sources (assq-ref data 'sources)))
common-builder))) `((table
(td (ol (@ (class "table"))
,@(map (lambda (arg) (thead
`(li ,(display-possible-store-item arg))) (tr
(or (and=> common-args vector->list) (th "")
(vector->list base-args)))))) (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 (tr
(td ,target) (th "")
(td ,(display-possible-store-item (th "System")))
(or target-builder (tbody
common-builder))) ,@(let ((base-system (assq-ref system 'base))
(td (ol (target-system (assq-ref system 'target)))
,@(map (lambda (arg) `((tr
`(li ,(display-possible-store-item arg))) (td ,base)
(or (and=> common-args vector->list) (td ,base-system))
(vector->list target-args))))))))))))) (tr
(h2 "Environment variables") (td ,target)
,(let ((environment-variables (assq-ref data 'environment-variables))) (td ,target-system)))))))))
`(table (h2 "Builder and arguments")
(@ (class "table")) ,(let ((builder (assq-ref data 'builder))
(thead (arguments (assq-ref data 'arguments)))
(th "Name")) (let ((common-builder (assq-ref builder 'common))
(tbody (common-args (assq-ref arguments 'common)))
,@(append-map (if (and common-builder
(match-lambda common-args)
((name . values) `(table
(let ((common-value (assq-ref values 'common))) (@ (class "table"))
(if common-value (thead
`((tr (th "Builder")
(td ,name) (th "Arguments"))
(td ,(display-possible-store-item common-value)))) (tbody
(let ((base-value (assq-ref values 'base)) (tr
(target-value (assq-ref values 'target))) (td ,(display-possible-store-item common-builder))
(if (and base-value target-value) (td (ol
`((tr ,@(map (lambda (arg)
(td (@ (rowspan 2)) `(li ,(display-possible-store-item arg)))
,name) common-args))))))
(td ,base ,(display-possible-store-item `(table
base-value))) (@ (class "table"))
(tr (thead
(td ,target ,(display-possible-store-item (tr
target-value)))) (th "")
`((tr (th "Builder")
(td ,name) (th "Arguments")))
(td ,@(if base-value (tbody
(list base ,@(let ((base-builder (assq-ref builder 'base))
(display-possible-store-item (target-builder (assq-ref builder 'target))
base-value)) (base-args (assq-ref arguments 'base))
(list target (target-args (assq-ref arguments 'target)))
(display-possible-store-item `((tr
target-value)))))))))))) (td ,base)
environment-variables)))))))))) (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))))))
'()))))))
(define* (compare/package-derivations query-parameters (define* (compare/package-derivations query-parameters
mode mode

15
guix-data-service/web/controller.scm
View file

@ -347,11 +347,13 @@
(for-each (for-each
(match-lambda (match-lambda
((stat . value) ((stat . value)
(metric-set (and=> (assq-ref resource-pool-metrics stat)
(assq-ref resource-pool-metrics stat) (lambda (metric)
value (metric-set
#:label-values metric
`((pool_name . ,name))))) value
#:label-values
`((pool_name . ,name)))))))
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format (simple-format
@ -496,7 +498,8 @@
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Derivation not found" "Derivation not found"
"No derivation found with this file name.") "Derivations can differ, but produce the same outputs, so try querying by
output, rather than derivation file name.")
#:code 404)))) #:code 404))))
(define (render-json-derivation derivation-file-name) (define (render-json-derivation derivation-file-name)

160
guix-data-service/web/revision/controller.scm
View file

@ -933,87 +933,94 @@
(define has-replacement? (assq-ref query-parameters 'has_replacement)) (define has-replacement? (assq-ref query-parameters 'has_replacement))
(fibers-let ((metadata (fibers-let
(with-resource-from-pool (connection-pool) conn ((metadata
(select-package-metadata-by-revision-name-and-version (with-resource-from-pool (connection-pool) conn
conn (select-package-metadata-by-revision-name-and-version
commit-hash conn
name commit-hash
version name
locale version
#:replacement? has-replacement?))) locale
(derivations #:replacement? has-replacement?)))
(with-resource-from-pool (connection-pool) conn (derivations
(with-resource-from-pool (connection-pool) conn
(map
(lambda (derivation-details)
(append
derivation-details
(list
(map (map
(lambda (derivation-details) (match-lambda
(append ((name path hash-algorithm hash recursive?)
derivation-details `((name . ,name)
(list (path . ,path)
(map (hash_algorithm . ,hash-algorithm)
(match-lambda (hash . ,hash)
((name path hash-algorithm hash recursive?) (recursive? . ,recursive?)
`((name . ,name) (nars
(path . ,path) . ,(list->vector
(hash_algorithm . ,hash-algorithm) (map (match-lambda
(hash . ,hash) ((hash-algorithm hash size
(recursive? . ,recursive?) urls signatures)
(nars `((hash . ((algorithm . ,hash-algorithm)
. ,(list->vector (value . ,hash)))
(map (match-lambda (size . ,size))))
((hash-algorithm hash size (select-nars-for-output
urls signatures) conn
`((hash . ((algorithm . ,hash-algorithm) path)))))))
(value . ,hash))) (select-derivation-outputs-by-derivation-file-name
(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 conn
commit-hash (third derivation-details))))))
name (select-derivations-by-revision-name-and-version
version)))) conn
(git-repositories commit-hash
(with-resource-from-pool (connection-pool) conn name
(git-repositories-containing-commit conn version))))
commit-hash))) (git-repositories
(lint-warnings (with-resource-from-pool (connection-pool) conn
(with-resource-from-pool (connection-pool) conn (git-repositories-containing-commit conn
(select-lint-warnings-by-revision-package-name-and-version commit-hash)))
conn (lint-warnings
commit-hash (with-resource-from-pool (connection-pool) conn
name (select-lint-warnings-by-revision-package-name-and-version
version conn
#:locale locale)))) commit-hash
name
version
#:locale locale))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
((application/json) ((application/json)
(render-json (if (null? metadata)
`((name . ,name) (render-json
(version . ,version) `((name . ,name)
,@(match metadata (version . ,version)
(((synopsis synopsis-locale description description-locale home-page file line column-number (error . "package not found"))
licenses)) #:code 404)
`((synopsis . ,(texinfo->variants-alist synopsis synopsis-locale)) (render-json
(description . ,(texinfo->variants-alist description description-locale)) `((name . ,name)
(location (version . ,version)
. ((file . ,file) ,@(match metadata
(line . ,line) (((synopsis synopsis-locale description description-locale home-page file line column-number
(column . ,column-number))) licenses))
(home-page . ,home-page)))) `((synopsis . ,(texinfo->variants-alist synopsis synopsis-locale))
(derivations . ,(list->vector (description . ,(texinfo->variants-alist description description-locale))
(map (match-lambda (location
((system target file-name status outputs) . ((file . ,file)
`((system . ,system) (line . ,line)
(target . ,target) (column . ,column-number)))
(derivation . ,file-name) (home-page . ,home-page))))
(outputs . ,(list->vector outputs))))) (derivations . ,(list->vector
derivations)))) (map (match-lambda
#:extra-headers http-headers-for-unchanging-content)) ((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 (else
(render-html (render-html
#:sxml (view-revision-package-and-version commit-hash #:sxml (view-revision-package-and-version commit-hash
@ -1029,6 +1036,9 @@
#:header-link header-link #:header-link header-link
#:version-history-link #:version-history-link
version-history-link) version-history-link)
#:code (if (null? metadata)
404
200)
#:extra-headers http-headers-for-unchanging-content))))) #:extra-headers http-headers-for-unchanging-content)))))
(define* (render-revision-package-derivations mime-types (define* (render-revision-package-derivations mime-types

2
guix-data-service/web/revision/html.scm
View file

@ -243,6 +243,8 @@
(div (div
(@ (class "col-sm-12")) (@ (class "col-sm-12"))
,(match package-metadata ,(match package-metadata
(()
"Package not found at this version")
(((synopsis synopsis-locale description description-locale home-page file line column-number (((synopsis synopsis-locale description description-locale home-page file line column-number
licenses)) licenses))
`(dl `(dl

4
guix-data-service/web/server.scm
View file

@ -325,8 +325,8 @@ port. Also, the port used can be changed by passing the --port option.\n"
(or (resource-pool-timeout-error? exn) (or (resource-pool-timeout-error? exn)
(resource-pool-too-many-waiters-error? exn)))) (resource-pool-too-many-waiters-error? exn))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
mime-types '(text/html application/json)
'(text/html application/json)) mime-types)
((application/json) ((application/json)
(apply (apply
values values

4
guix-data-service/web/util.scm
View file

@ -33,8 +33,8 @@
uri-encode-filename)) uri-encode-filename))
(define (most-appropriate-mime-type accepted-mime-types (define (most-appropriate-mime-type supported-mime-types
supported-mime-types) accepted-mime-types)
(or (or
;; Pick the first supported mime-type ;; Pick the first supported mime-type
(find (lambda (accepted-mime-type) (find (lambda (accepted-mime-type)

33
guix-dev.scm
View file

@ -44,39 +44,6 @@
(gnu packages ruby) (gnu packages ruby)
(srfi srfi-1)) (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 (package
(name "guix-data-service") (name "guix-data-service")
(version "0.0.0") (version "0.0.0")