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

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

2 files changed, 140 insertions, 119 deletions

diff --git a/guix/store/database.scm b/guix/store/database.scm
index 2ea63b17aa..0a84bbddb9 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -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)
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 0655ceb890..cd9660174c 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -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)))))