aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service')
-rw-r--r--guix-data-service/comparison.scm83
-rw-r--r--guix-data-service/jobs/load-new-guix-revision.scm72
-rw-r--r--guix-data-service/model/package.scm44
-rw-r--r--guix-data-service/model/utils.scm10
-rw-r--r--guix-data-service/web/compare/controller.scm52
-rw-r--r--guix-data-service/web/compare/html.scm59
-rw-r--r--guix-data-service/web/repository/controller.scm36
-rw-r--r--guix-data-service/web/repository/html.scm154
8 files changed, 506 insertions, 4 deletions
diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index 9aa8863..0c7c208 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -4,8 +4,11 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (squee)
+ #:use-module (guix-data-service model utils)
#:use-module (guix-data-service model derivation)
- #:export (package-data->package-data-vhashes
+ #:export (derivation-differences-data
+
+ package-data->package-data-vhashes
package-differences-data
package-data-vhash->derivations
package-data->names-and-versions
@@ -17,6 +20,84 @@
lint-warning-differences-data))
+(define (group-to-alist process lst)
+ (fold (lambda (element result)
+ (match (process element)
+ ((key . value)
+ (match (assoc key result)
+ ((_ . existing-values)
+ `((,key . ,(cons value existing-values))
+ ,@result))
+ (#f
+ `((,key . (,value))
+ ,@result))))))
+ '()
+ lst))
+
+(define (derivation-differences-data conn
+ base-derivation-file-name
+ target-derivation-file-name)
+ (define base-derivation
+ (select-derivation-by-file-name conn base-derivation-file-name))
+
+ (define target-derivation
+ (select-derivation-by-file-name conn target-derivation-file-name))
+
+ `((inputs
+ . ,(group-to-alist
+ (match-lambda
+ ((file-name output-name groups)
+ (cons (if (eq? (length groups) 2)
+ 'common
+ (first groups))
+ (list file-name output-name))))
+ (derivation-inputs-differences-data conn
+ (string->number
+ (first base-derivation))
+ (string->number
+ (first target-derivation)))))))
+
+(define (derivation-inputs-differences-data conn
+ base-derivation-id
+ target-derivation-id)
+ (define query
+ (string-append
+ "
+SELECT derivations.file_name,
+ derivation_outputs.name,
+ relevant_derivation_inputs.derivation_ids
+FROM derivation_outputs
+INNER JOIN (
+ SELECT derivation_output_id,
+ ARRAY_AGG(derivation_id) AS derivation_ids
+ FROM derivation_inputs
+ WHERE derivation_id IN (" (simple-format #f "~A,~A"
+ base-derivation-id
+ target-derivation-id)
+ ") GROUP BY derivation_output_id
+) AS relevant_derivation_inputs
+ ON derivation_outputs.id = relevant_derivation_inputs.derivation_output_id
+INNER JOIN derivations ON derivation_outputs.derivation_id = derivations.id
+"))
+
+ (map (match-lambda
+ ((derivation_file_name derivation_output_name
+ derivation_ids)
+ (let ((parsed-derivation-ids
+ (map string->number
+ (parse-postgresql-array-string derivation_ids))))
+ (list derivation_file_name
+ derivation_output_name
+ (append (if (memq base-derivation-id
+ parsed-derivation-ids)
+ '(base)
+ '())
+ (if (memq target-derivation-id
+ parsed-derivation-ids)
+ '(target)
+ '()))))))
+ (exec-query conn query)))
+
(define* (package-differences-data conn
base_guix_revision_id
target_guix_revision_id
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 86c3a78..643df0a 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -975,6 +975,75 @@ ORDER BY packages.name, packages.version"
#t)
+(define (update-package-derivations-table conn git-repository-id commit)
+ ;; Lock the table to wait for other transactions to commit before updating
+ ;; the table
+ (exec-query
+ conn
+ "
+LOCK TABLE ONLY package_derivations_by_guix_revision_range
+ IN SHARE ROW EXCLUSIVE MODE")
+
+ (for-each
+ (match-lambda
+ ((branch-name)
+ (log-time
+ (simple-format #f "deleting package derivation entries for ~A" branch-name)
+ (lambda ()
+ (exec-query
+ conn
+ "
+DELETE FROM package_derivations_by_guix_revision_range
+WHERE git_repository_id = $1 AND branch_name = $2"
+ (list git-repository-id
+ branch-name))))
+ (log-time
+ (simple-format #f "inserting package derivation entries for ~A" branch-name)
+ (lambda ()
+ (exec-query
+ conn
+ "
+INSERT INTO package_derivations_by_guix_revision_range
+SELECT DISTINCT
+ $1::integer AS git_repository_id,
+ $2 AS branch_name,
+ packages.name AS package_name,
+ packages.version AS package_version,
+ revision_packages.derivation_id AS derivation_id,
+ revision_packages.system AS system,
+ revision_packages.target AS target,
+ first_value(guix_revisions.id)
+ OVER package_version AS first_guix_revision_id,
+ last_value(guix_revisions.id)
+ OVER package_version AS last_guix_revision_id
+FROM packages
+INNER JOIN (
+ SELECT DISTINCT package_derivations.package_id,
+ package_derivations.derivation_id,
+ package_derivations.system,
+ package_derivations.target,
+ guix_revision_package_derivations.revision_id
+ FROM package_derivations
+ INNER JOIN guix_revision_package_derivations
+ ON package_derivations.id = guix_revision_package_derivations.package_derivation_id
+) AS revision_packages ON packages.id = revision_packages.package_id
+INNER JOIN guix_revisions ON revision_packages.revision_id = guix_revisions.id
+INNER JOIN git_branches ON guix_revisions.commit = git_branches.commit
+WHERE git_branches.name = $2
+WINDOW package_version AS (
+ PARTITION BY packages.name, packages.version, revision_packages.derivation_id
+ ORDER BY git_branches.datetime
+ RANGE BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING
+)
+ORDER BY packages.name, packages.version"
+ (list git-repository-id branch-name))))))
+ (exec-query
+ conn
+ "SELECT name FROM git_branches WHERE commit = $1 AND git_repository_id = $2"
+ (list commit git-repository-id)))
+
+ #t)
+
(define (load-new-guix-revision conn git-repository-id commit)
(let ((store-item
(store-item-for-git-repository-id-and-commit
@@ -983,7 +1052,8 @@ ORDER BY packages.name, packages.version"
(and
(extract-information-from conn git-repository-id
commit store-item)
- (update-package-versions-table conn git-repository-id commit))
+ (update-package-versions-table conn git-repository-id commit)
+ (update-package-derivations-table conn git-repository-id commit))
(begin
(simple-format #t "Failed to generate store item for ~A\n"
commit)
diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm
index c1cd2ae..0253a5a 100644
--- a/guix-data-service/model/package.scm
+++ b/guix-data-service/model/package.scm
@@ -12,7 +12,8 @@
inferior-packages->package-ids
select-package-versions-for-revision
- package-versions-for-branch))
+ package-versions-for-branch
+ package-derivations-for-branch))
(define (select-existing-package-entries package-entries)
(string-append "SELECT id, packages.name, packages.version, "
@@ -236,3 +237,44 @@ ORDER BY first_datetime DESC, package_version DESC"
(number->string git-repository-id)
branch-name)))
+(define (package-derivations-for-branch conn
+ git-repository-id
+ branch-name
+ system
+ target
+ package-name)
+ (exec-query
+ conn
+ "
+SELECT package_version,
+ derivations.file_name,
+ first_guix_revisions.commit AS first_guix_revision_commit,
+ first_git_branches.datetime AS first_datetime,
+ last_guix_revisions.commit AS last_guix_revision_commit,
+ last_git_branches.datetime AS last_datetime
+FROM package_derivations_by_guix_revision_range
+INNER JOIN derivations
+ ON package_derivations_by_guix_revision_range.derivation_id = derivations.id
+INNER JOIN guix_revisions AS first_guix_revisions
+ ON first_guix_revision_id = first_guix_revisions.id
+INNER JOIN git_branches AS first_git_branches
+ ON first_guix_revisions.git_repository_id = first_git_branches.git_repository_id
+ AND first_guix_revisions.commit = first_git_branches.commit
+INNER JOIN guix_revisions AS last_guix_revisions
+ ON last_guix_revision_id = last_guix_revisions.id
+INNER JOIN git_branches AS last_git_branches
+ ON last_guix_revisions.git_repository_id = last_git_branches.git_repository_id
+ AND last_guix_revisions.commit = last_git_branches.commit
+WHERE package_name = $1
+AND package_derivations_by_guix_revision_range.git_repository_id = $2
+AND package_derivations_by_guix_revision_range.branch_name = $3
+AND first_git_branches.name = $3
+AND last_git_branches.name = $3
+AND package_derivations_by_guix_revision_range.system = $4
+AND package_derivations_by_guix_revision_range.target = $5
+ORDER BY first_datetime DESC, package_version DESC"
+ (list package-name
+ (number->string git-repository-id)
+ branch-name
+ system
+ target)))
diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm
index 7798e74..a1cd432 100644
--- a/guix-data-service/model/utils.scm
+++ b/guix-data-service/model/utils.scm
@@ -11,6 +11,7 @@
non-empty-string-or-false
exec-query->vhash
two-lists->vhash
+ parse-postgresql-array-string
deduplicate-strings
group-list-by-first-n-fields
insert-missing-data-and-return-all-ids))
@@ -47,6 +48,15 @@
l1
l2))
+(define (parse-postgresql-array-string s)
+ (if (string=? s "{}")
+ '()
+ (string-split
+ (string-drop-right
+ (string-drop s 1)
+ 1)
+ #\,)))
+
(define (deduplicate-strings strings)
(pair-fold
(lambda (pair result)
diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm
index 381d25b..902b18c 100644
--- a/guix-data-service/web/compare/controller.scm
+++ b/guix-data-service/web/compare/controller.scm
@@ -53,6 +53,13 @@
(make-invalid-query-parameter
s "unknown commit"))))
+(define (parse-derivation conn)
+ (lambda (file-name)
+ (if (select-derivation-by-file-name conn file-name)
+ file-name
+ (make-invalid-query-parameter
+ file-name "unknown derivation"))))
+
(define (compare-controller request
method-and-path-components
mime-types
@@ -79,6 +86,15 @@
(render-compare-by-datetime mime-types
conn
parsed-query-parameters)))
+ (('GET "compare" "derivation")
+ (let* ((parsed-query-parameters
+ (parse-query-parameters
+ request
+ `((base_derivation ,(parse-derivation conn) #:required)
+ (target_derivation ,(parse-derivation conn) #:required)))))
+ (render-compare/derivation mime-types
+ conn
+ parsed-query-parameters)))
(('GET "compare" "derivations")
(let* ((parsed-query-parameters
(parse-query-parameters
@@ -287,6 +303,42 @@
lint-warnings-data)
#:extra-headers http-headers-for-unchanging-content)))))))))
+(define (render-compare/derivation 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/derivation
+ query-parameters
+ '()))))
+
+ (let ((base-derivation (assq-ref query-parameters 'base_derivation))
+ (target-derivation (assq-ref query-parameters 'target_derivation)))
+ (let ((data
+ (derivation-differences-data conn
+ base-derivation
+ target-derivation)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ data
+ #: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/derivations mime-types
conn
query-parameters)
diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm
index 86be5a9..2055a8d 100644
--- a/guix-data-service/web/compare/html.scm
+++ b/guix-data-service/web/compare/html.scm
@@ -22,6 +22,7 @@
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web view html)
#:export (compare
+ compare/derivation
compare/derivations
compare-by-datetime/derivations
compare/packages
@@ -232,6 +233,64 @@
warnings))))))
lint-warnings-data))))))))
+(define (compare/derivation query-parameters data)
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (h1 ,@(let ((base-commit (assq-ref query-parameters 'base_commit))
+ (target-commit (assq-ref query-parameters 'target_commit)))
+ (if (every string? (list base-commit target-commit))
+ `("Comparing "
+ (samp ,(string-take base-commit 8) "…")
+ " and "
+ (samp ,(string-take target-commit 8) "…"))
+ '("Comparing derivations")))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (div
+ (@ (class "well"))
+ (form
+ (@ (method "get")
+ (action "")
+ (class "form-horizontal"))
+ ,(form-horizontal-control
+ "Base derivation" query-parameters
+ #:required? #t
+ #:help-text "The derivation to use as the basis for the comparison."
+ #:font-family "monospace")
+ ,(form-horizontal-control
+ "Target derivation" query-parameters
+ #:required? #t
+ #:help-text "The derivation to compare against the base commit."
+ #:font-family "monospace")
+ (div (@ (class "form-group form-group-lg"))
+ (div (@ (class "col-sm-offset-2 col-sm-10"))
+ (button (@ (type "submit")
+ (class "btn btn-lg btn-primary"))
+ "Update results")))
+ (a (@ (class "btn btn-default btn-lg pull-right")
+ (href ,(let ((query-parameter-string
+ (query-parameters->string query-parameters)))
+ (string-append
+ "/compare/derivation.json"
+ (if (string-null? query-parameter-string)
+ ""
+ (string-append "?" query-parameter-string))))))
+ "View JSON")))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h3 "Foo")
+ ,@(let ((inputs (assq-ref data 'inputs)))
+ (assq-ref inputs 'target))))))))
+
(define (compare/derivations query-parameters
valid-systems
valid-build-statuses
diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm
index 23e3559..cdc89d6 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -111,6 +111,42 @@
branch-name
package-name
package-versions))))))
+ (('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history")
+ (let ((package-derivations
+ (package-derivations-for-branch conn
+ (string->number repository-id)
+ branch-name
+ "x86_64-linux"
+ "x86_64-linux"
+ package-name)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((versions . ,(list->vector
+ (map (match-lambda
+ ((package-version derivation-file-name
+ first-guix-revision-commit
+ first-datetime
+ last-guix-revision-commit
+ last-datetime)
+ `((version . ,package-version)
+ (derivation . ,derivation-file-name)
+ (first_revision
+ . ((commit . ,first-guix-revision-commit)
+ (datetime . ,first-datetime)))
+ (last_revision
+ . ((commit . ,last-guix-revision-commit)
+ (datetime . ,last-datetime))))))
+ package-versions))))))
+ (else
+ (render-html
+ #:sxml (view-branch-package-derivations
+ repository-id
+ branch-name
+ package-name
+ package-derivations))))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
(let ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name)))
diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm
index 43f3df7..129279d 100644
--- a/guix-data-service/web/repository/html.scm
+++ b/guix-data-service/web/repository/html.scm
@@ -23,7 +23,8 @@
#:export (view-git-repository
view-branches
view-branch
- view-branch-package))
+ view-branch-package
+ view-branch-package-derivations))
(define* (view-git-repository git-repository-id
label url cgit-url-base
@@ -277,3 +278,154 @@
(rationalize margin-left 1)
(rationalize width 1)))))))))))
versions-by-revision-range))))))))))
+
+(define (view-branch-package-derivations git-repository-id
+ branch-name
+ package-name
+ derivations-by-revision-range)
+ (define versions-list
+ (pair-fold (match-lambda*
+ (((last) (count result ...))
+ (cons (cons last count)
+ result))
+ (((a b rst ...) (count result ...))
+ (peek a b)
+ (if (string=? a b)
+ (cons (+ 1 count)
+ (cons #f result))
+ (cons 1
+ (cons (cons a count)
+ result)))))
+ '(1)
+ (reverse
+ (map first derivations-by-revision-range))))
+
+ (layout
+ #:body
+ `(,(header)
+ (div
+ (@ (class "container"))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (a (@ (href ,(string-append "/repository/" git-repository-id)))
+ (h3 "Repository"))
+ (a (@ (href ,(string-append "/repository/" git-repository-id
+ "/branch/" branch-name)))
+ (h3 ,(string-append branch-name " branch")))
+ (a (@ (class "btn btn-default btn-lg pull-right")
+ (href ,(string-append
+ "/repository/" git-repository-id
+ "/branch/" branch-name
+ "/package/" package-name
+ ".json")))
+ "View JSON")
+ (h1 (@ (style "white-space: nowrap;"))
+ (samp ,package-name))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-md-12"))
+ (table
+ (@ (class "table")
+ (style "table-layout: fixed;"))
+ (thead
+ (tr
+ (th (@ (class "col-sm-3")) "Version")
+ (th (@ (class "col-sm-5")) "Derivation")
+ (th (@ (class "col-sm-4")) "From")
+ (th (@ (class "col-sm-4")) "To")))
+ (tbody
+ ,@(let* ((times-in-seconds
+ (map (lambda (d)
+ (time-second
+ (date->time-monotonic
+ (string->date d "~Y-~m-~d ~H:~M:~S"))))
+ (append (map fourth derivations-by-revision-range)
+ (map sixth derivations-by-revision-range))))
+ (earliest-date-seconds
+ (apply min
+ times-in-seconds))
+ (latest-date-seconds
+ (apply max
+ times-in-seconds))
+ (min-to-max-seconds
+ (- latest-date-seconds
+ earliest-date-seconds)))
+ (map
+ (match-lambda*
+ ((version-column-entry
+ (package-version derivation-file-name
+ first-guix-revision-commit
+ first-datetime
+ last-guix-revision-commit
+ last-datetime))
+ `((tr
+ (@ (style "border-bottom: 0;"))
+ ,@(match version-column-entry
+ (#f '())
+ ((package-version . rowspan)
+ `((td (@ (rowspan ,(* 2 ; To account for the extra rows
+ rowspan)))
+ ,package-version))))
+ (td
+ (a (@ (href ,derivation-file-name))
+ ,(display-store-item-short derivation-file-name)))
+ (td (a (@ (href ,(string-append
+ "/revision/" first-guix-revision-commit)))
+ ,first-datetime)
+ (br)
+ (a (@ (href ,(string-append
+ "/revision/"
+ first-guix-revision-commit
+ "/package/"
+ package-name "/" package-version)))
+ "(More information)"))
+ (td (a (@ (href ,(string-append
+ "/revision/" last-guix-revision-commit)))
+ ,last-datetime)
+ (br)
+ (a (@ (href ,(string-append
+ "/revision/"
+ last-guix-revision-commit
+ "/package/"
+ package-name "/" package-version)))
+ "(More information)")))
+ (tr
+ (td
+ (@ (colspan 3)
+ (style "border-top: 0; padding-top: 0;"))
+ (div
+ (@
+ (style
+ ,(let* ((start-seconds
+ (time-second
+ (date->time-monotonic
+ (string->date first-datetime
+ "~Y-~m-~d ~H:~M:~S"))))
+ (end-seconds
+ (time-second
+ (date->time-monotonic
+ (string->date last-datetime
+ "~Y-~m-~d ~H:~M:~S"))))
+ (margin-left
+ (min
+ (* (/ (- start-seconds earliest-date-seconds)
+ min-to-max-seconds)
+ 100)
+ 98))
+ (width
+ (max
+ (- (* (/ (- end-seconds earliest-date-seconds)
+ min-to-max-seconds)
+ 100)
+ margin-left)
+ 2)))
+ (simple-format
+ #f
+ "margin-left: ~A%; width: ~A%; height: 10px; background: #DCDCDC;"
+ (rationalize margin-left 1)
+ (rationalize width 1)))))))))))
+ versions-list
+ derivations-by-revision-range))))))))))