;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.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 (gnu build activation)
  #:use-module (gnu build linux-boot)
  #:use-module (guix build utils)
  #:use-module (ice-9 ftw)
  #:use-m</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=21890aad50acc65bc29c3310036d1b1d273c0250'>refs</a><a href='/guix/log/bootstrap'>log</a><a href='/guix/tree/bootstrap?id=21890aad50acc65bc29c3310036d1b1d273c0250'>tree</a><a class='active' href='/guix/commit/bootstrap?id=21890aad50acc65bc29c3310036d1b1d273c0250'>commit</a><a href='/guix/diff/bootstrap?id=21890aad50acc65bc29c3310036d1b1d273c0250'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/bootstrap'>
<input type='hidden' name='id' value='21890aad50acc65bc29c3310036d1b1d273c0250'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/commit/?id=21890aad50acc65bc29c3310036d1b1d273c0250'>root</a>/<a href='/guix/commit/bootstrap?id=21890aad50acc65bc29c3310036d1b1d273c0250'>bootstrap</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='21890aad50acc65bc29c3310036d1b1d273c0250'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><table summary='commit info' class='commit-info'>
<tr><th>author</th><td>Ricardo Wurmus &lt;rekado@elephly.net&gt;</td><td class='right'>2019-09-02 14:38:31 +0200</td></tr>
<tr><th>committer</th><td>Ricardo Wurmus &lt;rekado@elephly.net&gt;</td><td class='right'>2019-09-02 14:40:56 +0200</td></tr>
<tr><th>commit</th><td colspan='2' class='oid'><a href='/guix/commit/bootstrap?id=21890aad50acc65bc29c3310036d1b1d273c0250'>21890aad50acc65bc29c3310036d1b1d273c0250</a> (<a href='/guix/patch/bootstrap?id=21890aad50acc65bc29c3310036d1b1d273c0250'>patch</a>)</td></tr>
<tr><th>tree</th><td colspan='2' class='oid'><a href='/guix/tree/?id=21890aad50acc65bc29c3310036d1b1d273c0250'>71aa409cd4bec8c94dbe909573fc760bee83f36d</a> /<a href='/guix/tree/bootstrap?id=21890aad50acc65bc29c3310036d1b1d273c0250'>bootstrap</a></td></tr>
<tr><th>parent</th><td colspan='2' class='oid'><a href='/guix/commit/bootstrap?id=a1a7afc06ce62257f15ca6515ac3663094253fcd'>a1a7afc06ce62257f15ca6515ac3663094253fcd</a> (<a href='/guix/diff/bootstrap?id=21890aad50acc65bc29c3310036d1b1d273c0250&amp;id2=a1a7afc06ce62257f15ca6515ac3663094253fcd'>diff</a>)</td></tr><tr><th>download</th><td colspan='2' class='oid'><a href='/guix/snapshot/guix-21890aad50acc65bc29c3310036d1b1d273c0250.tar.gz'>guix-21890aad50acc65bc29c3310036d1b1d273c0250.tar.gz</a><br/><a href='/guix/snapshot/guix-21890aad50acc65bc29c3310036d1b1d273c0250.zip'>guix-21890aad50acc65bc29c3310036d1b1d273c0250.zip</a><br/></td></tr></table>
<div class='commit-subject'>gnu: r-rmarkdown: Update to 1.15.</div><div class='commit-msg'>* gnu/packages/statistics.scm (r-rmarkdown): Update to 1.15.
</div><div class='diffstat-header'><a href='/guix/diff/?id=21890aad50acc65bc29c3310036d1b1d273c0250'>Diffstat</a> (limited to 'bootstrap')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
              ,@(if (and home create-home?)
                          (if (file-exists? home)
                              `("-d" ,home)     ; avoid warning from 'useradd'
                              `("-d" ,home "--create-home"))
                          '())
                    ,@(if shell `("-s" ,shell) '())
                    ,@(if password `("-p" ,password) '())
                    ,@(if system? '("--system") '())
                    ,name)))
        (and (zero? (apply system* "useradd" args))
             (begin
               ;; Since /etc/skel is a link to a directory in the store where
               ;; all files have the writable bit cleared, and since 'useradd'
               ;; preserves permissions when it copies them, explicitly make
               ;; them writable.
               (make-skeletons-writable home)
               #t)))))

(define* (modify-user name group
                      #:key uid comment home create-home?
                      shell password system?
                      (supplementary-groups '())
                      (log-port (current-error-port)))
  "Modify user account NAME to have all the given settings."
  ;; Use 'usermod' 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) '())
                ;; Don't use '--move-home'.
                ,@(if home `("-d" ,home) '())
                ,@(if shell `("-s" ,shell) '())
                ,name)))
    (zero? (apply system* "usermod" args))))

