amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'staging' into 'core-updates'.

Browse source 
Conflicts:

	gnu/local.mk
	gnu/packages/cmake.scm
	gnu/packages/curl.scm
	gnu/packages/gl.scm
	gnu/packages/glib.scm
	gnu/packages/guile.scm
	gnu/packages/node.scm
	gnu/packages/openldap.scm
	gnu/packages/package-management.scm
	gnu/packages/python-xyz.scm
	gnu/packages/python.scm
	gnu/packages/tls.scm
	gnu/packages/vpn.scm
	gnu/packages/xorg.scm
This commit is contained in:
Maxim Cournoyer 2021-01-13 23:39:52 -05:00
commit 01f0707207
No known key found for this signature in database
GPG key ID: 1260E46482E63562
407 changed files with 75910 additions and 10423 deletions
Download patch file Download diff file Expand all files Collapse all files

60
guix/store/database.scm
View file

@ -21,7 +21,6 @@
(define-module (guix store database)
#:use-module (sqlite3)
#:use-module (guix config)
#:use-module (guix gexp)
#:use-module (guix serialization)
#:use-module (guix store deduplication)
#:use-module (guix base16)
@ -29,7 +28,6 @@
#:use-module (guix build syscalls)
#:use-module ((guix build utils)
#:select (mkdir-p executable-file?))
#:use-module (guix utils)
#:use-module (guix build store-copy)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@ -41,10 +39,10 @@
#:export (sql-schema
%default-database-file
store-database-file
call-with-database
with-database
path-id
sqlite-register
register-path
register-items
%epoch
reset-timestamps))
@ -325,8 +323,19 @@ ids of items referred to."
(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)
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
@ -339,9 +348,7 @@ Every store item in REFERENCES must already be registered."
#:deriver deriver
#:hash hash
#:nar-size nar-size
#:time (time-second
(or time
(current-time time-utc))))))
#:time (time-second time))))
;; 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
@ -384,44 +391,13 @@ is true."
(chmod file (if (executable-file? file) #o555 #o444)))
(utime file 1 1 0 0)))))
(define* (register-path path
#:key (references '()) deriver prefix
state-directory (deduplicate? #t)
(reset-timestamps? #t)
(schema (sql-schema)))
"Register PATH as a valid store file, with REFERENCES as its list of
references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
given, it must be the name of the directory containing the new store to
initialize; if STATE-DIRECTORY is given, it must be a string containing the
absolute file name to the state directory of the store being initialized.
Return #t on success.
Use with care as it directly modifies the store! This is primarily meant to
be used internally by the daemon's build hook.
PATH must be protected from GC and locked during execution of this, typically
by adding it as a temp-root."
(define db-file
(store-database-file #:prefix prefix
#:state-directory state-directory))
(parameterize ((sql-schema schema))
(with-database db-file db
(register-items db (list (store-info path deriver references))
#:prefix prefix
#:deduplicate? deduplicate?
#:reset-timestamps? reset-timestamps?
#:log-port (%make-void-port "w")))))
(define %epoch
;; When it all began.
(make-time time-utc 0 1))
(define* (register-items db items
#:key prefix
(deduplicate? #t)
(reset-timestamps? #t)
registration-time
(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
@ -454,8 +430,6 @@ typically by adding them as temp-roots."
;; significant differences when 'register-closures' is called
;; consecutively for overlapping closures such as 'system' and 'bootcfg'.
(unless (path-id db to-register)
(when reset-timestamps?
(reset-timestamps real-file-name))
(let-values (((hash nar-size) (nar-sha256 real-file-name)))
(call-with-retrying-transaction db
(lambda ()
@ -466,9 +440,7 @@ typically by adding them as temp-roots."
"sha256:"
(bytevector->base16-string hash))
#:nar-size nar-size
#:time registration-time)))
(when deduplicate?
(deduplicate real-file-name hash #:store store-dir)))))
#:time registration-time))))))
(let* ((prefix (format #f "registering ~a items" (length items)))
(progress (progress-reporter/bar (length items)

199
guix/store/deduplication.scm
View file

@ -26,45 +26,25 @@
#:use-module (guix build syscalls)
#:use-module (guix base32)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (rnrs io ports)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (guix serialization)
#:export (nar-sha256
deduplicate))
;; XXX: This port is used as a workaround on Guile <= 2.2.4 where
;; 'port-position' throws to 'out-of-range' when the offset is great than or
;; equal to 2^32: <https://bugs.gnu.org/32161>.
(define (counting-wrapper-port output-port)
"Return two values: an output port that wraps OUTPUT-PORT, and a thunk to
retrieve the number of bytes written to OUTPUT-PORT."
(let ((byte-count 0))
(values (make-custom-binary-output-port "counting-wrapper"
(lambda (bytes offset count)
(put-bytevector output-port bytes
offset count)
(set! byte-count
(+ byte-count count))
count)
(lambda ()
byte-count)
#f
(lambda ()
(close-port output-port)))
(lambda ()
byte-count))))
deduplicate
dump-file/deduplicate
copy-file/deduplicate))
(define (nar-sha256 file)
"Gives the sha256 hash of a file and the size of the file in nar form."
(let*-values (((port get-hash) (open-sha256-port))
((wrapper get-size) (counting-wrapper-port port)))
(write-file file wrapper)
(force-output wrapper)
(let-values (((port get-hash) (open-sha256-port)))
(write-file file port)
(force-output port)
(let ((hash (get-hash))
(size (get-size)))
(close-port wrapper)
(size (port-position port)))
(close-port port)
(values hash size))))
(define (tempname-in directory)
@ -155,49 +135,118 @@ under STORE."
(define links-directory
(string-append store "/.links"))
(mkdir-p links-directory)
(let loop ((path path)
(type (stat:type (lstat path)))
(hash hash))
(if (eq? 'directory type)
;; Can't hardlink directories, so hardlink their atoms.
(for-each (match-lambda
((file . properties)
(unless (member file '("." ".."))
(let* ((file (string-append path "/" file))
(type (match (assoc-ref properties 'type)
((or 'unknown #f)
(stat:type (lstat file)))
(type type))))
(loop file type
(and (not (eq? 'directory type))
(nar-sha256 file)))))))
(scandir* path))
(let ((link-file (string-append links-directory "/"
(bytevector->nix-base32-string hash))))
(if (file-exists? link-file)
(replace-with-link link-file path
#:swap-directory links-directory
#:store store)
(catch 'system-error
(lambda ()
(link path link-file))
(lambda args
(let ((errno (system-error-errno args)))
(cond ((= errno EEXIST)
;; Someone else put an entry for PATH in
;; LINKS-DIRECTORY before we could. Let's use it.
(replace-with-link path link-file
#:swap-directory
links-directory
#:store store))
((= errno ENOSPC)
;; There's not enough room in the directory index for
;; more entries in .links, but that's fine: we can
;; just stop.
#f)
((= errno EMLINK)
;; PATH has reached the maximum number of links, but
;; that's OK: we just can't deduplicate it more.
#f)
(else (apply throw args)))))))))))
(let loop ((path path)
(type (stat:type (lstat path)))
(hash hash))
(if (eq? 'directory type)
;; Can't hardlink directories, so hardlink their atoms.
(for-each (match-lambda
((file . properties)
(unless (member file '("." ".."))
(let* ((file (string-append path "/" file))
(type (match (assoc-ref properties 'type)
((or 'unknown #f)
(stat:type (lstat file)))
(type type))))
(loop file type
(and (not (eq? 'directory type))
(nar-sha256 file)))))))
(scandir* path))
(let ((link-file (string-append links-directory "/"
(bytevector->nix-base32-string hash))))
(if (file-exists? link-file)
(replace-with-link link-file path
#:swap-directory links-directory
#:store store)
(catch 'system-error
(lambda ()
(link path link-file))
(lambda args
(let ((errno (system-error-errno args)))
(cond ((= errno EEXIST)
;; Someone else put an entry for PATH in
;; LINKS-DIRECTORY before we could. Let's use it.
(replace-with-link path link-file
#:swap-directory
links-directory
#:store store))
((= errno ENOENT)
;; This most likely means that LINKS-DIRECTORY does
;; not exist. Attempt to create it and try again.
(mkdir-p links-directory)
(loop path type hash))
((= errno ENOSPC)
;; There's not enough room in the directory index for
;; more entries in .links, but that's fine: we can
;; just stop.
#f)
((= errno EMLINK)
;; PATH has reached the maximum number of links, but
;; that's OK: we just can't deduplicate it more.
#f)
(else (apply throw args)))))))))))
(define (tee input len output)
"Return a port that reads up to LEN bytes from INPUT and writes them to
OUTPUT as it goes."
(define bytes-read 0)
(define (fail)
;; Reached EOF before we had read LEN bytes from INPUT.
(raise (condition
(&nar-error (port input)
(file (port-filename output))))))
(define (read! bv start count)
;; Read at most LEN bytes in total.
(let ((count (min count (- len bytes-read))))
(let loop ((ret (get-bytevector-n! input bv start count)))
(cond ((eof-object? ret)
(if (= bytes-read len)
0 ; EOF
(fail)))
((and (zero? ret) (> count 0))
;; Do not return zero since zero means EOF, so try again.
(loop (get-bytevector-n! input bv start count)))
(else
(put-bytevector output bv start ret)
(set! bytes-read (+ bytes-read ret))
ret)))))
(make-custom-binary-input-port "tee input port" read! #f #f #f))
(define* (dump-file/deduplicate file input size type
#:key (store (%store-directory)))
"Write SIZE bytes read from INPUT to FILE. TYPE is a symbol, either
'regular or 'executable.
This procedure is suitable as a #:dump-file argument to 'restore-file'. When
used that way, it deduplicates files on the fly as they are restored, thereby
removing the need to a deduplication pass that would re-read all the files
down the road."
(define hash
(call-with-output-file file
(lambda (output)
(let-values (((hash-port get-hash)
(open-hash-port (hash-algorithm sha256))))
(write-file-tree file hash-port
#:file-type+size (lambda (_) (values type size))
#:file-port
(const (tee input size output)))
(close-port hash-port)
(get-hash)))))
(deduplicate file hash #:store store))
(define* (copy-file/deduplicate source target
#:key (store (%store-directory)))
"Like 'copy-file', but additionally deduplicate TARGET in STORE."
(call-with-input-file source
(lambda (input)
(let ((stat (stat input)))
(dump-file/deduplicate target input (stat:size stat)
(if (zero? (logand (stat:mode stat)
#o100))
'regular
'executable)
#:store store)))))