Merge branch 'master' into core-updates

2 files changed, 39 insertions, 13 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 756a6872bb..d36eeafe47 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (activate-users+groups
+            activate-user-home
             activate-etc
             activate-setuid-programs
             activate-/bin/sh
@@ -215,7 +216,7 @@ numeric gid or #f."
                      #:supplementary-groups supplementary-groups
                      #:comment comment
                      #:home home
-                     #:create-home? create-home?
+                     #:create-home? (and create-home? system?)
                      #:shell shell
                      #:password password)
 
@@ -263,6 +264,20 @@ numeric gid or #f."
                                (((names . _) ...)
                                 names)))))
 
+(define (activate-user-home users)
+  "Create and populate the home directory of USERS, a list of tuples, unless
+they already exist."
+  (define ensure-user-home
+    (match-lambda
+      ((name uid group supplementary-groups comment home create-home?
+             shell password system?)
+       (unless (or (not home) (directory-exists? home))
+         (mkdir-p home)
+         (unless system?
+           (copy-account-skeletons home))))))
+
+  (for-each ensure-user-home users))
+
 (define (activate-etc etc)
   "Install ETC, a directory in the store, as the source of static files for
 /etc."
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 6e5c6aaf15..f8ab95370c 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -72,22 +72,33 @@
   "Bind-mount SOURCE at TARGET."
   (mount source target "" MS_BIND))
 
+(define (seek* fd/port offset whence)
+  "Like 'seek' but return -1 instead of throwing to 'system-error' upon
+EINVAL.  This makes it easier to catch cases like OFFSET being too large for
+FD/PORT."
+  (catch 'system-error
+    (lambda ()
+      (seek fd/port offset whence))
+    (lambda args
+      (if (= EINVAL (system-error-errno args))
+          -1
+          (apply throw args)))))
+
 (define (read-superblock device offset size magic?)
   "Read a superblock of SIZE from OFFSET and DEVICE.  Return the raw
 superblock on success, and #f if no valid superblock was found.  MAGIC?
 takes a bytevector and returns #t when it's a valid superblock."
   (call-with-input-file device
     (lambda (port)
-      (seek port offset SEEK_SET)
-
-      (let ((block (make-bytevector size)))
-        (match (get-bytevector-n! port block 0 (bytevector-length block))
-          ((? eof-object?)
-           #f)
-          ((? number? len)
-           (and (= len (bytevector-length block))
-                (and (magic? block)
-                     block))))))))
+      (and (= offset (seek* port offset SEEK_SET))
+           (let ((block (make-bytevector size)))
+             (match (get-bytevector-n! port block 0 (bytevector-length block))
+               ((? eof-object?)
+                #f)
+               ((? number? len)
+                (and (= len (bytevector-length block))
+                     (and (magic? block)
+                          block)))))))))
 
 (define (sub-bytevector bv start size)
   "Return a copy of the SIZE bytes of BV starting from offset START."