[jackhill/guix/guix.git] / guix / build / activation.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(define-module (guix build activation)
  #:use-module (guix build utils)
  #:use-module (guix build linux-initrd)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (activate-users+groups
            activate-etc
            activate-setuid-programs
            activate-current-system))

;;; Commentary:
;;;
;;; This module provides "activation" helpers.  Activation is the process that
;;; consists in setting up system-wide files and directories so that an
;;; 'operating-system' configuration becomes active.
;;;
;;; Code:

(define* (add-group name #:key gid password
                    (log-port (current-error-port)))
  "Add NAME as a user group, with the given numeric GID if specified."
  ;; Use 'groupadd' from the Shadow package.
  (format log-port "adding group '~a'...~%" name)
  (let ((args `(,@(if gid `("-g" ,(number->string gid)) '())
                ,@(if password `("-p" ,password) '())
                ,name)))
    (zero? (apply system* "groupadd" args))))

(define* (add-user name group
                   #:key uid comment home shell password
                   (supplementary-groups '())
                   (log-port (current-error-port)))
  "Create an account for user NAME part of GROUP, with the specified
properties.  Return #t on success."
  (format log-port "adding user '~a'...~%" name)

  (if (and uid (zero? uid))

      ;; 'useradd' fails with "Cannot determine your user name" if the root
      ;; account doesn't exist.  Thus, for bootstrapping purposes, create that
      ;; one manually.
      (begin
        (call-with-output-file "/etc/shadow"
          (cut format <> "~a::::::::~%" name))
        (call-with-output-file "/etc/passwd"
          (cut format <> "~a:x:~a:~a:~a:~a:~a~%"
               name "0" "0" comment home shell))
        (chmod "/etc/shadow" #o600)
        #t)

      ;; Use 'useradd' from the Shadow package.
      (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
                    "-g" ,(if (number? group) (number->string group) group)
                    ,@(if (pair? supplementary-groups)
                          `("-G" ,(string-join supplementary-groups ","))
                          '())
                    ,@(if comment `("-c" ,comment) '())
                    ,@(if home
                          (if (file-exists? home)
                              `("-d" ,home)     ; avoid warning from 'useradd'
                              `("-d" ,home "--create-home"))
                          '())
                    ,@(if shell `("-s" ,shell) '())
                    ,@(if password `("-p" ,password) '())
                    ,name)))
        (zero? (apply system* "useradd" args)))))

(define (activate-users+groups users groups)
  "Make sure the accounts listed in USERS and the user groups listed in GROUPS
are all available.

Each item in USERS is a list of all the characteristics of a user account;
each item in GROUPS is a tuple with the group name, group password or #f, and
numeric gid or #f."
  (define (touch file)
    (call-with-output-file file (const #t)))

  (define activate-user
    (match-lambda
     ((name uid group supplementary-groups comment home shell password)
      (unless (false-if-exception (getpwnam name))
        (let ((profile-dir (string-append "/var/guix/profiles/per-user/"
                                          name)))
          (add-user name group
                    #:uid uid
                    #:supplementary-groups supplementary-groups
                    #:comment comment
                    #:home home
                    #:shell shell
                    #:password password)

          ;; Create the profile directory for the new account.
          (let ((pw (getpwnam name)))
            (mkdir-p profile-dir)
            (chown profile-dir (passwd:uid pw) (passwd:gid pw))))))))

  ;; 'groupadd' aborts if the file doesn't already exist.
  (touch "/etc/group")

  ;; Create the root account so we can use 'useradd' and 'groupadd'.
  (activate-user (find (match-lambda
                        ((name (? zero?) _ ...) #t)
                        (_ #f))
                       users))

  ;; Then create the groups.
  (for-each (match-lambda
             ((name password gid)
              (add-group name #:gid gid #:password password)))
            groups)

  ;; Finally create the other user accounts.
  (for-each activate-user users))

(define (activate-etc etc)
  "Install ETC, a directory in the store, as the source of static files for
/etc."

  ;; /etc is a mixture of static and dynamic settings.  Here is where we
  ;; initialize it from the static part.

  (format #t "populating /etc from ~a...~%" etc)
  (let ((rm-f (lambda (f)
                (false-if-exception (delete-file f)))))
    (rm-f "/etc/static")
    (symlink etc "/etc/static")
    (for-each (lambda (file)
                ;; TODO: Handle 'shadow' specially so that changed
                ;; password aren't lost.
                (let ((target (string-append "/etc/" file))
                      (source (string-append "/etc/static/" file)))
                  (rm-f target)
                  (symlink source target)))
              (scandir etc
                       (lambda (file)
                         (not (member file '("." ".."))))

                       ;; The default is 'string-locale<?', but we don't have
                       ;; it when run from the initrd's statically-linked
                       ;; Guile.
                       string<?))

    ;; Prevent ETC from being GC'd.
    (rm-f "/var/guix/gcroots/etc-directory")
    (symlink etc "/var/guix/gcroots/etc-directory")))

(define %setuid-directory
  ;; Place where setuid programs are stored.
  "/run/setuid-programs")

(define (activate-setuid-programs programs)
  "Turn PROGRAMS, a list of file names, into setuid programs stored under
%SETUID-DIRECTORY."
  (define (make-setuid-program prog)
    (let ((target (string-append %setuid-directory
                                 "/" (basename prog))))
      (catch 'system-error
        (lambda ()
          (link prog target))
        (lambda args
          ;; Perhaps PROG and TARGET live in a different file system, so copy
          ;; PROG.
          (copy-file prog target)))
      (chown target 0 0)
      (chmod target #o6555)))

  (format #t "setting up setuid programs in '~a'...~%"
          %setuid-directory)
  (if (file-exists? %setuid-directory)
      (for-each (compose delete-file
                         (cut string-append %setuid-directory "/" <>))
                (scandir %setuid-directory
                         (lambda (file)
                           (not (member file '("." ".."))))
                         string<?))
      (mkdir-p %setuid-directory))

  (for-each make-setuid-program programs))

(define %current-system
  ;; The system that is current (a symlink.)  This is not necessarily the same
  ;; as the system we booted (aka. /run/booted-system) because we can re-build
  ;; a new system configuration and activate it, without rebooting.
  "/run/current-system")

(define (boot-time-system)
  "Return the '--system' argument passed on the kernel command line."
  (find-long-option "--system" (linux-command-line)))

(define* (activate-current-system #:optional (system (boot-time-system)))
  "Atomically make SYSTEM the current system."
  (format #t "making '~a' the current system...~%" system)

  ;; Atomically make SYSTEM current.
  (let ((new (string-append %current-system ".new")))
    (symlink system new)
    (rename-file new %current-system)))

;;; activation.scm ends here
Commit	Line	Data
4dfe6c58 LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (guix build activation)
09e028f4	20	#:use-module (guix build utils)
b4140694	21	#:use-module (guix build linux-initrd)
4dfe6c58	22	#:use-module (ice-9 ftw)
ab6a279a LC	23	#:use-module (ice-9 match)
ab6a279a LC	24	#:use-module (srfi srfi-1)
ad896f23	25	#:use-module (srfi srfi-26)
ab6a279a LC	26	#:export (activate-users+groups
ab6a279a LC	27	activate-etc
b4140694 LC	28	activate-setuid-programs
b4140694 LC	29	activate-current-system))
4dfe6c58 LC	30
	31	;;; Commentary:
	32	;;;
	33	;;; This module provides "activation" helpers. Activation is the process that
	34	;;; consists in setting up system-wide files and directories so that an
	35	;;; 'operating-system' configuration becomes active.
	36	;;;
	37	;;; Code:
	38
ab6a279a LC	39	(define* (add-group name #:key gid password
	40	(log-port (current-error-port)))
	41	"Add NAME as a user group, with the given numeric GID if specified."
	42	;; Use 'groupadd' from the Shadow package.
	43	(format log-port "adding group '~a'...~%" name)
	44	(let ((args `(,@(if gid `("-g" ,(number->string gid)) '())
	45	,@(if password `("-p" ,password) '())
	46	,name)))
	47	(zero? (apply system* "groupadd" args))))
	48
	49	(define* (add-user name group
	50	#:key uid comment home shell password
	51	(supplementary-groups '())
	52	(log-port (current-error-port)))
	53	"Create an account for user NAME part of GROUP, with the specified
	54	properties. Return #t on success."
	55	(format log-port "adding user '~a'...~%" name)
	56
	57	(if (and uid (zero? uid))
	58
	59	;; 'useradd' fails with "Cannot determine your user name" if the root
	60	;; account doesn't exist. Thus, for bootstrapping purposes, create that
	61	;; one manually.
	62	(begin
	63	(call-with-output-file "/etc/shadow"
	64	(cut format <> "~a::::::::~%" name))
	65	(call-with-output-file "/etc/passwd"
	66	(cut format <> "~a:x:~a:~a:~a:~a:~a~%"
	67	name "0" "0" comment home shell))
	68	(chmod "/etc/shadow" #o600)
	69	#t)
	70
	71	;; Use 'useradd' from the Shadow package.
	72	(let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
	73	"-g" ,(if (number? group) (number->string group) group)
	74	,@(if (pair? supplementary-groups)
	75	`("-G" ,(string-join supplementary-groups ","))
	76	'())
	77	,@(if comment `("-c" ,comment) '())
f3b692ac LC	78	,@(if home
	79	(if (file-exists? home)
	80	`("-d" ,home) ; avoid warning from 'useradd'
	81	`("-d" ,home "--create-home"))
	82	'())
ab6a279a LC	83	,@(if shell `("-s" ,shell) '())
	84	,@(if password `("-p" ,password) '())
	85	,name)))
	86	(zero? (apply system* "useradd" args)))))
	87
	88	(define (activate-users+groups users groups)
	89	"Make sure the accounts listed in USERS and the user groups listed in GROUPS
	90	are all available.
	91
	92	Each item in USERS is a list of all the characteristics of a user account;
	93	each item in GROUPS is a tuple with the group name, group password or #f, and
	94	numeric gid or #f."
	95	(define (touch file)
	96	(call-with-output-file file (const #t)))
	97
	98	(define activate-user
	99	(match-lambda
	100	((name uid group supplementary-groups comment home shell password)
	101	(unless (false-if-exception (getpwnam name))
	102	(let ((profile-dir (string-append "/var/guix/profiles/per-user/"
	103	name)))
	104	(add-user name group
	105	#:uid uid
	106	#:supplementary-groups supplementary-groups
	107	#:comment comment
	108	#:home home
	109	#:shell shell
	110	#:password password)
	111
	112	;; Create the profile directory for the new account.
	113	(let ((pw (getpwnam name)))
	114	(mkdir-p profile-dir)
	115	(chown profile-dir (passwd:uid pw) (passwd:gid pw))))))))
	116
	117	;; 'groupadd' aborts if the file doesn't already exist.
	118	(touch "/etc/group")
	119
	120	;; Create the root account so we can use 'useradd' and 'groupadd'.
	121	(activate-user (find (match-lambda
	122	((name (? zero?) _ ...) #t)
	123	(_ #f))
	124	users))
	125
	126	;; Then create the groups.
	127	(for-each (match-lambda
	128	((name password gid)
	129	(add-group name #:gid gid #:password password)))
	130	groups)
	131
	132	;; Finally create the other user accounts.
	133	(for-each activate-user users))
	134
4dfe6c58 LC	135	(define (activate-etc etc)
	136	"Install ETC, a directory in the store, as the source of static files for
	137	/etc."
	138
	139	;; /etc is a mixture of static and dynamic settings. Here is where we
	140	;; initialize it from the static part.
	141
	142	(format #t "populating /etc from ~a...~%" etc)
	143	(let ((rm-f (lambda (f)
	144	(false-if-exception (delete-file f)))))
	145	(rm-f "/etc/static")
	146	(symlink etc "/etc/static")
	147	(for-each (lambda (file)
	148	;; TODO: Handle 'shadow' specially so that changed
	149	;; password aren't lost.
	150	(let ((target (string-append "/etc/" file))
	151	(source (string-append "/etc/static/" file)))
	152	(rm-f target)
	153	(symlink source target)))
	154	(scandir etc
	155	(lambda (file)
	156	(not (member file '("." ".."))))
	157
	158	;; The default is 'string-locale<?', but we don't have
	159	;; it when run from the initrd's statically-linked
	160	;; Guile.
	161	string<?))
	162
	163	;; Prevent ETC from being GC'd.
	164	(rm-f "/var/guix/gcroots/etc-directory")
	165	(symlink etc "/var/guix/gcroots/etc-directory")))
	166
09e028f4 LC	167	(define %setuid-directory
	168	;; Place where setuid programs are stored.
	169	"/run/setuid-programs")
	170
	171	(define (activate-setuid-programs programs)
	172	"Turn PROGRAMS, a list of file names, into setuid programs stored under
	173	%SETUID-DIRECTORY."
	174	(define (make-setuid-program prog)
	175	(let ((target (string-append %setuid-directory
	176	"/" (basename prog))))
	177	(catch 'system-error
	178	(lambda ()
	179	(link prog target))
	180	(lambda args
	181	;; Perhaps PROG and TARGET live in a different file system, so copy
	182	;; PROG.
	183	(copy-file prog target)))
	184	(chown target 0 0)
	185	(chmod target #o6555)))
	186
	187	(format #t "setting up setuid programs in '~a'...~%"
	188	%setuid-directory)
	189	(if (file-exists? %setuid-directory)
ad896f23 LC	190	(for-each (compose delete-file
ad896f23 LC	191	(cut string-append %setuid-directory "/" <>))
09e028f4 LC	192	(scandir %setuid-directory
	193	(lambda (file)
	194	(not (member file '("." ".."))))
	195	string<?))
	196	(mkdir-p %setuid-directory))
	197
	198	(for-each make-setuid-program programs))
	199
b4140694 LC	200	(define %current-system
b4140694 LC	201	;; The system that is current (a symlink.) This is not necessarily the same
484a2b3a LC	202	;; as the system we booted (aka. /run/booted-system) because we can re-build
484a2b3a LC	203	;; a new system configuration and activate it, without rebooting.
b4140694 LC	204	"/run/current-system")
	205
	206	(define (boot-time-system)
	207	"Return the '--system' argument passed on the kernel command line."
	208	(find-long-option "--system" (linux-command-line)))
	209
484a2b3a LC	210	(define* (activate-current-system #:optional (system (boot-time-system)))
484a2b3a LC	211	"Atomically make SYSTEM the current system."
b4140694	212	(format #t "making '~a' the current system...~%" system)
b4140694 LC	213
	214	;; Atomically make SYSTEM current.
	215	(let ((new (string-append %current-system ".new")))
	216	(symlink system new)
	217	(rename-file new %current-system)))
	218
4dfe6c58	219	;;; activation.scm ends here