;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (guix extensions index) #:use-module (guix config) ;; %guix-package-name, ... #:use-module (guix ui) ;; display G_ #:use-module (guix scripts) #:use-module (sqlite3) #:use-module (ice-9 match) #:use-module (guix describe) #:use-module (guix store) #:use-module (guix monads) #:autoload (guix combinators) (fold2) #:autoload (guix grafts) (%graft?) #:autoload (guix store roots) (gc-roots) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix sets) #:use-module ((guix utils) #:select (cache-directory)) #:autoload (guix build utils) (find-files) #:autoload (gnu packages) (fold-packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-71) #:export (guix-index)) (define debug #f) (define schema " create table if not exists Packages ( id integer primary key autoincrement not null, name text not null, version text not null, unique (name, version) -- add uniqueness constraint ); create table if not exists Directories ( id integer primary key autoincrement not null, name text not null, package integer not null, foreign key (package) references Packages(id) on delete cascade, unique (name, package) -- add uniqueness constraint ); create table if not exists Files ( name text not null, basename text not null, directory integer not null, foreign key (directory) references Directories(id) on delete cascade unique (name, basename, directory) -- add uniqueness constraint ); create index if not exists IndexFiles on Files(basename);") (define (call-with-database file proc) (let ((db (sqlite-open file))) (dynamic-wind (lambda () #t) (lambda () (sqlite-exec db schema) (proc db)) (lambda () (sqlite-close db))))) (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 "\ SELECT id FROM Directories WHERE name = :name AND package = :package;" #:cache? #t)) (define stmt-insert-directory (sqlite-prepare db "\ INSERT OR IGNORE INTO Directories(name, package) -- to avoid spurious writes VALUES (:name, :package);" #:cache? #t)) (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;")) (define (insert-package db package) "Insert all the files of PACKAGE into DB." (mlet %store-monad ((drv (package->derivation package #:graft? #f))) (match (derivation->output-paths drv) (((labels . directories) ...) (when (every file-exists? directories) (insert-files db (package-name package) (package-version package) directories)) (return #t))))) (define (filter-public-current-supported package) "Filter supported, not hidden (public) and not superseded (current) package." (and (not (hidden-package? package)) (not (package-superseded package)) (supported-package? package))) (define (filter-supported-package package) "Filter supported package (package might be hidden or superseded)." (and (supported-package? package))) (define (no-filter package) "No filtering on package" #t) (define* (insert-packages db #:optional (filter-policy filter-public-current-supported)) "Insert all current packages matching `filter-package-policy` into DB." (with-store store (parameterize ((%graft? #f)) (fold-packages (lambda (package _) (run-with-store store (insert-package db package))) #t #:select? filter-policy)))) ;;; ;;; Indexing from local profiles. ;;; (define (all-profiles) "Return the list of profiles on the system." (delete-duplicates (filter-map (lambda (root) (if (file-exists? (string-append root "/manifest")) root (let ((root (string-append root "/profile"))) (and (file-exists? (string-append root "/manifest")) root)))) (gc-roots)))) (define (profiles->manifest-entries profiles) "Return manifest entries for all of PROFILES, without duplicates." (let loop ((visited (set)) (profiles profiles) (entries '())) (match profiles (() entries) ((profile . rest) (let* ((manifest (profile-manifest profile)) (entries visited (fold2 (lambda (entry lst visited) (let ((item (manifest-entry-item entry))) (if (set-contains? visited item) (values lst visited) (values (cons entry lst) (set-insert item visited))))) entries visited (manifest-transitive-entries manifest)))) (loop visited rest entries)))))) (define (insert-manifest-entry db entry) "Insert ENTRY, a manifest entry, into DB." (insert-files db (manifest-entry-name entry) (manifest-entry-version entry) (list (manifest-entry-item entry)))) ;FIXME: outputs? (define (index-manifests db-file) "Insert into DB-FILE entries for packages that appear in manifests available on the system." (call-with-database db-file (lambda (db) (for-each (lambda (entry) (insert-manifest-entry db entry)) (let ((lst (profiles->manifest-entries (all-profiles)))) (pk 'entries (length lst)) lst))))) ;;; ;;; Search. ;;; (define-record-type (package-match name version file) package-match? (name package-match-name) (version package-match-version) (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;")) (sqlite-bind-arguments lookup-stmt #:file file) (sqlite-fold (lambda (result lst) (match result (#(package version directory file) (cons (package-match package version (string-append directory "/" file)) lst)))) '() lookup-stmt)) ;;; ;;; CLI ;;; (define (index-packages-with-db db-pathname) "Index packages using db at location DB-PATHNAME." (call-with-database db-pathname (lambda (db) (insert-packages db no-filter)))) (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)))) (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))) matches)) (define default-db-path (string-append (cache-directory #:ensure? #f) "/index/db.sqlite")) (define (show-bug-report-information) ;; TRANSLATORS: The placeholder indicates the bug-reporting address for this ;; package. Please add another line saying "Report translation bugs to ;; ...\n" with the address for translation bugs (typically your translation ;; team's web or email address). (format #t (G_ " Report bugs to: ~a.") %guix-bug-report-address) (format #t (G_ " ~a home page: <~a>") %guix-package-name %guix-home-page-url) (format #t (G_ " General help using Guix and GNU software: <~a>") ;; TRANSLATORS: Change the "/en" bit of this URL appropriately if ;; the web site is translated in your language. (G_ "https://guix.gnu.org/en/help/")) (newline)) (define (show-help) (display (G_ "Usage: guix index [OPTIONS...] [search FILE...] Without argument, indexes (package, file) relationships in the local store. With 'search FILE', search for packages installing FILE.\n Note: The internal cache is located at ~/.cache/guix/index/db.sqlite. See --db-path for customization.\n")) (newline) (display (G_ "The valid values for OPTIONS are:")) (newline) (display (G_ " -h, --help Display this help and exit")) (display (G_ " -V, --version Display version information and exit")) (display (G_ " --db-path=DIR Change default location of the cache db")) (newline) (newline) (display (G_ "The valid values for ARGS are:")) (newline) (display (G_ " search FILE Search for packages installing the FILE (from cache db)")) (newline) (show-bug-report-information)) (define-command (guix-index . args) (category extension) (synopsis "Index packages to allow searching package for a given filename") (define (parse-db-args args) "Parsing of string key=value where we are only interested in 'value'" (match (string-split args #\=) ((unused db-path) db-path) (_ #f))) (define (display-help-and-exit) (show-help) (exit 0)) (match args ((or ("-h") ("--help")) (display-help-and-exit)) ((or ("-V") ("--version")) (show-version-and-exit "guix locate")) ((db-path-args) (let ((db-path (parse-db-args db-path-args))) (if db-path (index-packages-with-db db-path) (display-help-and-exit)))) (("search" file) (let ((matches (matching-packages-with-db default-db-path file))) (print-matching-results matches) (exit (pair? matches)))) ((db-path-args "search" file) (let ((db-path (parse-db-args db-path-args))) (if db-path (let ((matches (matching-packages-with-db db-path file))) (print-matching-results matches) (exit (pair? matches))) (display-help-and-exit)))) (_ ;; By default, index (index-manifests default-db-path))))