;;; 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 locate) #:use-module (guix scripts) #:use-module (sqlite3) #:use-module (ice-9 match) #:use-module (guix store) #:use-module (guix monads) #:autoload (guix grafts) (%graft?) #:use-module (guix derivations) #:use-module (guix packages) #:autoload (guix build utils) (find-files) #:autoload (gnu packages) (fold-packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:export (guix-locate)) (define schema " create table if not exists Packages ( id integer primary key autoincrement not null, name text not null, version text not null ); 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 ); 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 ); 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 the files contained in DIRECTORIES as belonging to PACKAGE at VERSION." (define last-row-id-stmt (sqlite-prepare db "SELECT last_insert_rowid();" #:cache? #t)) (define package-stmt (sqlite-prepare db "\ INSERT OR REPLACE INTO Packages(name, version) VALUES (:name, :version);" #:cache? #t)) (define directory-stmt (sqlite-prepare db "\ INSERT INTO Directories(name, package) VALUES (:name, :package);" #:cache? #t)) (define file-stmt (sqlite-prepare db "\ INSERT INTO Files(name, basename, directory) VALUES (:name, :basename, :directory);" #:cache? #t)) (sqlite-exec db "begin immediate;") (sqlite-bind-arguments package-stmt #:name package #:version version) (sqlite-fold (const #t) #t package-stmt) (match (sqlite-fold cons '() last-row-id-stmt) ((#(package-id)) (pk 'package package-id package) (for-each (lambda (directory) (define (strip file) (string-drop file (+ (string-length directory) 1))) (sqlite-reset directory-stmt) (sqlite-bind-arguments directory-stmt #:name directory #:package package-id) (sqlite-fold (const #t) #t directory-stmt) (match (sqlite-fold cons '() last-row-id-stmt) ((#(directory-id)) (for-each (lambda (file) ;; If DIRECTORY is a symlink, (find-files ;; DIRECTORY) returns the DIRECTORY singleton. (unless (string=? file directory) (sqlite-reset file-stmt) (sqlite-bind-arguments file-stmt #:name (strip file) #:basename (basename file) #:directory directory-id) (sqlite-fold (const #t) #t file-stmt))) (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 (insert-packages db) "Insert all the current packages into DB." (with-store store (parameterize ((%graft? #f)) (fold-packages (lambda (package _) (run-with-store store (insert-package db package))) #t #:select? (lambda (package) (and (not (hidden-package? package)) (not (package-superseded package)) (supported-package? package))))))) (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 DISTINCT 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)) (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)))) (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)) ;; TODO: Determine the current guile/guix mechanism to provide configuration ;; for this (define default-location-db-path "/tmp/db") (define-command (guix-locate . args) (category extension) (synopsis "Index packages then search what package declares a given file") (match args (("index") (index-packages-with-db default-location-db-path)) (("search" file) (let ((matches (matching-packages-with-db default-location-db-path file))) (print-matching-results matches) (exit (pair? matches)))) (_ (format (current-error-port) "usage: guix locate [index|search] args ...~% ~a" args) (exit 1))))