build-aux/generate-authors.scm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;;
;;; 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/>.

;;;
;;; Generate AUTHORS file for directory with the Guix git repository.
;;;

(use-modules
 (ice-9 popen)
 (ice-9 rdelim)
 (ice-9 match)
 (srfi srfi-1)
 (guix config)
 (guix utils)
 (guix build utils))

(define %guix-dir
  (make-parameter #f))

(define-syntax-rule (append-maybe init-lst (test add-lst) ...)
  (let* ((lst init-lst)
         (lst (if test
                  (append lst add-lst)
                  lst))
         ...)
    lst))

(define (command-output cmd . args)
  "Execute CMD with ARGS and return its output without trailing newspace."
  (let* ((port (apply open-pipe* OPEN_READ cmd args))
         (output (read-string port)))
    (close-port port)
    (string-trim-right output #\newline)))

(define (git-output . args)
  "Execute git command with ARGS and return its output without trailing
newspace."
  (with-directory-excursion (%guix-dir)
    (apply command-output "git" args)))

(define* (contributors-string #:optional (range "HEAD"))
  "Return a string with names of people contributed to commit RANGE."
  (git-output "shortlog" "--numbered" "--summary" "--email" range))

(define* (tags #:key pattern sort)
  "Return a list of the git repository tags.
PATTERN is passed to '--list' and SORT is passed to '--sort' options of
'git tag' command."
  (let* ((args (append-maybe
                '("tag")
                (pattern (list "--list" pattern))
                (sort    (list "--sort" sort))))
         (output (apply git-output args)))
    (string-split output #\newline)))

(define (version-tags)
  "Return only version tags (v0.8, etc.) sorted from the biggest version
to the smallest one."
  (tags #:pattern "v*"
        #:sort "-version:refname"))

(define (generate-authors-file file)
  "Generate authors FILE."
  (define previous-release-tag
    (find (lambda (tag)
            (version>? %guix-version
                       (substring tag 1))) ; remove leading 'v'
          (version-tags)))

  (define release-range
    (string-append previous-release-tag "..HEAD"))

  (with-output-to-file file
    (lambda ()
      (display "\
GNU Guix consists of Scheme code that implements the deployment model
of the Nix package management tool.  In fact, it currently talks to a
build daemon whose code comes from Nix (see the manual for details.)

Nix was initially written by Eelco Dolstra; other people have been
contributing to it.  See `nix/AUTHORS' for details.\n\n")
      (format #t "Contributors to GNU Guix ~a:\n\n"
              %guix-version)
      (display (contributors-string release-range))
      (newline) (newline)
      (display "Overall contributors:\n\n")
      (display (contributors-string))
      (newline))))

(define (show-help)
  (match (command-line)
    ((me _ ...)
     (format #t "Usage: guile ~a DIRECTORY AUTHORS
Generate AUTHORS file for DIRECTORY with the Guix git repository.\n"
             me))))

(match (command-line)
  ((_ guix-dir authors-file)
   (parameterize ((%guix-dir guix-dir))
     (generate-authors-file authors-file)))
  (_
   (show-help)
   (exit 1)))

;;; generate-authors.scm ends here
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; 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 system accounts)
  #:use-module (gnu system privilege)
  #:use-module (gnu build accounts)
  #:use-module (gnu build linux-boot)
  #:use-module (guix build utils)
  #:use-module ((guix build syscalls) #:select (with-file-lock))
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (activate-users+groups
            activate-user-home
            activate-etc
            activate-privileged-programs
            activate-special-files
            activate-modprobe
            activate-firmware
            activate-ptrace-attach
            activate-current-system
            mkdir-p/perms))

;;; 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 %skeleton-directory
  ;; Directory containing skeleton files for new accounts.
  ;; Note: keep the trailing '/' so that 'scandir' enters it.
  "/etc/skel/")

(define (dot-or-dot-dot? file)
  (member file '("." "..")))

;; Based upon mkdir-p from (guix build utils)
(define (verify-not-symbolic dir)
  "Verify DIR or its ancestors aren't symbolic links."
  (define absolute?
    (string-prefix? "/" dir))

  (define not-slash
    (char-set-complement (char-set #\/)))

  (define (verify-component file)
    (unless (eq? 'directory (stat:type (lstat file)))
      (error "file name component is not a directory" dir)))

  (let loop ((components (string-tokenize dir not-slash))
             (root       (if absolute?
                             ""
                             ".")))
    (match components
      ((head tail ...)
       (let ((file (string-append root "/" head)))
         (catch 'system-error
           (lambda ()
             (verify-component file)
             (loop tail file))
           (lambda args
             (if (= ENOENT (system-error-errno args))
                 #t
                 (apply throw args))))))
      (() #t))))

;; TODO: the TOCTTOU race can be addressed once guile has bindings
;; for fstatat, openat and friends.
(define (mkdir-p/perms directory owner bits)
  "Create the directory DIRECTORY and all its ancestors.
Verify no component of DIRECTORY is a symbolic link.
Warning: this is currently suspect to a TOCTTOU race!"
  (verify-not-symbolic directory)
  (mkdir-p directory)
  (chown directory (passwd:uid owner) (passwd:gid owner))
  (chmod directory bits))

(define* (copy-account-skeletons home
                                 #:key
                                 (directory %skeleton-directory)
                                 uid gid)
  "Copy the account skeletons from DIRECTORY to HOME.  When UID is an integer,
make it the owner of all the files created except the home directory; likewise
for GID."
  (define (set-owner file)
    (when (or uid gid)
      (chown file (or uid -1) (or gid -1))))

  (let ((files (scandir directory (negate dot-or-dot-dot?)
                        string<?)))
    (mkdir-p home)
    (for-each (lambda (file)
                (let ((target (string-append home "/" file)))
                  (copy-recursively (string-append directory "/" file)
                                    target
                                    #:log (%make-void-port "w"))
                  (for-each set-owner
                            (find-files target (const #t)
                                        #:directories? #t))
                  (make-file-writable target)))
              files)))

(define* (make-skeletons-writable home
                                  #:optional (directory %skeleton-directory))
  "Make sure that the files that have been copied from DIRECTORY to HOME are
owner-writable in HOME."
  (let ((files (scandir directory (negate dot-or-dot-dot?)
                        string<?)))
    (for-each (lambda (file)
                (let ((target (string-append home "/" file)))
                  (when (file-exists? target)
                    (make-file-writable target))))
              files)))

(define (duplicates lst)
  "Return elements from LST present more than once in LST."
  (let loop ((lst lst)
             (seen vlist-null)
             (result '()))
    (match lst
      (()
       (reverse result))
      ((head . tail)
       (loop tail
             (vhash-cons head #t seen)
             (if (vhash-assoc head seen)
                 (cons head result)
                 result))))))

(define (activate-users+groups users groups)
  "Make sure USERS (a list of user account records) and GROUPS (a list of user
group records) are all available."
  (define (make-home-directory user)
    (let ((home (user-account-home-directory user))
          (pwd  (getpwnam (user-account-name user))))
      (mkdir-p home)

      ;; Always set ownership and permissions for home directories of system
      ;; accounts.  If a service needs looser permissions on its home
      ;; directories, it can always chmod it in an activation snippet.
      (chown home (passwd:uid pwd) (passwd:gid pwd))
      (chmod home #o700)))

  (define system-accounts
    (filter (lambda (user)
              (and (user-account-system? user)
                   (user-account-create-home-directory? user)))
            users))

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

  ;; Take same lock as libc's 'lckpwdf' (but without a timeout) while we read
  ;; and write the databases.  This ensures there's no race condition with
  ;; other tools that might be accessing it at the same time.
  (with-file-lock %password-lock-file
    (let-values (((groups passwd shadow)
                  (user+group-databases users groups)))
      (write-group groups)
      (write-passwd passwd)
      (write-shadow shadow)))

  ;; Home directories of non-system accounts are created by
  ;; 'activate-user-home'.
  (for-each make-home-directory system-accounts)

  ;; Turn shared home directories, such as /var/empty, into root-owned,
  ;; read-only places.
  (for-each (lambda (directory)
              (chown directory 0 0)
              (chmod directory #o555))
            (duplicates (map user-account-home-directory system-accounts))))

(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
    (lambda (user)
      (let ((name         (user-account-name user))
            (home         (user-account-home-directory user))
            (create-home? (user-account-create-home-directory? user))
            (system?      (user-account-system? user)))
        ;; 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)
            (chmod home #o700)
            (copy-account-skeletons home
                                    #:uid uid #:gid gid)

            ;; It is important 'chown' be called after
            ;; 'copy-account-skeletons'.  Otherwise, a malicious user with
            ;; good timing could create a symlink in HOME that would be
            ;; dereferenced by 'copy-account-skeletons'.
            (chown home uid 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 used to be stored.  It exists for backwards
  ;; compatibility & will be removed.  Use %PRIVILEGED-PROGRAM-DIRECTORY instead.
  "/run/setuid-programs")

(define %privileged-program-directory
  ;; Place where privileged copies of programs are stored.
  "/run/privileged/bin")

(define (activate-privileged-programs programs libcap)
  "Turn PROGRAMS, a list of file privileged-programs records, into privileged
copies stored under %PRIVILEGED-PROGRAM-DIRECTORY, using LIBCAP's setcap(8)
binary if needed."
  (define (ensure-empty-directory directory)
    (if (file-exists? directory)
        (for-each (compose delete-file
                           (cut string-append directory "/" <>))
                  (scandir directory
                           (lambda (file)
                             (not (member file '("." ".."))))
                           string<?))
        (mkdir-p directory))    )

  (define (make-privileged-program program setuid? setgid? uid gid capabilities)
    (let ((target (string-append %privileged-program-directory
                                 "/" (basename program)))
          (mode (+ #o0555                   ; base permissions
                   (if setuid? #o4000 0)    ; setuid bit
                   (if setgid? #o2000 0)))) ; setgid bit
      (copy-file program target)
      (chown target uid gid)
      (chmod target mode)
      (when (and capabilities libcap)
        (system* (string-append libcap "/sbin/setcap")
                 "-q" capabilities target))))

  (define (make-deprecated-wrapper program)
    ;; This will eventually become a script that warns on usage, then vanish.
    (symlink (string-append %privileged-program-directory
                            "/" (basename program))
             (string-append %setuid-directory
                            "/" (basename program))))

  (format #t "setting up privileged programs in '~a'...~%"
          %privileged-program-directory)
  (ensure-empty-directory %privileged-program-directory)
  (ensure-empty-directory %setuid-directory)

  (for-each (lambda (program)
              (catch 'system-error
                (lambda ()
                  (let* ((program-name (privileged-program-program program))
                         (setuid?      (privileged-program-setuid? program))
                         (setgid?      (privileged-program-setgid? program))
                         (user         (privileged-program-user program))
                         (group        (privileged-program-group program))
                         (capabilities (privileged-program-capabilities program))
                         (uid (match user
                                ((? string?) (passwd:uid (getpwnam user)))
                                ((? integer?) user)))
                         (gid (match group
                                ((? string?) (group:gid (getgrnam group)))
                                ((? integer?) group))))
                    (make-privileged-program program-name
                                             setuid? setgid? uid gid
                                             capabilities)
                    (make-deprecated-wrapper program-name)))
                (lambda args
                  ;; If we fail to create a privileged program, better keep going
                  ;; so that we don't leave %PRIVILEGED-PROGRAM-DIRECTORY empty
                  ;; or half-populated.  This can happen if PROGRAMS contains
                  ;; incorrect file names: <https://bugs.gnu.org/38800>.
                  (format (current-error-port)
                          "warning: failed to privilege ~s: ~a~%"
                          (privileged-program-program program)
                          (strerror (system-error-errno args))))))
            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."

  ;; If the kernel was built without loadable module support, this file is
  ;; unavailable, so check for its existence first.
  (when (file-exists? "/proc/sys/kernel/modprobe")
    (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\"."

  ;; If the kernel was built without firmware loading support, this file
  ;; does not exist.  Do nothing in that case.
  (let ((firmware-path "/sys/module/firmware_class/parameters/path"))
    (when (file-exists? firmware-path)
      (call-with-output-file firmware-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 'gnu.system' argument passed on the kernel command line."
  (find-long-option "gnu.system" (if (string-contains %host-type "linux-gnu")
                                   (linux-command-line)
                                   (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)

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

;;; activation.scm ends here