;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2019 Caleb Ristvedt ;;; Copyright © 2018, 2020, 2021 Ludovic Courtès ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2022 Efraim Flashner ;;; ;;; 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 store database) #:use-module (sqlite3) #:use-module (guix config) #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix progress) #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (mkdir-p executable-file?)) #:use-module (guix build store-copy) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (rnrs io ports) #:use-module (ice-9 match) #:export (sql-schema %default-database-file store-database-file call-with-database with-database valid-path-id register-valid-path register-items %epoch reset-timestamps vacuum-database)) ;;; Code for working with the store database directly. (define sql-schema ;; Name of the file containing the SQL scheme or #f. (make-parameter #f)) (define* (store-database-directory #:key prefix state-directory) "Return the store database directory, taking PREFIX and STATE-DIRECTORY into account when provided." ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and ;; %store-database-directory already handle the "environment variables / ;; defaults" question, so we only need to choose between what is given and ;; those. (cond (state-directory (string-append state-directory "/db")) (prefix (string-append prefix %localstatedir "/guix/db")) (else %store-database-directory))) (define* (store-database-file #:key prefix state-directory) "Return the store database file name, taking PREFIX and STATE-DIRECTORY into account when provided." (string-append (store-database-directory #:prefix prefix #:state-directory state-directory) "/db.sqlite")) (define (initialize-database db) "Initializing DB, an empty database, by creating all the tables and indexes as specified by SQL-SCHEMA." (define schema (or (sql-schema) (search-path %load-path "guix/store/schema.sql"))) (sqlite-exec db (call-with-input-file schema get-string-all))) (define* (call-with-database file proc #:key (wal-mode? #t)) "Pass PROC a database record corresponding to FILE. If FILE doesn't exist, create it and initialize it as a new database. Unless WAL-MODE? is set to #f, set journal_mode=WAL." (let ((new? (and (not (file-exists? file)) (begin (mkdir-p (dirname file)) #t))) (db (sqlite-open file))) ;; Using WAL breaks for the Hurd . (when wal-mode? ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED ;; errors when we have several readers: . (sqlite-exec db "PRAGMA journal_mode=WAL;")) ;; Install a busy handler such that, when the database is locked, sqlite ;; retries until 30 seconds have passed, at which point it gives up and ;; throws SQLITE_BUSY. (sqlite-exec db "PRAGMA busy_timeout = 30000;") (dynamic-wind noop (lambda () (when new? (initialize-database db)) (proc db)) (lambda () (sqlite-close db))))) ;; XXX: missing in guile-sqlite3@0.1.2 (define SQLITE_BUSY 5) (define (call-with-SQLITE_BUSY-retrying thunk) "Call THUNK, retrying as long as it exits abnormally due to SQLITE_BUSY errors." (catch 'sqlite-error thunk (lambda (key who code errmsg) (if (= code SQLITE_BUSY) (call-with-SQLITE_BUSY-retrying thunk) (throw key who code errmsg))))) (define* (call-with-transaction db proc #:key restartable?) "Start a transaction with DB and run PROC. If PROC exits abnormally, abort the transaction, otherwise commit the transaction after it finishes. RESTARTABLE? may be set to a non-#f value when it is safe to run PROC multiple times. This may reduce contention for the database somewhat." ;; We might 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!) might have to be executed again for ;; every retry. (sqlite-exec db (if restartable? "begin;" "begin immediate;")) (catch #t (lambda () (let-values ((result (proc))) (sqlite-exec db "commit;") (apply values result))) (lambda args ;; The roll back may or may not have occurred automatically when the ;; error was generated. If it has occurred, this does nothing but signal ;; an error. If it hasn't occurred, this needs to be done. (false-if-exception (sqlite-exec db "rollback;")) (apply throw args)))) (define* (call-with-retrying-transaction db proc #:key restartable?) (call-with-SQLITE_BUSY-retrying (lambda () (call-with-transaction db proc #:restartable? restartable?)))) (define %default-database-file ;; Default location of the store database. (string-append %store-database-directory "/db.sqlite")) (define-syntax with-database (syntax-rules () "Open DB from FILE and close it when the dynamic extent of EXP... is left. If FILE doesn't exist, create it and initialize it as a new database. Pass #:wal-mode? to call-with-database." ((_ file db #:wal-mode? wal-mode? exp ...) (call-with-database file (lambda (db) exp ...) #:wal-mode? wal-mode?)) ((_ file db exp ...) (call-with-database file (lambda (db) exp ...))))) (define (sqlite-step-and-reset statement) (let ((val (sqlite-step statement))) (sqlite-reset statement) val)) (define (last-insert-row-id db) ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. ;; Work around that. (let ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" #:cache? #t))) (vector-ref (sqlite-step-and-reset stmt) 0))) (define (valid-path-id db path) "If PATH exists in the 'ValidPaths' table, return its numerical identifier. Otherwise, return #f." (let ((stmt (sqlite-prepare db " SELECT id FROM ValidPaths WHERE path = :path" #:cache? #t))) (sqlite-bind-arguments stmt #:path path) (match (sqlite-step-and-reset stmt) (#(id) id) (#f #f)))) (define-inlinable (assert-integer proc in-range? key number) (unless (integer? number) (throw 'wrong-type-arg proc "Wrong type argument ~A: ~S" (list key number) (list number))) (unless (in-range? number) (throw 'out-of-range proc "Integer ~A out of range: ~S" (list key number) (list number)))) (define (add-references db referrer references) "REFERRER is the id of the referring store item, REFERENCES is a list ids of items referred to." (let ((stmt (sqlite-prepare db " INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference)" #:cache? #t))) (for-each (lambda (reference) (sqlite-bind-arguments stmt #:referrer referrer #:reference reference) (sqlite-step-and-reset stmt)) references))) (define (timestamp) "Return a timestamp, either the current time of SOURCE_DATE_EPOCH." (match (getenv "SOURCE_DATE_EPOCH") (#f (current-time time-utc)) ((= string->number seconds) (if seconds (make-time time-utc 0 seconds) (current-time time-utc))))) (define* (register-valid-path db #:key path (references '()) deriver hash nar-size (time (timestamp))) "Registers this stuff in DB. PATH is the store item to register and REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv' that produced PATH, HASH is the base16-encoded Nix sha256 hash of PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after being converted to nar form. TIME is the registration time to be recorded in the database or #f, meaning \"right now\". Every store item in REFERENCES must already be registered." (define registration-time (time-second time)) ;; Make sure NAR-SIZE is valid. (assert-integer "register-valid-path" positive? #:nar-size nar-size) (assert-integer "register-valid-path" (cut >= <> 0) #:time registration-time) (define id (let ((existing-id (valid-path-id db path))) (if existing-id (let ((stmt (sqlite-prepare db " UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver = :deriver, narSize = :size WHERE id = :id" #:cache? #t))) (sqlite-bind-arguments stmt #:id existing-id #:deriver deriver #:hash hash #:size nar-size #:time registration-time) (sqlite-step-and-reset stmt) existing-id) (let ((stmt (sqlite-prepare db " INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) VALUES (:path, :hash, :time, :deriver, :size)" #:cache? #t))) (sqlite-bind-arguments stmt #:path path #:deriver deriver #:hash hash #:size nar-size #:time registration-time) (sqlite-step-and-reset stmt) (last-insert-row-id db))))) ;; Call 'path-id' on each of REFERENCES. This ensures we get a ;; "non-NULL constraint" failure if one of REFERENCES is unregistered. (add-references db id (map (cut valid-path-id db <>) references))) ;;; ;;; High-level interface. ;;; (define* (reset-timestamps file #:key preserve-permissions?) "Reset the modification time on FILE and on all the files it contains, if it's a directory. Canonicalize file permissions unless PRESERVE-PERMISSIONS? is true." ;; Note: We're resetting to one second after the Epoch like 'guix-daemon' ;; has always done. (let loop ((file file) (type (stat:type (lstat file)))) (case type ((directory) (unless preserve-permissions? (chmod file #o555)) (utime file 1 1 0 0) (let ((parent file)) (for-each (match-lambda (("." . _) #f) ((".." . _) #f) ((file . properties) (let ((file (string-append parent "/" file))) (loop file (match (assoc-ref properties 'type) ((or 'unknown #f) (stat:type (lstat file))) (type type)))))) (scandir* parent)))) ((symlink) (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW)) (else (unless preserve-permissions? (chmod file (if (executable-file? file) #o555 #o444))) (utime file 1 1 0 0))))) (define %epoch ;; When it all began. (make-time time-utc 0 1)) (define* (register-items db items #:key prefix (registration-time (timestamp)) (log-port (current-error-port))) "Register all of ITEMS, a list of records as returned by 'read-reference-graph', in DB. ITEMS must be in topological order (with leaves first.) REGISTRATION-TIME must be the registration time to be recorded in the database; #f means \"now\". Write a progress report to LOG-PORT. All of ITEMS must be protected from GC and locked during execution of this, typically by adding them as temp-roots." (define store-dir (if prefix (string-append prefix %storedir) %store-directory)) (define (register db item) (define to-register (if prefix (string-append %storedir "/" (basename (store-info-item item))) ;; note: we assume here that if path is, for example, ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an ;; environment variable has been used to change the store directory ;; to /foo/bar/gnu/store, since otherwise real-path would end up ;; being /gnu/store/thing.txt, which is probably not the right file ;; in this case. (store-info-item item))) (define real-file-name (string-append store-dir "/" (basename (store-info-item item)))) ;; When TO-REGISTER is already registered, skip it. This makes a ;; significant differences when 'register-closures' is called ;; consecutively for overlapping closures such as 'system' and 'bootcfg'. (unless (valid-path-id db to-register) (let-values (((hash nar-size) (nar-sha256 real-file-name))) (call-with-retrying-transaction db (lambda () (register-valid-path db #:path to-register #:references (store-info-references item) #:deriver (store-info-deriver item) #:hash (string-append "sha256:" (bytevector->base16-string hash)) #:nar-size nar-size #:time registration-time)))))) (let* ((prefix (format #f "registering ~a items" (length items))) (progress (progress-reporter/bar (length items) prefix log-port))) (call-with-progress-reporter progress (lambda (report) (for-each (lambda (item) (register db item) (report)) items))))) (define (vacuum-database) (let ((db (sqlite-open (store-database-file)))) (sqlite-exec db "VACUUM;") (sqlite-close db)))