(define* (delete-user name #:key (log-port (current-error-port)))
  "Remove user account NAME.  Return #t on success.  This may fail if NAME is
logged in."
  (format log-port "deleting user '~a'...~%" name)
  (zero? (system* "userdel" name)))

(define* (delete-group name #:key (log-port (current-error-port)))
  "Remove group NAME.  Return #t on success."
  (format log-port "deleting group '~a'...~%" name)
  (zero? (system* "groupdel" name)))

(define* (ensure-user name group
                      #:key uid comment home create-home?
                      shell password system?
                      (supplementary-groups '())
                      (log-port (current-error-port))
                      #:rest rest)
  "Make sure user NAME exists and has the relevant settings."
  (if (false-if-exception (getpwnam name))
      (apply modify-user name group rest)
      (apply add-user name group rest)))

(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)
    (close-port (open-file file "a0b")))

  (define activate-user
    (match-lambda
     ((name uid group supplementary-groups comment home create-home?
       shell password system?)
      (let ((profile-dir (string-append "/var/guix/profiles/per-user/"
                                        name)))
        (ensure-user name group
                     #:uid uid
                     #:system? system?
                     #:supplementary-groups supplementary-groups
                     #:comment comment
                     #:home home

                     ;; Home directories of non-system accounts are created by
                     ;; 'activate-user-home'.
                     #:create-home? (and create-home? system?)

                     #:shell shell
                     #:password password)

        (unless system?
          ;; 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")

  ;; Allow home directories to be created under /var/lib.
  (mkdir-p "/var/lib")

  ;; 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 system?)
              (unless (false-if-exception (getgrnam name))
                (add-group name
                           #:gid gid #:password password
                           #:system? system?))))
            groups)

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

  ;; Finally, delete extra user accounts and groups.
  (for-each delete-user
            (lset-difference string=?
                             (map passwd:name (current-users))
                             (match users
                               (((names . _) ...)
                                names))))
  (for-each delete-group
            (lset-difference string=?
                             (map group:name (current-groups))
                             (match groups
                               (((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?)
       ;; The home directories of system accounts are created during
       ;; activation, not here.
       (unless (or (not home) (not create-home?) system?
                   (directory-exists? home))
         (let* ((pw  (getpwnam name))
                (uid (passwd:uid pw))
                (gid (passwd:gid pw)))
           (mkdir-p home)
           (chown home uid gid)
           (unless system?
             (copy-account-skeletons home
                                     #:uid uid #:gid gid)))))))

  (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."

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

  (define (rm-f file)
    (false-if-exception (delete-file file)))

  (format #t "populating /etc from ~a...~%" etc)
  (mkdir-p "/etc")

  ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink.  This
  ;; symlink, to a target outside of the store, probably doesn't belong in the
  ;; static 'etc' store directory.  However, if it were to be put there,
  ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
  ;; time of activation (e.g. when installing a fresh system), the call to
  ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
  (rm-f "/etc/ssl")
  (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")

  (rm-f "/etc/static")
  (symlink etc "/etc/static")
  (for-each (lambda (file)
              (let ((target (string-append "/etc/" file))
                    (source (string-append "/etc/static/" file)))
                (rm-f target)

                ;; Things such as /etc/sudoers must be regular files, not
                ;; symlinks; furthermore, they could be modified behind our
                ;; back---e.g., with 'visudo'.  Thus, make a copy instead of
                ;; symlinking them.
                (if (file-is-directory? source)
                    (symlink source target)
                    (copy-file source target))

                ;; XXX: Dirty hack to meet sudo's expectations.
                (when (string=? (basename target) "sudoers")
                  (chmod target #o440))))
            (scandir etc (negate dot-or-dot-dot?)

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

(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))))
      (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 (activate-special-files special-files)
  "Install the files listed in SPECIAL-FILES.  Each element of SPECIAL-FILES
is a pair where the first element is the name of the special file and the
second element is the name it should appear at, such as:

  ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
   (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
"
  (define install-special-file
    (match-lambda
      ((target file)
       (let ((pivot (string-append target ".new")))
         (mkdir-p (dirname target))
         (symlink file pivot)
         (rename-file pivot target)))))

  (for-each install-special-file special-files))

(define (activate-modprobe modprobe)
  "Tell the kernel to use MODPROBE to load modules."
  (call-with-output-file "/proc/sys/kernel/modprobe"
    (lambda (port)
      (display modprobe port))))

(define (activate-firmware directory)
  "Tell the kernel to look for device firmware under DIRECTORY.  This
mechanism bypasses udev: it allows Linux to handle firmware loading directly
by itself, without having to resort to a \"user helper\"."
  (call-with-output-file "/sys/module/firmware_class/parameters/path"
    (lambda (port)
      (display directory port))))

(define (activate-ptrace-attach)
  "Allow users to PTRACE_ATTACH their own processes.

This works around a regression introduced in the default \"security\" policy
found in Linux 3.4 onward that prevents users from attaching to their own
processes--see Yama.txt in the Linux source tree for the rationale.  This
sounds like an unacceptable restriction for little or no security
improvement."
  (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
    (when (file-exists? file)
      (call-with-output-file file
        (lambda (port)
          (display 0 port))))))


(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 (or (getenv "GUIX_NEW_SYSTEM")
                                 (boot-time-system))))
  "Atomically make SYSTEM the current system."
  ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
  ;; system reconfigure' to pass the file name of the new 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