123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441 |
- (define-module (guix store database)
- #:use-module (sqlite3)
- #:use-module (guix config)
- #:use-module (guix serialization)
- #: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)
- #:use-module (system foreign)
- #:export (sql-schema
- %default-database-file
- store-database-file
- call-with-database
- with-database
- path-id
- sqlite-register
- register-items
- %epoch
- reset-timestamps))
- (define sql-schema
-
- (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."
-
-
-
-
-
- (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)))
-
- (when wal-mode?
-
-
- (sqlite-exec db "PRAGMA journal_mode=WAL;"))
-
-
-
- (sqlite-exec db "PRAGMA busy_timeout = 30000;")
- (dynamic-wind noop
- (lambda ()
- (when new?
- (initialize-database db))
- (proc db))
- (lambda ()
- (sqlite-close db)))))
- (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."
- (define (exec sql)
- (with-statement db sql stmt
- (sqlite-fold cons '() stmt)))
-
-
-
-
-
- (exec (if restartable? "begin;" "begin immediate;"))
- (catch #t
- (lambda ()
- (let-values ((result (proc)))
- (exec "commit;")
- (apply values result)))
- (lambda args
-
-
-
- (false-if-exception (exec "rollback;"))
- (apply throw args))))
- (define* (call-with-savepoint db proc
- #:optional (savepoint-name "SomeSavepoint"))
- "Call PROC after creating a savepoint named SAVEPOINT-NAME. If PROC exits
- abnormally, rollback to that savepoint. In all cases, remove the savepoint
- prior to returning."
- (define (exec sql)
- (with-statement db sql stmt
- (sqlite-fold cons '() stmt)))
- (dynamic-wind
- (lambda ()
- (exec (string-append "SAVEPOINT " savepoint-name ";")))
- (lambda ()
- (catch #t
- proc
- (lambda args
- (exec (string-append "ROLLBACK TO " savepoint-name ";"))
- (apply throw args))))
- (lambda ()
- (exec (string-append "RELEASE " savepoint-name ";")))))
- (define* (call-with-retrying-transaction db proc #:key restartable?)
- (call-with-SQLITE_BUSY-retrying
- (lambda ()
- (call-with-transaction db proc #:restartable? restartable?))))
- (define* (call-with-retrying-savepoint db proc
- #:optional (savepoint-name
- "SomeSavepoint"))
- (call-with-SQLITE_BUSY-retrying
- (lambda ()
- (call-with-savepoint db proc savepoint-name))))
- (define %default-database-file
-
- (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 (call-with-statement db sql proc)
- (let ((stmt (sqlite-prepare db sql #:cache? #t)))
- (dynamic-wind
- (const #t)
- (lambda ()
- (proc stmt))
- (lambda ()
- (sqlite-finalize stmt)))))
- (define-syntax-rule (with-statement db sql stmt exp ...)
- "Run EXP... with STMT bound to a prepared statement corresponding to the sql
- string SQL for DB."
- (call-with-statement db sql
- (lambda (stmt) exp ...)))
- (define (last-insert-row-id db)
-
-
- (with-statement db "SELECT last_insert_rowid();" stmt
- (match (sqlite-fold cons '() stmt)
- ((#(id)) id)
- (_ #f))))
- (define path-id-sql
- "SELECT id FROM ValidPaths WHERE path = :path")
- (define* (path-id db path)
- "If PATH exists in the 'ValidPaths' table, return its numerical
- identifier. Otherwise, return #f."
- (with-statement db path-id-sql stmt
- (sqlite-bind-arguments stmt #:path path)
- (match (sqlite-fold cons '() stmt)
- ((#(id) . _) id)
- (_ #f))))
- (define update-sql
- "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver =
- :deriver, narSize = :size WHERE id = :id")
- (define insert-sql
- "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
- VALUES (:path, :hash, :time, :deriver, :size)")
- (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* (update-or-insert db #:key path deriver hash nar-size time)
- "The classic update-if-exists and insert-if-doesn't feature that sqlite
- doesn't exactly have... they've got something close, but it involves deleting
- and re-inserting instead of updating, which causes problems with foreign keys,
- of course. Returns the row id of the row that was modified or inserted."
-
- (assert-integer "update-or-insert" positive? #:nar-size nar-size)
- (assert-integer "update-or-insert" (cut >= <> 0) #:time time)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- (call-with-savepoint db
- (lambda ()
- (let ((id (path-id db path)))
- (if id
- (with-statement db update-sql stmt
- (sqlite-bind-arguments stmt #:id id
- #:deriver deriver
- #:hash hash #:size nar-size #:time time)
- (sqlite-fold cons '() stmt))
- (with-statement db insert-sql stmt
- (sqlite-bind-arguments stmt
- #:path path #:deriver deriver
- #:hash hash #:size nar-size #:time time)
- (sqlite-fold cons '() stmt)))
- (last-insert-row-id db)))))
- (define add-reference-sql
- "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);")
- (define (add-references db referrer references)
- "REFERRER is the id of the referring store item, REFERENCES is a list
- ids of items referred to."
- (with-statement db add-reference-sql stmt
- (for-each (lambda (reference)
- (sqlite-reset stmt)
- (sqlite-bind-arguments stmt #:referrer referrer
- #:reference reference)
- (sqlite-fold cons '() 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* (sqlite-register 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."
- (let ((id (update-or-insert db #:path path
- #:deriver deriver
- #:hash hash
- #:nar-size nar-size
- #:time (time-second time))))
-
-
- (add-references db id
- (map (cut path-id db <>) references))))
- (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."
-
-
- (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
-
- (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 <store-info> 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)))
-
-
-
-
-
-
- (store-info-item item)))
- (define real-file-name
- (string-append store-dir "/" (basename (store-info-item item))))
-
-
-
- (unless (path-id db to-register)
- (let-values (((hash nar-size) (nar-sha256 real-file-name)))
- (call-with-retrying-transaction db
- (lambda ()
- (sqlite-register 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)))))
|