Toggle diff (333 lines)
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index fc13032b73..c123ad3b11 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -264,6 +264,9 @@ interface (FFI) of Guile.")
(scheme-file "git.scm" #~(define-module (git))))
+ (scheme-file "sqlite3.scm" #~(define-module (sqlite3))))
(with-imported-modules `(((guix config)
@@ -278,6 +281,8 @@ interface (FFI) of Guile.")
+ ((sqlite3) => ,fake-sqlite3)
,@(source-module-closure `((guix store)
diff --git a/gnu/packages.scm b/gnu/packages.scm
index d22c992bb1..0ae5b84284 100644
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-39)
@@ -204,10 +205,8 @@ PROC is called along these lines:
PROC can use #:allow-other-keys to ignore the bits it's not interested in.
When a package cache is available, this procedure does not actually load any
- (load-package-cache (current-profile)))
- (if (and cache (cache-is-authoritative?))
+ (if (and (cache-is-authoritative?)
(vhash-fold (lambda (name vector result)
(#(name version module symbol outputs
@@ -220,7 +219,7 @@ package module."
#:deprecated? deprecated?))))
+ (cache-lookup (current-profile)))
(fold-packages (lambda (package result)
(proc (package-name package)
(package-version package)
@@ -252,31 +251,7 @@ is guaranteed to never traverse the same package twice."
(define %package-cache-file
;; Location of the package cache.
- "/lib/guix/package.cache")
-(define load-package-cache
- "Attempt to load the package cache. On success return a vhash keyed by
-package names. Return #f on failure."
- (load-compiled (string-append profile %package-cache-file)))
- (fold (lambda (item vhash)
- (#(name version module symbol outputs
- (vhash-cons name item vhash))))
- (if (= ENOENT (system-error-errno args))
- (apply throw args))))))))
+ "/lib/guix/package-cache.sqlite")
(define find-packages-by-name/direct ;bypass the cache
@@ -297,25 +272,57 @@ decreasing version order."
-(define (cache-lookup cache name)
+(define* (cache-lookup profile #:optional name)
"Lookup package NAME in CACHE. Return a list sorted in increasing version
(define (package-version<? v1 v2)
(version>? (vector-ref v2 1) (vector-ref v1 1)))
- (sort (vhash-fold* cons '() name cache)
+ (define (int->boolean n)
+ (define (string->list str)
+ (call-with-input-string str read))
+ (define select-statement
+ "SELECT name, version, module, symbol, outputs, supported, superseded, locationFile, locationLine, locationColumn from packages"
+ (if name " WHERE name = :name" "")))
+ (string-append profile %package-cache-file))
+ (let* ((db (sqlite-open cache-file SQLITE_OPEN_READONLY))
+ (statement (sqlite-prepare db select-statement)))
+ (sqlite-bind-arguments statement #:name name))
+ (let ((result (sqlite-fold (lambda (v result)
+ (#(name version module symbol outputs supported superseded file line column)
+ (string->symbol symbol)
+ (int->boolean supported)
+ (int->boolean superseded)
+ (list file line column))
+ (sqlite-finalize statement)
+ (sort result package-version<?))))
(define* (find-packages-by-name name #:optional version)
"Return the list of packages with the given NAME. If VERSION is not #f,
then only return packages whose version is prefixed by VERSION, sorted in
decreasing version order."
- (load-package-cache (current-profile)))
- (if (and (cache-is-authoritative?) cache)
- (match (cache-lookup cache name)
+ (if (and (cache-is-authoritative?)
+ (match (cache-lookup (current-profile) name)
((#(_ versions modules symbols _ _ _ _ _ _) ...)
(fold (lambda (version* module symbol result)
@@ -331,12 +338,9 @@ decreasing version order."
(define* (find-package-locations name #:optional version)
"Return a list of version/location pairs corresponding to each package
matching NAME and VERSION."
- (load-package-cache (current-profile)))
- (if (and cache (cache-is-authoritative?))
- (match (cache-lookup cache name)
+ (if (and (cache-is-authoritative?)
+ (match (cache-lookup (current-profile) name)
((#(name versions modules symbols outputs
files lines columns) ...)
@@ -372,6 +376,33 @@ VERSION."
;; Prevent Guile 3 from inlining this procedure so we can mock it in tests.
(set! find-best-packages-by-name find-best-packages-by-name)
+;; (generate-package-cache "/tmp/test")
+;; XXX: missing in guile-sqlite3@0.1.0
+(define (call-with-transaction db proc)
+ "Start a transaction with DB (make as many attempts as necessary) and run
+PROC. If PROC exits abnormally, abort the transaction, otherwise commit the
+transaction after it finishes."
+ ;; We use begin immediate here so that if we need to retry, we
+ ;; figure that out immediately rather than because some SQLITE_BUSY
+ ;; exception gets thrown partway through PROC - in which case the
+ ;; part already executed (which may contain side-effects!) would be
+ ;; executed again for every retry.
+ (sqlite-exec db "begin immediate;")
+ (sqlite-exec db "commit;")
+ (lambda (key who error description)
+ (if (= error SQLITE_BUSY)
+ (call-with-transaction db proc)
+ (sqlite-exec db "rollback;")
+ (throw 'sqlite-error who error description))))))
(define (generate-package-cache directory)
"Generate under DIRECTORY a cache of all the available packages.
@@ -381,49 +412,84 @@ reducing the memory footprint."
(string-append directory %package-cache-file))
- (define (expand-cache module symbol variable result+seen)
+ "CREATE TABLE packages (name text,
+CREATE VIRTUAL TABLE packageSearch USING fts5(name, searchText);")
+ (define insert-statement
+ "INSERT INTO packages(name, version, module, symbol, outputs, supported, superseded, locationFile, locationLine, locationColumn)
+VALUES(:name, :version, :module, :symbol, :outputs, :supported, :superseded, :locationfile, :locationline, :locationcolumn)")
+ (define insert-package-search-statement
+ "INSERT INTO packageSearch(name, searchText) VALUES(:name, :searchtext)")
+ (define (boolean->int x)
+ (define (list->string x)
+ (call-with-output-string (cut write x <>)))
+ (define (insert-package db module symbol variable seen)
(match (false-if-exception (variable-ref variable))
- (if (or (vhash-assq package seen)
- (hidden-package? package))
- (cons (cons `#(,(package-name package)
- ,(package-version package)
- ,(package-outputs package)
- ,(->bool (supported-package? package))
- ,(->bool (package-superseded package))
- ,@(let ((loc (package-location package)))
- ,(location-column loc))
- (vhash-consq package #t seen))))))
- (fold-module-public-variables* expand-cache
- (all-modules (%package-module-path)
- warn-about-load-error))))
+ ((or (vhash-assq package seen)
+ (hidden-package? package))
+ (let ((statement (sqlite-prepare db insert-statement)))
+ (sqlite-bind-arguments statement
+ #:name (package-name package)
+ #:version (package-version package)
+ #:module (list->string (module-name module))
+ #:symbol (symbol->string symbol)
+ #:outputs (list->string (package-outputs package))
+ #:supported (boolean->int (supported-package? package))
+ #:superseded (boolean->int (package-superseded package))
+ ((package-location package) => location-file)
+ ((package-location package) => location-line)
+ ((package-location package) => location-column)
+ (sqlite-fold cons '() statement)
+ (sqlite-finalize statement))
+ (let ((statement (sqlite-prepare db insert-package-search-statement)))
+ (sqlite-bind-arguments statement
+ #:name (package-name package)
+ #:searchtext (package-description package))
+ (sqlite-fold cons '() statement)
+ (sqlite-finalize statement))
+ (vhash-consq package #t seen))))
(mkdir-p (dirname cache-file))
- (call-with-output-file cache-file
- ;; Store the cache as a '.go' file. This makes loading fast and reduces
- ;; heap usage since some of the static data is directly mmapped.
- #:opts '(#:to-file? #t)))))
+ (let ((tmp (string-append (dirname cache-file) "/tmp")))
+ (setenv "SQLITE_TMPDIR" tmp))
+ (let ((db (sqlite-open cache-file)))
+ (sqlite-exec db schema)
+ (call-with-transaction db
+ (fold-module-public-variables* (cut insert-package db <> <> <> <>)
+ (all-modules (%package-module-path)
+ warn-about-load-error))))