From 8799fcfb9f6238abe0e19ce650ee7f1e2b7e0d90 Mon Sep 17 00:00:00 2001 From: "Antoine R. Dumont (@ardumont)" Date: Thu, 22 Dec 2022 15:53:43 +0100 Subject: [PATCH core-updates 3/6] scripts-index: Store outputs alongside packages --- guix/scripts/index.scm | 207 ++++++++++++++++++++++------------------- 1 file changed, 112 insertions(+), 95 deletions(-) diff --git a/guix/scripts/index.scm b/guix/scripts/index.scm index 8d68a63847..d1478042ab 100644 --- a/guix/scripts/index.scm +++ b/guix/scripts/index.scm @@ -50,7 +50,7 @@ (define-module (guix scripts index) (define debug #f) -(define application-version 2) +(define application-version 3) ;; The following schema is the full schema at the `application-version`. It ;; should be modified according to the development required and @@ -70,6 +70,7 @@ (define schema-full id integer primary key autoincrement not null, name text not null, version text not null, + output text, unique (name, version) -- add uniqueness constraint ); @@ -102,6 +103,10 @@ (define schema-to-migrate '((1 . " (2 . " alter table SchemaVersion add column date date; +") + (3 . " +alter table Packages +add column output text; "))) (define (call-with-database file proc) @@ -133,85 +138,90 @@ (define stmt-select-version (sqlite-prepare db "\ ((#(version)) version))) -(define (insert-files db package version directories) - "Insert files from DIRECTORIES as belonging to PACKAGE at VERSION." - (define stmt-select-package - (sqlite-prepare db "\ -SELECT id FROM Packages WHERE name = :name AND version = :version;" - #:cache? #t)) - - (define stmt-insert-package - (sqlite-prepare db "\ -INSERT OR IGNORE INTO Packages(name, version) -- to avoid spurious writes -VALUES (:name, :version);" - #:cache? #t)) - - (define stmt-select-directory - (sqlite-prepare db "\ +(define (insert-files db package version outputs directories) + "Insert DIRECTORIES files belonging to VERSION PACKAGE (with OUTPUTS)." + (define stmt-select-package + (sqlite-prepare db "\ +SELECT id FROM Packages WHERE name = :name AND version = :version LIMIT 1;" + #:cache? #t)) + + (define stmt-insert-package + (sqlite-prepare db "\ +INSERT OR REPLACE INTO Packages(name, version, output) +VALUES (:name, :version, :output);" + #:cache? #t)) + + (define stmt-select-directory + (sqlite-prepare db "\ SELECT id FROM Directories WHERE name = :name AND package = :package;" - #:cache? #t)) + #:cache? #t)) - (define stmt-insert-directory - (sqlite-prepare db "\ + (define stmt-insert-directory + (sqlite-prepare db "\ INSERT OR IGNORE INTO Directories(name, package) -- to avoid spurious writes VALUES (:name, :package);" - #:cache? #t)) + #:cache? #t)) - (define stmt-insert-file - (sqlite-prepare db "\ + (define stmt-insert-file + (sqlite-prepare db "\ INSERT OR IGNORE INTO Files(name, basename, directory) VALUES (:name, :basename, :directory);" - #:cache? #t)) - - (sqlite-exec db "begin immediate;") - (sqlite-bind-arguments stmt-insert-package - #:name package - #:version version) - (sqlite-fold (const #t) #t stmt-insert-package) - - (sqlite-bind-arguments stmt-select-package - #:name package - #:version version) - (match (sqlite-fold cons '() stmt-select-package) - ((#(package-id)) - (when debug - (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)" - package version package-id) - (pk 'package package-id package)) - (for-each (lambda (directory) - (define (strip file) - (string-drop file (+ (string-length directory) 1))) - - (sqlite-reset stmt-insert-directory) - (sqlite-bind-arguments stmt-insert-directory - #:name directory - #:package package-id) - (sqlite-fold (const #t) #t stmt-insert-directory) - - (sqlite-reset stmt-select-directory) - (sqlite-bind-arguments stmt-select-directory - #:name directory - #:package package-id) - (match (sqlite-fold cons '() stmt-select-directory) - ((#(directory-id)) - (when debug - (format #t "(name, package, dir-id): (~a, ~a, ~a)\n" - directory package-id directory-id)) - (for-each (lambda (file) - ;; If DIRECTORY is a symlink, (find-files - ;; DIRECTORY) returns the DIRECTORY singleton. - (unless (string=? file directory) - (sqlite-reset stmt-insert-file) - (sqlite-bind-arguments stmt-insert-file - #:name (strip file) - #:basename - (basename file) - #:directory - directory-id) - (sqlite-fold (const #t) #t stmt-insert-file))) - (find-files directory))))) - directories))) - (sqlite-exec db "commit;")) + #:cache? #t)) + + (sqlite-exec db "begin immediate;") + ;; 1 record per output + (for-each (lambda (output) + (let ((out (if (string=? "out" output) "" output))) + (sqlite-reset stmt-insert-package) + (sqlite-bind-arguments stmt-insert-package + #:name package + #:version version + #:output out) + (sqlite-fold (const #t) #t stmt-insert-package))) + outputs) + (sqlite-bind-arguments stmt-select-package + #:name package + #:version version) + (match (sqlite-fold cons '() stmt-select-package) + ((#(package-id)) + (when debug + (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)" + package version package-id) + (pk 'package package-id package)) + (for-each (lambda (directory) + (define (strip file) + (string-drop file (+ (string-length directory) 1))) + + (sqlite-reset stmt-insert-directory) + (sqlite-bind-arguments stmt-insert-directory + #:name directory + #:package package-id) + (sqlite-fold (const #t) #t stmt-insert-directory) + + (sqlite-reset stmt-select-directory) + (sqlite-bind-arguments stmt-select-directory + #:name directory + #:package package-id) + (match (sqlite-fold cons '() stmt-select-directory) + ((#(directory-id)) + (when debug + (format #t "(name, package, dir-id): (~a, ~a, ~a)\n" + directory package-id directory-id)) + (for-each (lambda (file) + ;; If DIRECTORY is a symlink, (find-files + ;; DIRECTORY) returns the DIRECTORY singleton. + (unless (string=? file directory) + (sqlite-reset stmt-insert-file) + (sqlite-bind-arguments stmt-insert-file + #:name (strip file) + #:basename + (basename file) + #:directory + directory-id) + (sqlite-fold (const #t) #t stmt-insert-file))) + (find-files directory))))) + directories))) + (sqlite-exec db "commit;")) ;;; @@ -224,8 +234,9 @@ (define (insert-package db package) (match (derivation->output-paths drv) (((labels . directories) ...) (when (every file-exists? directories) - (insert-files db (package-name package) (package-version package) - directories)) + (insert-files + db (package-name package) (package-version package) (package-outputs package) + directories)) (return #t))))) (define (insert-packages-with-progress db packages insert-package-fn) @@ -283,6 +294,7 @@ (define (insert-manifest-entry db entry) "Insert a manifest ENTRY into DB." (insert-files db (manifest-entry-name entry) (manifest-entry-version entry) + (list (manifest-entry-output entry)) (list (manifest-entry-item entry)))) ;FIXME: outputs? (define (index-packages-from-manifests-with-db db-pathname) @@ -298,28 +310,29 @@ (define (index-packages-from-manifests-with-db db-pathname) ;;; (define-record-type - (package-match name version file) + (package-match name version output file) package-match? - (name package-match-name) - (version package-match-version) - (file package-match-file)) + (name package-match-name) + (version package-match-version) + (output package-match-output) + (file package-match-file)) (define (matching-packages db file) "Return unique corresponding to packages containing FILE." (define lookup-stmt (sqlite-prepare db "\ -SELECT Packages.name, Packages.version, Directories.name, Files.name -FROM Packages -INNER JOIN Files, Directories -ON files.basename = :file - AND directories.id = files.directory - AND packages.id = directories.package;")) +SELECT p.name, p.version, p.output, d.name, f.name +FROM Packages p +INNER JOIN Files f, Directories d +ON f.basename = :file + AND d.id = f.directory + AND p.id = d.package;")) (sqlite-bind-arguments lookup-stmt #:file file) (sqlite-fold (lambda (result lst) (match result - (#(package version directory file) - (cons (package-match package version + (#(package version output directory file) + (cons (package-match package version output (string-append directory "/" file)) lst)))) '() lookup-stmt)) @@ -346,14 +359,12 @@ (define (insert-package-from-store db package) (not (package-superseded package)) (supported-package? package)))))) (insert-packages-with-progress - db packages insert-package-from-store)))) - (index-packages-from-store db)))) + db packages insert-package-from-store))))))) (define (matching-packages-with-db db-pathname file) "Compute list of packages referencing FILE using db at DB-PATHNAME." (call-with-database db-pathname - (lambda (db) - (matching-packages db file)))) + (lambda (db) (matching-packages db file)))) (define (read-version-from-db db-pathname) (call-with-database db-pathname @@ -387,10 +398,16 @@ (define (migrate-schema-to-version db-pathname) (define (print-matching-results matches) "Print the MATCHES matching results." (for-each (lambda (result) - (format #t "~20a ~a~%" - (string-append (package-match-name result) - "@" (package-match-version result)) - (package-match-file result))) + (let ((name (package-match-name result)) + (version (package-match-version result)) + (output (package-match-output result)) + (file (package-match-file result))) + (format #t "~20a ~a~%" + (string-append name "@" version + (if (string-null? output) + "" + (string-append ":" output))) + file))) matches)) (define default-db-path -- 2.36.1