code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 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 (gnu build accounts)
  #:use-module (guix records)
  #:use-module (guix combinators)
  #:use-module (gnu system accounts)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 rdelim)
  #:export (password-entry
            password-entry?
            password-entry-name
            password-entry-uid
            password-entry-gid
            password-entry-real-name
            password-entry-directory
            password-entry-shell

            shadow-entry
            shadow-entry?
            shadow-entry-name
            shadow-entry-minimum-change-period
            shadow-entry-maximum-change-period
            shadow-entry-change-warning-time
            shadow-entry-maximum-inactivity
            shadow-entry-expiration

            group-entry
            group-entry?
            group-entry-name
            group-entry-gid
            group-entry-members

            %password-lock-file
            write-group
            write-passwd
            write-shadow
            read-group
            read-passwd
            read-shadow

            %id-min
            %id-max
            %system-id-min
            %system-id-max

            user+group-databases))

;;; Commentary:
;;;
;;; This modules provides functionality equivalent to the C library's
;;; <shadow.h>, <pwd.h>, and <grp.h> routines, as well as a subset of the
;;; functionality of the Shadow command-line tools.  It can parse and write
;;; /etc/passwd, /etc/shadow, and /etc/group.  It can also take care of UID
;;; and GID allocation in a way similar to what 'useradd' does.
;;;
;;; The benefit is twofold: less code is involved, and the ID allocation
;;; strategy and state preservation is made explicit.
;;;
;;; Code:

;;;
;;; Machinery to define user and group databases.
;;;

(define-syntax serialize-field
  (syntax-rules (serialization)
    ((_ entry (field get (serialization ->string string->) _ ...))
     (->string (get entry)))
    ((_ entry (field get _ ...))
     (get entry))))

(define-syntax deserialize-field
  (syntax-rules (serialization)
    ((_ str (field get (serialization ->string string->) _ ...))
     (string-> str))
    ((_ str (field get _ ...))
     str)))

(define-syntax let/fields
  (syntax-rules ()
    ((_ (((name get attributes ...) rest ...) lst) body ...)
     (let ((l lst))
       (let ((name (deserialize-field (car l)
                                      (name get attributes ...))))
         (let/fields ((rest ...) (cdr l)) body ...))))
    ((_ (() lst) body ...)
     (begin body ...))))

(define-syntax define-database-entry
  (syntax-rules (serialization)
    "Define a record data type, as per 'define-record-type*', with additional
information on how to serialize and deserialize the whole database as well as
each field."
    ((_ <record> record make-record record?
        (serialization separator entry->string string->entry)
        fields ...)
     (let-syntax ((field-name
                   (syntax-rules ()
                     ((_ (name _ (... ...))) name))))
       (define-record-type* <record> record make-record
         record?
         fields ...)

       (define (entry->string entry)
         (string-join (list (serialize-field entry fields) ...)
                      (string separator)))

       (define (string->entry str)
         (let/fields ((fields ...) (string-split str #\:))
                     (make-record (field-name fields) ...)))))))

(define number->string*
  (match-lambda
    ((? number? number) (number->string number))
    (_ "")))

(define (false-if-string=? false-string)
  (lambda (str)
    (if (string=? str false-string)
        #f
        str)))

(define (string-if-false str)
  (lambda (obj)
    (if (not obj) str obj)))

(define (comma-separated->list str)
  (string-tokenize str (char-set-complement (char-set #\,))))

(define (list->comma-separated lst)
  (string-join lst ","))

;;;
;;; Database definitions.
;;;

(define-database-entry <password-entry>           ;<pwd.h>
  password-entry make-password-entry
  password-entry?
  (serialization #\: password-entry->string string->password-entry)

  (name       password-entry-name)
  (password   password-entry-password
              (serialization (const "x") (const #f))
              (default "x"))
  (uid        password-entry-uid
              (serialization number->string string->number))
  (gid        password-entry-gid
              (serialization number->string string->number))
  (real-name  password-entry-real-name
              (default ""))
  (directory  password-entry-directory)
  (shell      password-entry-shell
              (default "/bin/sh")))

(define-database-entry <shadow-entry>             ;<shadow.h>
  shadow-entry make-shadow-entry
  shadow-entry?
  (serialization #\: shadow-entry->string string->shadow-entry)

  (name                  shadow-entry-name)       ;string
  (password              shadow-entry-password    ;string | #f
                         (serialization (string-if-false "!")
                                        (false-if-string=? "!"))
                         (default #f))
  (last-change           shadow-entry-last-change ;days since 1970-01-01
                         (serialization number->string* string->number)
                         (default 0))
  (minimum-change-period shadow-entry-minimum-change-period
                         (serialization number->string* string->number)
                         (default #f))            ;days | #f
  (maximum-change-period shadow-entry-maximum-change-period
                         (serialization number->string* string->number)
                         (default #f))            ;days | #f
  (change-warning-time   shadow-entry-change-warning-time
                         (serialization number->string* string->number)
                         (default #f))            ;days | #f
  (maximum-inactivity    shadow-entry-maximum-inactivity
                         (serialization number->string* string->number)
                         (default #f))             ;days | #f
  (expiration            shadow-entry-expiration
                         (serialization number->string* string->number)
                         (default #f))            ;days since 1970-01-01 | #f
  (flags                 shadow-entry-flags       ;"reserved"
                         (serialization number->string* string->number)
                         (default #f)))

(define-database-entry <group-entry>              ;<grp.h>
  group-entry make-group-entry
  group-entry?
  (serialization #\: group-entry->string string->group-entry)

  (name            group-entry-name)
  (password        group-entry-password
                   (serialization (string-if-false "x")
                                  (false-if-string=? "x"))
                   (default #f))
  (gid             group-entry-gid
                   (serialization number->string string->number))
  (members         group-entry-members
                   (serialization list->comma-separated comma-separated->list)
                   (default '())))

(define %password-lock-file
  ;; The password database lock file used by libc's 'lckpwdf'.  Users should
  ;; grab this lock with 'with-file-lock' when they access the databases.
  "/etc/.pwd.lock")

(define (database-writer file mode entry->string)
  (lambda* (entries #:optional (file-or-port file))
    "Write ENTRIES to FILE-OR-PORT.  When FILE-OR-PORT is a file name, write
to it atomically and set the appropriate permissions."
    (define (write-entries port)
      (for-each (lambda (entry)
                  (display (entry->string entry) port)
                  (newline port))
                (delete-duplicates entries)))

    (if (port? file-or-port)
        (write-entries file-or-port)
        (let* ((template (string-append file-or-port ".XXXXXX"))
               (port     (mkstemp! template)))
          (dynamic-wind
            (const #t)
            (lambda ()
              (chmod port mode)
              (write-entries port)

              (fsync port)
              (close-port port)
              (rename-file template file-or-port))
            (lambda ()
              (unless (port-closed? port)
                (close-port port))
              (when (file-exists? template)
                (delete-file template))))))))

(define write-passwd
  (database-writer "/etc/passwd" #o644 password-entry->string))
(define write-shadow
  (database-writer "/etc/shadow" #o600 shadow-entry->string))
(define write-group
  (database-writer "/etc/group" #o644 group-entry->string))

(define (database-reader file string->entry)
  (lambda* (#:optional (file-or-port file))
    (define (read-entries port)
      (let loop ((entries '()))
        (match (read-line port)
          ((? eof-object?)
           (reverse entries))
          (line
           (loop (cons (string->entry line) entries))))))

    (if (port? file-or-port)
        (read-entries file-or-port)
        (call-with-input-file file-or-port
          read-entries))))

(define read-passwd
  (database-reader "/etc/passwd" string->password-entry))
(define read-shadow
  (database-reader "/etc/shadow" string->shadow-entry))
(define read-group
  (database-reader "/etc/group" string->group-entry))

;;;
;;; Building databases.
;;;

(define-record-type* <allocation>
  allocation make-allocation
  allocation?
  (ids            allocation-ids (default vlist-null))
  (next-id        allocation-next-id (default %id-min))
  (next-system-id allocation-next-system-id (default %system-id-max)))

;; Trick to avoid name clashes...
(define-syntax %allocation (identifier-syntax allocation))

;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c
;; in Shadow.)
(define %id-min 1000)
(define %id-max 60000)

(define %system-id-min 100)
(define %system-id-max 999)

(define (system-id? id)
  (and (> id %system-id-min)
       (<= id %system-id-max)))

(define (user-id? id)
  (and (>= id %id-min)
       (< id %id-max)))

(define* (allocate-id assignment #:key system?)
  "Return two values: a newly allocated ID, and an updated <allocation> record
based on ASSIGNMENT.  If SYSTEM? is true, return a system ID."
  (define next
    ;; Return the next available ID, looping if necessary.
    (if system?
        (lambda (id)
          (let ((next-id (- id 1)))
            (if (< next-id %system-id-min)
                %system-id-max
                next-id)))
        (lambda (id)
          (let ((next-id (+ id 1)))
            (if (>= next-id %id-max)
                %id-min
                next-id)))))

  (let loop ((id (if system?
                     (allocation-next-system-id assignment)
                     (allocation-next-id assignment))))
    (if (vhash-assv id (allocation-ids assignment))
        (loop (next id))
        (let ((taken (vhash-consv id #t (allocation-ids assignment))))
          (values (if system?
                      (allocation (inherit assignment)
                                  (next-system-id (next id))
                                  (ids taken))
                      (allocation (inherit assignment)
                                  (next-id (next id))
                                  (ids taken)))
                  id)))))

(define* (reserve-ids allocation ids #:key (skip? #t))
  "Mark the numbers listed in IDS as reserved in ALLOCATION.  When SKIP? is
true, start allocation after the highest (or lowest, depending on whether it's
a system ID allocation) number among IDS."
  (%allocation
   (inherit allocation)
   (next-id (if skip?
                (+ (reduce max
                           (- (allocation-next-id allocation) 1)
                           (filter user-id? ids))
                   1)
                (allocation-next-id allocation)))
   (next-system-id
    (if skip?
        (- (reduce min
                   (+ 1 (allocation-next-system-id allocation))
                   (filter system-id? ids))
           1)
        (allocation-next-system-id allocation)))
   (ids (fold (cut vhash-consv <> #t <>)
              (allocation-ids allocation)
              ids))))

(define (allocated? allocation id)
  "Return true if ID is already allocated as part of ALLOCATION."
  (->bool (vhash-assv id (allocation-ids allocation))))

(define (lookup-procedure lst key)
  "Return a lookup procedure for the elements of LST, calling KEY to obtain
the key of each element."
  (let ((table (fold (lambda (obj table)
                       (vhash-cons (key obj) obj table))
                     vlist-null
                     lst)))
    (lambda (key)
      (match (vhash-assoc key table)
        (#f #f)
        ((_ . value) value)))))

(define* (allocate-groups groups members
                          #:optional (current-groups '()))
  "Return a list of group entries for GROUPS, a list of <user-group>.  Members
for each group are taken from MEMBERS, a vhash that maps group names to member
names.  GIDs and passwords found in CURRENT-GROUPS, a list of group entries,
are reused."
  (define gids
    ;; Mark all the currently-used GIDs and the explicitly requested GIDs as
    ;; reserved.
    (reserve-ids (reserve-ids (allocation)
                              (map group-entry-gid current-groups))
                 (filter-map user-group-id groups)
                 #:skip? #f))

  (define previous-entry
    (lookup-procedure current-groups group-entry-name))

  (reverse
   (fold2 (lambda (group result allocation)
            (let ((name         (user-group-name group))
                  (password     (user-group-password group))
                  (requested-id (user-group-id group))
                  (system?      (user-group-system? group)))
              (let*-values (((previous)
                             (previous-entry name))
                            ((allocation id)
                             (cond
                              ((number? requested-id)
                               (values (reserve-ids allocation
                                                    (list requested-id))
                                       requested-id))
                              (previous
                               (values allocation
                                       (group-entry-gid previous)))
                              (else
                               (allocate-id allocation
                                            #:system? system?)))))
                (values (cons (group-entry
                               (name name)
                               (password
                                (if previous
                                    (group-entry-password previous)
                                    password))
                               (gid id)
                               (members (vhash-fold* cons '() name members)))
                              result)
                        allocation))))
          '()
          gids
          groups)))

(define* (allocate-passwd users groups #:optional (current-passwd '()))
  "Return a list of password entries for USERS, a list of <user-account>.
Take GIDs from GROUPS, a list of group entries.  Reuse UIDs from
CURRENT-PASSWD, a list of password entries, when possible; otherwise allocate
new UIDs."
  (define uids
    (reserve-ids (reserve-ids (allocation)
                              (map password-entry-uid current-passwd))
                 (filter-map user-account-uid users)
                 #:skip? #f))

  (define previous-entry
    (lookup-procedure current-passwd password-entry-name))

  (define (group-id name)
    (or (any (lambda (entry)
               (and (string=? (group-entry-name entry) name)
                    (group-entry-gid entry)))
             groups)
        (error "group not found" name)))

  (reverse
   (fold2 (lambda (user result allocation)
            (let ((name         (user-account-name user))
                  (requested-id (user-account-uid user))
                  (group        (user-account-group user))
                  (real-name    (user-account-comment user))
                  (directory    (user-account-home-directory user))
                  (shell        (user-account-shell user))
                  (system?      (user-account-system? user)))
              (let*-values (((previous)
                             (previous-entry name))
                            ((allocation id)
                             (cond
                              ((number? requested-id)
                               (values (reserve-ids allocation
                                                    (list requested-id))
                                       requested-id))
                              (previous
                               (values allocation
                                       (password-entry-uid previous)))
                              (else
                               (allocate-id allocation
                                            #:system? system?)))))
                (values (cons (password-entry
                               (name name)
                               (uid id)
                               (directory directory)
                               (gid (if (number? group) group (group-id group)))
                               (real-name (if previous
                                              (password-entry-real-name previous)
                                              real-name))

                               ;; Do not reuse the shell of PREVIOUS since (1)
                               ;; that could lead to confusion, and (2) the
                               ;; shell might have been GC'd.  See
                               ;; <https://lists.gnu.org/archive/html/guix-devel/2019-04/msg00478.html>.
                               (shell shell))
                              result)
                        allocation))))
          '()
          uids
          users)))

(define* (days-since-epoch #:optional (current-time current-time))
  "Return the number of days elapsed since the 1st of January, 1970."
  (let* ((now   (current-time time-utc))
         (epoch (make-time time-utc 0 0))
         (diff  (time-difference now epoch)))
    (quotient (time-second diff) (* 24 3600))))

(define* (passwd->shadow users passwd #:optional (current-shadow '())
                         #:key (current-time current-time))
  "Return a list of shadow entries for the password entries listed in PASSWD.
Reuse shadow entries from CURRENT-SHADOW when they exist, and take the initial
password from USERS."
  (define previous-entry
    (lookup-procedure current-shadow shadow-entry-name))

  (define now
    (days-since-epoch current-time))

  (map (lambda (user passwd)
         (or (previous-entry (password-entry-name passwd))
             (shadow-entry (name (password-entry-name passwd))
                           (password (user-account-password user))
                           (last-change now))))
       users passwd))

(define (empty-if-not-found thunk)
  "Call THUNK and return the empty list if that throws to ENOENT."
  (catch 'system-error
    thunk
    (lambda args
      (if (= ENOENT (system-error-errno args))
          '()
          (apply throw args)))))

(define* (user+group-databases users groups
                               #:key
                               (current-passwd
                                (empty-if-not-found read-passwd))
                               (current-groups
                                (empty-if-not-found read-group))
                               (current-shadow
                                (empty-if-not-found read-shadow))
                               (current-time current-time))
  "Return three values: the list of group entries, the list of password
entries, and the list of shadow entries corresponding to USERS and GROUPS.
Preserve stateful bits from CURRENT-PASSWD, CURRENT-GROUPS, and
CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc."
  (define members
    ;; Map group name to user names.
    (fold (lambda (user members)
            (fold (cute vhash-cons <> (user-account-name user) <>)
                  members
                  (user-account-supplementary-groups user)))
          vlist-null
          users))

  (define group-entries
    (allocate-groups groups members current-groups))

  (define passwd-entries
    (allocate-passwd users group-entries current-passwd))

  (define shadow-entries
    (passwd->shadow users passwd-entries current-shadow
                    #:current-time current-time))

  (values group-entries passwd-entries shadow-entries))


code:
;;; 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>
;;;
;;; 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 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-setuid-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 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 #o4555)))

  (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 (lambda (program)
              (catch 'system-error
                (lambda ()
                  (make-setuid-program program))
                (lambda args
                  ;; If we fail to create a setuid program, better keep going
                  ;; so that we don't leave %SETUID-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 make '~a' setuid-root: ~a~%"
                          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\"."
  (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" (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)

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

;;; activation.scm ends here

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 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 (gnu build bootloader)
  #:use-module (guix build utils)
  #:use-module (guix utils)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 format)
  #:use-module (rnrs io ports)
  #:use-module (rnrs io simple)
  #:export (write-file-on-device
            install-efi-loader))

;;;
;;; Writing utils.
;;;

(define (write-file-on-device file size device offset)
  "Write SIZE bytes from FILE to DEVICE starting at OFFSET."
  (call-with-input-file file
    (lambda (input)
      (let ((bv (get-bytevector-n input size)))
        (call-with-port
         ;; Do not use "call-with-output-file" that would truncate the file.
         (open-file-output-port device
                                (file-options no-truncate no-fail)
                                (buffer-mode block)
                                ;; Use the binary-friendly ISO-8859-1
                                ;; encoding.
                                (make-transcoder (latin-1-codec)))
         (lambda (output)
           (seek output offset SEEK_SET)
           (put-bytevector output bv)))))))

;;;
;;; EFI bootloader.
;;;

(define (install-efi grub grub-config esp)
  "Write a self-contained GRUB EFI loader to the mounted ESP using GRUB-CONFIG."
  (let* ((system %host-type)
         ;; Hard code the output location to a well-known path recognized by
         ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
         ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
         (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
         (efi-directory (string-append esp "/EFI/BOOT"))
         ;; Map grub target names to boot file names.
         (efi-targets (cond ((string-prefix? "x86_64" system)
                             '("x86_64-efi" . "BOOTX64.EFI"))
                            ((string-prefix? "i686" system)
                             '("i386-efi" . "BOOTIA32.EFI"))
                            ((string-prefix? "armhf" system)
                             '("arm-efi" . "BOOTARM.EFI"))
                            ((string-prefix? "aarch64" system)
                             '("arm64-efi" . "BOOTAA64.EFI")))))
    ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
    (setenv "TMPDIR" esp)

    (mkdir-p efi-directory)
    (invoke grub-mkstandalone "-O" (car efi-targets)
            "-o" (string-append efi-directory "/"
                                (cdr efi-targets))
            ;; Graft the configuration file onto the image.
            (string-append "boot/grub/grub.cfg=" grub-config))))

(define (install-efi-loader grub-efi esp)
  "Install in ESP directory the given GRUB-EFI bootloader.  Configure it to
load the Grub bootloader located in the 'Guix_image' root partition."
  (let ((grub-config "grub.cfg"))
    (call-with-output-file grub-config
      (lambda (port)
        ;; Create a tiny configuration file telling the embedded grub where to
        ;; load the real thing.  XXX This is quite fragile, and can prevent
        ;; the image from booting when there's more than one volume with this
        ;; label present.  Reproducible almost-UUIDs could reduce the risk
        ;; (not eliminate it).
        (format port
                "insmod part_msdos~@
               search --set=root --label Guix_image~@
               configfile /boot/grub/grub.cfg~%")))
    (install-efi grub-efi grub-config esp)
    (delete-file grub-config)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Marius Bakke <marius@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 (gnu build chromium-extension)
  #:use-module (gcrypt base16)
  #:use-module ((gcrypt hash) #:prefix hash:)
  #:use-module (ice-9 iconv)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages check)
  #:use-module (gnu packages chromium)
  #:use-module (gnu packages gnupg)
  #:use-module (gnu packages tls)
  #:use-module (gnu packages xorg)
  #:use-module (guix build-system trivial)
  #:export (make-chromium-extension))

;;; Commentary:
;;;
;;; Tools to deal with Chromium extensions.
;;;
;;; Code:

(define (make-signing-key seed)
  "Return a derivation for a deterministic PKCS #8 private key using SEED."

  (define sha256sum
    (bytevector->base16-string (hash:sha256 (string->bytevector seed "UTF-8"))))

  ;; certtool.c wants a 56 byte seed for a 2048 bit key.
  (define size 2048)
  (define normalized-seed (string-take sha256sum 56))

  (computed-file (string-append seed "-signing-key.pem")
                 #~(system* #$(file-append gnutls "/bin/certtool")
                            "--generate-privkey"
                            "--key-type=rsa"
                            "--pkcs8"
                            ;; Use the provable FIPS-PUB186-4 algorithm for
                            ;; deterministic results.
                            "--provable"
                            "--password="
                            "--no-text"
                            (string-append "--bits=" #$(number->string size))
                            (string-append "--seed=" #$normalized-seed)
                            "--outfile" #$output)
                 #:local-build? #t))

(define* (make-crx signing-key package #:optional (package-output "out"))
  "Create a signed \".crx\" file from the unpacked Chromium extension residing
in PACKAGE-OUTPUT of PACKAGE.  The extension will be signed with SIGNING-KEY."
  (define name (package-name package))
  (define version (package-version package))

  (with-imported-modules '((guix build utils))
    (computed-file
     (string-append name "-" version ".crx")
     #~(begin
         ;; This is not great.  We pull Xorg and Chromium just to Zip and
         ;; sign an extension.  This should be implemented with something
         ;; lighter.  (TODO: where is the CRXv3 documentation..?)
         (use-modules (guix build utils))
         (let ((chromium #$(file-append ungoogled-chromium "/bin/chromium"))
               (xvfb #$(file-append xorg-server "/bin/Xvfb"))
               (packdir "/tmp/extension"))
           (mkdir-p (dirname packdir))
           (copy-recursively (ungexp package package-output) packdir)
           (system (string-append xvfb " :1 &"))
           (setenv "DISPLAY" ":1")
           (sleep 2)                    ;give Xorg some time to initialize...
           ;; Chromium stores the current time in the .crx Zip archive.
           ;; Use a fixed timestamp for deterministic behavior.
           ;; FIXME (core-updates): faketime is missing an absolute reference
           ;; to 'date', hence the need to set PATH.
           (setenv "PATH" #$(file-append coreutils "/bin"))
           (invoke #$(file-append libfaketime "/bin/faketime")
                   "2000-01-01 00:00:00"
                   chromium
                   "--user-data-dir=/tmp/signing-profile"
                   (string-append "--pack-extension=" packdir)
                   (string-append "--pack-extension-key=" #$signing-key))
           (copy-file (string-append packdir ".crx") #$output)))
     #:local-build? #t)))

(define* (crx->chromium-json crx version)
  "Return a derivation that creates a Chromium JSON settings file for the
extension given as CRX.  VERSION is used to signify the CRX version, and
must match the version listed in the extension manifest.json."
  ;; See chrome/browser/extensions/external_provider_impl.cc and
  ;; extensions/common/extension.h for documentation on the JSON format.
  (computed-file "extension.json"
                 #~(call-with-output-file #$output
                     (lambda (port)
                       (format port "{
  \"external_crx\": \"~a\",
  \"external_version\": \"~a\"
}
"
                               #$crx #$version)))
                 #:local-build? #t))

(define (signing-key->public-der key)
  "Return a derivation for a file containing the public key of KEY in DER
format."
  (computed-file "der"
                 #~(system* #$(file-append gnutls "/bin/certtool")
                            "--load-privkey" #$key
                            "--pubkey-info"
                            "--outfile" #$output
                            "--outder")
                 #:local-build? #t))

(define (chromium-json->profile-object json signing-key)
  "Return a derivation that installs JSON to the directory searched by
Chromium, using a file name (aka extension ID) derived from SIGNING-KEY."
  (define der (signing-key->public-der signing-key))

  (with-extensions (list guile-gcrypt)
    (with-imported-modules '((guix build utils))
      (computed-file
       "chromium-extension"
       #~(begin
           (use-modules (guix build utils)
                        (gcrypt base16)
                        (gcrypt hash))
           (define (base16-string->chromium-base16 str)
             ;; Translate STR, a hexadecimal string, to a Chromium-style
             ;; representation using the letters a-p (where a=0, p=15).
             (define s1 "0123456789abcdef")
             (define s2 "abcdefghijklmnop")
             (let loop ((chars (string->list str))
                        (converted '()))
               (if (null? chars)
                   (list->string (reverse converted))
                   (loop (cdr chars)
                         (cons (string-ref s2 (string-index s1 (car chars)))
                               converted)))))

           (let* ((checksum (bytevector->base16-string (file-sha256 #$der)))
                  (file-name (base16-string->chromium-base16
                              (string-take checksum 32)))
                  (extension-directory (string-append #$output
                                                      "/share/chromium/extensions")))
             (mkdir-p extension-directory)
             (symlink #$json (string-append extension-directory "/"
                                            file-name ".json"))))
       #:local-build? #t))))

(define* (make-chromium-extension p #:optional (output "out"))
  "Create a Chromium extension from package P and return a package that,
when installed, will make the extension contained in P available as a
Chromium browser extension.  OUTPUT specifies which output of P to use."
  (let* ((pname (package-name p))
         (version (package-version p))
         (signing-key (make-signing-key pname)))
    (package
      (inherit p)
      (name (string-append pname "-chromium"))
      (source #f)
      (build-system trivial-build-system)
      (native-inputs '())
      (inputs
       `(("extension" ,(chromium-json->profile-object
                        (crx->chromium-json (make-crx signing-key p output)
                                            version)
                        signing-key))))
      (propagated-inputs '())
      (outputs '("out"))
      (arguments
       '(#:modules ((guix build utils))
         #:builder
         (begin
           (use-modules (guix build utils))
           (copy-recursively (assoc-ref %build-inputs "extension")
                             (assoc-ref %outputs "out"))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2019 Carl Dong <contact@carldong.me>
;;;
;;; 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 cross-toolchain)
  #:use-module (guix build utils)
  #:use-module (guix build gnu-build-system)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:export (cross-gcc-build-phases))

;;; Commentary:
;;;
;;; This module provides tools to build a cross-compiler.
;;;
;;; Code:

(define %gcc-include-paths
  ;; Environment variables for header search paths.
  ;; Note: See <http://bugs.gnu.org/22186> for why not 'CPATH'.
  '("C_INCLUDE_PATH"
    "CPLUS_INCLUDE_PATH"
    "OBJC_INCLUDE_PATH"
    "OBJCPLUS_INCLUDE_PATH"))

(define %gcc-cross-include-paths
  ;; Search path for target headers when cross-compiling.
  (map (cut string-append "CROSS_" <>) %gcc-include-paths))

(define* (make-cross-binutils-visible #:key outputs inputs target
                                      #:allow-other-keys)
  "Create symlinks for 'as', 'nm', and 'ld' in the \"out\" output, under
libexec/gcc, so that the cross-GCC can find them."
  (let* ((out      (assoc-ref outputs "out"))
         (libexec  (string-append out "/libexec/gcc/" target))
         (binutils (string-append (assoc-ref inputs "binutils-cross")
                                  "/bin/" target "-"))
         (wrapper  (string-append (assoc-ref inputs "ld-wrapper-cross")
                                  "/bin/" target "-ld")))
    (for-each (lambda (file)
                (symlink (string-append binutils file)
                         (string-append libexec "/" file)))
              '("as" "nm"))
    (symlink wrapper (string-append libexec "/ld"))
    #t))

(define* (set-cross-path #:key inputs #:allow-other-keys)
  "Add the cross kernel headers to CROSS_CPATH, and remove them from
C_INCLUDE_PATH et al."
  (match (assoc-ref inputs "libc")
    ((? string? libc)
     (let ((kernel (assoc-ref inputs "xkernel-headers")))
       (define (cross? x)
         ;; Return #t if X is a cross-libc or cross Linux.
         (or (string-prefix? libc x)
             (string-prefix? kernel x)))

       (let ((cpath (string-append libc "/include"
                                   ":" kernel "/include")))
         (for-each (cut setenv <> cpath)
                   %gcc-cross-include-paths))

       (setenv "CROSS_LIBRARY_PATH"
               (string-append libc "/lib:" kernel "/lib")) ;for Hurd's libihash

       (for-each (lambda (var)
                   (and=> (getenv var)
                          (lambda (value)
                            (let* ((path (search-path-as-string->list value))
                                   (native-path (list->search-path-as-string
                                                 (remove cross? path) ":")))
                              (setenv var native-path)))))
                 (cons "LIBRARY_PATH" %gcc-include-paths))
       #t))
    (#f
     ;; We're building the sans-libc cross-compiler, so nothing to do.
     #t)))

(define* (set-cross-path/mingw #:key inputs target #:allow-other-keys)
  "Add the cross MinGW headers to CROSS_C_*_INCLUDE_PATH, and remove them from
C_*INCLUDE_PATH."
  (let ((libc (assoc-ref inputs "libc"))
        (gcc (assoc-ref inputs "gcc")))
    (define (cross? x)
      (and libc (string-prefix? libc x)))

    (define (unpacked-mingw-dir)
      (match (scandir "." (lambda (name)
                            (string-contains name "mingw-w64")))
        ((mingw-dir)
         (string-append
          (getcwd) "/" mingw-dir "/mingw-w64-headers"))))

    (if libc
        (let ((cpath (string-append libc "/include"
                                    ":" libc "/" target "/include")))
          (for-each (cut setenv <> cpath)
                    %gcc-cross-include-paths))

        ;; libc is false, so we are building xgcc-sans-libc.
        ;; Add essential headers from mingw-w64.
        (let ((mingw-source (assoc-ref inputs "mingw-source")))
          (invoke "tar" "xvf" mingw-source)
          (let ((mingw-headers (unpacked-mingw-dir)))
            ;; We need _mingw.h which will gets built from _mingw.h.in by
            ;; mingw-w64's configure.  We cannot configure mingw-w64 until we
            ;; have xgcc-sans-libc; substitute to the rescue.
            (copy-file (string-append mingw-headers "/crt/_mingw.h.in")
                       (string-append mingw-headers "/crt/_mingw.h"))

            (substitute* (string-append mingw-headers "/crt/_mingw.h")
              (("@MINGW_HAS_SECURE_API@")
               "#define MINGW_HAS_SECURE_API 1")
              (("@DEFAULT_WIN32_WINNT@")
               "0x502")
              (("@DEFAULT_MSVCRT_VERSION@")
               "0x700"))

            (let ((cpath (string-append mingw-headers "/include"
                                        ":" mingw-headers "/crt"
                                        ":" mingw-headers
                                        "/defaults/include")))
              (for-each (cut setenv <> cpath)
                        (cons "CROSS_LIBRARY_PATH"
                              %gcc-cross-include-paths))))))

    (when libc
      (setenv "CROSS_LIBRARY_PATH"
              (string-append libc "/lib"
                             ":" libc "/" target "/lib")))

    (setenv "CPP" (string-append gcc "/bin/cpp"))
    (for-each (lambda (var)
                (and=> (getenv var)
                       (lambda (value)
                         (let* ((path (search-path-as-string->list
                                       value))
                                (native-path (list->search-path-as-string
                                              (remove cross? path) ":")))
                           (setenv var native-path)))))
              (cons "LIBRARY_PATH" %gcc-include-paths))
    #t))

(define (install-strip . _)
  "Install a stripped GCC."
  ;; Unlike our 'strip' phase, this will do the right thing for
  ;; cross-compilers.
  (invoke "make" "install-strip"))

(define* (cross-gcc-build-phases target
                                 #:optional (phases %standard-phases))
  "Modify PHASES to include everything needed to build a cross-GCC for TARGET,
a target triplet."
  (modify-phases phases
    (add-before 'configure 'set-cross-path
      ;; This mingw32 target checking logic should match that of target-mingw?
      ;; in (guix utils), but (guix utils) is too large too copy over to the
      ;; build side entirely and for now we have no way to select variables to
      ;; copy over. See (gnu packages cross-base) for more details.
      (if (string-suffix? "-mingw32" target)
          (cut set-cross-path/mingw #:target target <...>)
          set-cross-path))
    (add-after 'install 'make-cross-binutils-visible
      (cut make-cross-binutils-visible #:target target <...>))
    (replace 'install install-strip)))

;;; cross-toolchain.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 David C. Trudgian <dave@trudgian.net>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@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/>.

(define-module (gnu build file-systems)
  #:use-module (gnu system uuid)
  #:use-module (gnu system file-systems)
  #:use-module (guix build utils)
  #:use-module (guix build bournish)
  #:use-module ((guix build syscalls)
                #:hide (file-system-type))
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (system foreign)
  #:autoload   (system repl repl) (start-repl)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (disk-partitions
            partition-label-predicate
            partition-uuid-predicate
            partition-luks-uuid-predicate
            find-partition-by-label
            find-partition-by-uuid
            find-partition-by-luks-uuid
            canonicalize-device-spec

            read-partition-label
            read-partition-uuid
            read-luks-partition-uuid

            bind-mount

            mount-flags->bit-mask
            check-file-system
            mount-file-system))

;;; Commentary:
;;;
;;; This modules provides tools to deal with disk partitions, and to mount and
;;; check file systems.
;;;
;;; Code:

(define (bind-mount source target)
  "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)
      (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 null-terminated-latin1->string
  (cut latin1->string <> zero?))

(define (bytevector-utf16-length bv)
  "Given a bytevector BV containing a NUL-terminated UTF16-encoded string,
determine where the NUL terminator is and return its index.  If there's no
NUL terminator, return the size of the bytevector."
  (let ((length (bytevector-length bv)))
    (let loop ((index 0))
      (if (< index length)
          (if (zero? (bytevector-u16-ref bv index 'little))
              index
              (loop (+ index 2)))
          length))))

(define* (bytevector->u16-list bv endianness #:optional (index 0))
  (if (< index (bytevector-length bv))
      (cons (bytevector-u16-ref bv index endianness)
            (bytevector->u16-list bv endianness (+ index 2)))
      '()))

;; The initrd doesn't have iconv data, so do the conversion ourselves.
(define (utf16->string bv endianness)
  (list->string
   (map integer->char
        (reverse
         (let loop ((remainder (bytevector->u16-list bv endianness))
                    (result '()))
             (match remainder
              (() result)
              ((a) (cons a result))
              ((a b x ...)
               (if (and (>= a #xD800) (< a #xDC00) ; high surrogate
                        (>= b #xDC00) (< b #xE000)) ; low surrogate
                   (loop x (cons (+ #x10000
                                    (* #x400 (- a #xD800))
                                    (- b #xDC00))
                                 result))
                   (loop (cons b x) (cons a result))))))))))

(define (null-terminated-utf16->string bv endianness)
  (utf16->string (sub-bytevector bv 0 (bytevector-utf16-length bv))
                 endianness))

;;;
;;; Ext2 file systems.
;;;

;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
;; TODO: Use "packed structs" from Guile-OpenGL or similar.

(define-syntax %ext2-endianness
  ;; Endianness of ext2 file systems.
  (identifier-syntax (endianness little)))

(define (ext2-superblock? sblock)
  "Return #t when SBLOCK is an ext2 superblock."
  (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
    (= magic #xef53)))

(define (read-ext2-superblock device)
  "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
if DEVICE does not contain an ext2 file system."
  (read-superblock device 1024 264 ext2-superblock?))

(define (ext2-superblock-uuid sblock)
  "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock 104 16))

(define (ext2-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-latin1->string (sub-bytevector sblock 120 16)))

(define (check-ext2-file-system device)
  "Return the health of an ext2 file system on DEVICE."
  (match (status:exit-val
          (system* "e2fsck" "-v" "-p" "-C" "0" device))
    (0 'pass)
    (1 'errors-corrected)
    (2 'reboot-required)
    (_ 'fatal-error)))

;;;
;;; Linux swap.
;;;

;; Linux "swap space" is not a file system but it has a UUID and volume name,
;; like actual file systems, and we want to be able to look up swap partitions
;; by UUID and by label.

(define %linux-swap-magic
  (string->utf8 "SWAPSPACE2"))

;; Like 'PAGE_SIZE' in Linux, arch/x86/include/asm/page.h.
;; XXX: This is always 4K on x86_64, i386, and ARMv7.  However, on AArch64,
;; this is determined by 'CONFIG_ARM64_PAGE_SHIFT' in the kernel, which is 12
;; by default (4K) but can be 14 or 16.
(define %page-size 4096)

(define (linux-swap-superblock? sblock)
  "Return #t when SBLOCK is an linux-swap superblock."
  (and (= (bytevector-length sblock) %page-size)
       (bytevector=? (sub-bytevector sblock (- %page-size 10) 10)
                     %linux-swap-magic)))

(define (read-linux-swap-superblock device)
  "Return the raw contents of DEVICE's linux-swap superblock as a bytevector, or #f
if DEVICE does not contain an linux-swap file system."
  (read-superblock device 0 %page-size linux-swap-superblock?))

;; See 'union swap_header' in 'include/linux/swap.h'.

(define (linux-swap-superblock-uuid sblock)
  "Return the UUID of Linux-swap superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock (+ 1024 4 4 4) 16))

(define (linux-swap-superblock-volume-name sblock)
  "Return the label of Linux-swap superblock SBLOCK as a string."
  (null-terminated-latin1->string
   (sub-bytevector sblock (+ 1024 4 4 4 16) 16)))

;;;
;;; Bcachefs file systems.
;;;

;; <https://evilpiepirate.org/git/bcachefs-tools.git/tree/libbcachefs/bcachefs_format.h>

(define-syntax %bcachefs-endianness
  ;; Endianness of bcachefs file systems.
  (identifier-syntax (endianness little)))

(define (bcachefs-superblock? sblock)
  "Return #t when SBLOCK is an bcachefs superblock."
  (bytevector=? (sub-bytevector sblock 24 16)
                #vu8(#xc6 #x85 #x73 #xf6 #x4e #x1a #x45 #xca
                     #x82 #x65 #xf5 #x7f #x48 #xba #x6d #x81)))

(define (read-bcachefs-superblock device)
  "Return the raw contents of DEVICE's bcachefs superblock as a bytevector, or #f
if DEVICE does not contain a bcachefs file system."
  ;; Field offsets & lengths, in bytes.  There are more (and the superblock is
  ;; extensible) but we need only some basic information here:
  ;;  0 16 bch_csum
  ;; 16  8 version
  ;; 24 16 magic
  ;; 40 16 uuid               ← ‘internal’: you probably don't want this one
  ;; 56 16 user_uuid          ← ‘external’: user-visible one by which to mount
  ;; 72 32 label
  ;; Assume a sane file system: ignore the back-up superblock & checksums.
  (read-superblock device 4096 104 bcachefs-superblock?))

(define (bcachefs-superblock-external-uuid sblock)
  "Return the external UUID of bcachefs superblock SBLOCK as a 16-byte
bytevector."
  (sub-bytevector sblock 56 16))

(define (bcachefs-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 32 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-latin1->string (sub-bytevector sblock 72 32)))

(define (check-bcachefs-file-system device)
  "Return the health of a bcachefs file system on DEVICE."
  (let ((ignored-bits (logior 2))       ; DEVICE was mounted read-only
        (status
         ;; A number, or #f on abnormal termination (e.g., assertion failure).
         (status:exit-val
          (apply system* "bcachefs" "fsck" "-p" "-v"
                 ;; Make each multi-device member a separate argument.
                 (string-split device #\:)))))
    (match (and=> status (cut logand <> (lognot ignored-bits)))
      (0 'pass)
      (1 'errors-corrected)
      (_ 'fatal-error))))

;;;
;;; Btrfs file systems.
;;;

;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.

(define-syntax %btrfs-endianness
  ;; Endianness of btrfs file systems.
  (identifier-syntax (endianness little)))

(define (btrfs-superblock? sblock)
  "Return #t when SBLOCK is a btrfs superblock."
  (bytevector=? (sub-bytevector sblock 64 8)
                (string->utf8 "_BHRfS_M")))

(define (read-btrfs-superblock device)
  "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
if DEVICE does not contain a btrfs file system."
  (read-superblock device 65536 4096 btrfs-superblock?))

(define (btrfs-superblock-uuid sblock)
  "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock 32 16))

(define (btrfs-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 256 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-latin1->string (sub-bytevector sblock 299 256)))

(define (check-btrfs-file-system device)
  "Return the health of a btrfs file system on DEVICE."
  (match (status:exit-val
          (system* "btrfs" "device" "scan"))
    (0 'pass)
    (_ 'fatal-error)))

;;;
;;; FAT32 file systems.
;;;

;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.

(define (fat32-superblock? sblock)
  "Return #t when SBLOCK is a fat32 superblock."
  (bytevector=? (sub-bytevector sblock 82 8)
                (string->utf8 "FAT32   ")))

(define (read-fat32-superblock device)
  "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or
#f if DEVICE does not contain a fat32 file system."
  (read-superblock device 0 90 fat32-superblock?))

(define (fat32-superblock-uuid sblock)
  "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
  (sub-bytevector sblock 67 4))

(define (fat32-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 11 characters, or
#f if SBLOCK has no volume name.  The volume name is a latin1 string.
Trailing spaces are trimmed."
  (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))

(define (check-fat-file-system device)
  "Return the health of a fat file system on DEVICE."
  (match (status:exit-val
          (system* "fsck.vfat" "-v" "-a" device))
    (0 'pass)
    (1 'errors-corrected)
    (_ 'fatal-error)))

;;;
;;; FAT16 file systems.
;;;

(define (fat16-superblock? sblock)
  "Return #t when SBLOCK is a fat16 boot record."
  (bytevector=? (sub-bytevector sblock 54 8)
                (string->utf8 "FAT16   ")))

(define (read-fat16-superblock device)
  "Return the raw contents of DEVICE's fat16 superblock as a bytevector, or
#f if DEVICE does not contain a fat16 file system."
  (read-superblock device 0 62 fat16-superblock?))

(define (fat16-superblock-uuid sblock)
  "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
  (sub-bytevector sblock 39 4))

(define (fat16-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 11 characters, or
#f if SBLOCK has no volume name.  The volume name is a latin1 string.
Trailing spaces are trimmed."
  (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
                                     (lambda (c) #f))
                     #\space))

;;;
;;; ISO9660 file systems.
;;;

;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.

(define (iso9660-superblock? sblock)
  "Return #t when SBLOCK is an iso9660 volume descriptor."
  (bytevector=? (sub-bytevector sblock 1 6)
                ;; Note: "\x01" is the volume descriptor format version
                (string->utf8 "CD001\x01")))

(define (read-iso9660-primary-volume-descriptor device offset)
  "Find and read the first primary volume descriptor, starting at OFFSET.
   Return #f if not found."
  (let* ((sblock    (read-superblock device offset 2048 iso9660-superblock?))
         (type-code (if sblock
                        (bytevector-u8-ref sblock 0)
                        (error (format #f
                                       "Could not read ISO9660 primary
volume descriptor from ~s"
                                       device)))))
    (match type-code
      (255 #f) ; Volume Descriptor Set Terminator.
      (1 sblock) ; Primary Volume Descriptor
      (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))

(define (read-iso9660-superblock device)
  "Return the raw contents of DEVICE's iso9660 primary volume descriptor
as a bytevector, or #f if DEVICE does not contain an iso9660 file system."
  ;; Start reading at sector 16.
  ;; Since we are not sure that the device contains an ISO9660 file system,
  ;; we have to find that out first.
  (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?)
      (read-iso9660-primary-volume-descriptor device (* 2048 16))
      #f)) ; Device does not contain an iso9660 file system.

(define (iso9660-superblock-uuid sblock)
  "Return the modification time of an iso9660 primary volume descriptor
SBLOCK as a bytevector.  If that's not set, returns the creation time."
  ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
  ;; Compare Grub: "2014-12-02-19-30-23-00".
  ;; Compare blkid result: "2014-12-02-19-30-23-00".
  ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
  (let* ((creation-time (sub-bytevector sblock 813 17))
         (modification-time (sub-bytevector sblock 830 17))
         (unset-time (make-bytevector 17 0))
         (time (if (bytevector=? unset-time modification-time)
                   creation-time
                   modification-time)))
    (sub-bytevector time 0 16))) ; strips GMT offset.

(define (iso9660-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string.  The volume name is an ASCII
string.  Trailing spaces are trimmed."
  ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
  (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
                                     (lambda (c) #f)) #\space))

;;;
;;; JFS file systems.
;;;

;; Taken from <linux-libre>/fs/jfs/jfs_superblock.h.

(define-syntax %jfs-endianness
  ;; Endianness of JFS file systems.
  (identifier-syntax (endianness little)))

(define (jfs-superblock? sblock)
  "Return #t when SBLOCK is a JFS superblock."
  (bytevector=? (sub-bytevector sblock 0 4)
                (string->utf8 "JFS1")))

(define (read-jfs-superblock device)
  "Return the raw contents of DEVICE's JFS superblock as a bytevector, or #f
if DEVICE does not contain a JFS file system."
  (read-superblock device 32768 184 jfs-superblock?))

(define (jfs-superblock-uuid sblock)
  "Return the UUID of JFS superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock 136 16))

(define (jfs-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-latin1->string (sub-bytevector sblock 152 16)))

(define (check-jfs-file-system device)
  "Return the health of a JFS file system on DEVICE."
  (match (status:exit-val
          (system* "jfs_fsck" "-p" "-v" device))
    (0 'pass)
    (1 'errors-corrected)
    (2 'reboot-required)
    (_ 'fatal-error)))

;;;
;;; F2FS (Flash-Friendly File System)
;;;

;;; https://git.kernel.org/pub/scm/linux/kernel/git/jaegeuk/f2fs.git/tree/include/linux/f2fs_fs.h
;;; (but using xxd proved to be simpler)

(define-syntax %f2fs-endianness
  ;; Endianness of F2FS file systems
  (identifier-syntax (endianness little)))

;; F2FS actually stores two adjacent copies of the superblock.
;; should we read both?
(define (f2fs-superblock? sblock)
  "Return #t when SBLOCK is an F2FS superblock."
  (let ((magic (bytevector-u32-ref sblock 0 %f2fs-endianness)))
    (= magic #xF2F52010)))

(define (read-f2fs-superblock device)
  "Return the raw contents of DEVICE's F2FS superblock as a bytevector, or #f
if DEVICE does not contain an F2FS file system."
  (read-superblock device
                   ;; offset of magic in first copy
                   #x400
                   ;; difference between magic of second
                   ;; and first copies
                   (- #x1400 #x400)
                   f2fs-superblock?))

(define (f2fs-superblock-uuid sblock)
  "Return the UUID of F2FS superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock
                  (- (+ #x460 12)
                     ;; subtract superblock offset
                     #x400)
                  16))

(define (f2fs-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 512 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-utf16->string
   (sub-bytevector sblock (- (+ #x470 12) #x400) 512)
   %f2fs-endianness))

(define (check-f2fs-file-system device)
  "Return the health of a F2FS file system on DEVICE."
  (match (status:exit-val
          (system* "fsck.f2fs" "-p" device))
    ;; 0 and -1 are the only two possibilities
    ;; (according to the manpage)
    (0 'pass)
    (_ 'fatal-error)))

;;;
;;; LUKS encrypted devices.
;;;

;; The LUKS header format is described in "LUKS On-Disk Format Specification":
;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>.  We follow
;; version 1.2.1 of this document.

;; The LUKS2 header format is described in "LUKS2 On-Disk Format Specification":
;; <https://gitlab.com/cryptsetup/LUKS2-docs/blob/master/luks2_doc_wip.pdf>.
;; It is a WIP document.

(define-syntax %luks-endianness
  ;; Endianness of LUKS headers.
  (identifier-syntax (endianness big)))

(define (luks-superblock? sblock)
  "Return #t when SBLOCK is a luks superblock."
  (define %luks-magic
    ;; The 'LUKS_MAGIC' constant.
    (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
                                 (list #xba #xbe))))
  (let ((magic   (sub-bytevector sblock 0 6))
        (version (bytevector-u16-ref sblock 6 %luks-endianness)))
    (and (bytevector=? magic %luks-magic)
         (or (= version 1) (= version 2)))))

(define (read-luks-header file)
  "Read a LUKS header from FILE.  Return the raw header on success, and #f if
not valid header was found."
  ;; Size in bytes of the LUKS binary header, which includes key slots in
  ;; LUKS1.  In LUKS2 the binary header is partially backward compatible, so
  ;; that UUID can be extracted as for LUKS1. Keyslots and other metadata are
  ;; not part of this header in LUKS2, but are included in the JSON metadata
  ;; area that follows.
  (read-superblock file 0 592 luks-superblock?))

(define (luks-header-uuid header)
  "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
  ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
  ;; bytes of its ASCII representation.
  (let ((uuid (sub-bytevector header 168 36)))
    (string->uuid (utf8->string uuid))))

;;;
;;; NTFS file systems.
;;;

;; Taken from <linux-libre>/fs/ntfs/layout.h

(define-syntax %ntfs-endianness
  ;; Endianness of NTFS file systems.
  (identifier-syntax (endianness little)))

(define (ntfs-superblock? sblock)
  "Return #t when SBLOCK is a NTFS superblock."
  (bytevector=? (sub-bytevector sblock 3 8)
                (string->utf8 "NTFS    ")))

(define (read-ntfs-superblock device)
  "Return the raw contents of DEVICE's NTFS superblock as a bytevector, or #f
if DEVICE does not contain a NTFS file system."
  (read-superblock device 0 511 ntfs-superblock?))

(define (ntfs-superblock-uuid sblock)
  "Return the UUID of NTFS superblock SBLOCK as a 8-byte bytevector."
  (sub-bytevector sblock 72 8))

;; TODO: Add ntfs-superblock-volume-name.  The partition label is not stored
;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems
;; way harder to access.

(define (check-ntfs-file-system device)
  "Return the health of a NTFS file system on DEVICE."
  (match (status:exit-val
          (system* "ntfsfix" device))
    (0 'pass)
    (_ 'fatal-error)))

;;;
;;; Partition lookup.
;;;

(define (disk-partitions)
  "Return the list of device names corresponding to valid disk partitions."
  (define (partition? name major minor)
    ;; grub-mkrescue does some funny things for EFI support which
    ;; makes it a lot more difficult than one would expect to support
    ;; booting an ISO-9660 image from an USB flash drive.
    ;; For example there's a buggy (too small) hidden partition in it
    ;; which Linux mounts and then proceeds to fail while trying to
    ;; fall off the edge.
    ;; In any case, partition tables are supposed to be optional so
    ;; here we allow checking entire disks for file systems, too.
    (> major 2))                      ;ignore RAM disks and floppy disks

  (call-with-input-file "/proc/partitions"
    (lambda (port)
      ;; Skip the two header lines.
      (read-line port)
      (read-line port)

      ;; Read each subsequent line, and extract the last space-separated
      ;; field.
      (let loop ((parts '()))
        (let ((line  (read-line port)))
          (if (eof-object? line)
              (reverse parts)
              (match (string-tokenize line)
                (((= string->number major) (= string->number minor)
                  blocks name)
                 (if (partition? name major minor)
                     (loop (cons name parts))
                     (loop parts))))))))))

(define (ENOENT-safe proc)
  "Wrap the one-argument PROC such that ENOENT, EIO, and ENOMEDIUM errors are
caught and lead to a warning and #f as the result."
  (lambda (device)
    (catch 'system-error
      (lambda ()
        (proc device))
      (lambda args
        (let ((errno (system-error-errno args)))
          (cond ((= ENOENT errno)
                 (format (current-error-port)
                         "warning: device '~a' not found~%" device)
                 #f)
                ((= ENOMEDIUM errno)              ;for removable media
                 #f)
                ((= EIO errno)                    ;unreadable hardware like audio CDs
                 (format (current-error-port)
                         "warning: failed to read from device '~a'~%" device)
                 #f)
                (else
                 (apply throw args))))))))

(define (partition-field-reader read field)
  "Return a procedure that takes a device and returns the value of a FIELD in
the partition superblock or #f."
  (lambda (device)
    (let ((sblock (read device)))
      (and sblock
           (field sblock)))))

(define (read-partition-field device partition-field-readers)
  "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
takes a list of PARTITION-FIELD-READERS and returns the result of the first
partition field reader that returned a value."
  (match (filter-map (cut apply <> (list device)) partition-field-readers)
    ((field . _) field)
    (_ #f)))

(define %partition-label-readers
  (list (partition-field-reader read-iso9660-superblock
                                iso9660-superblock-volume-name)
        (partition-field-reader read-ext2-superblock
                                ext2-superblock-volume-name)
        (partition-field-reader read-linux-swap-superblock
                                linux-swap-superblock-volume-name)
        (partition-field-reader read-bcachefs-superblock
                                bcachefs-superblock-volume-name)
        (partition-field-reader read-btrfs-superblock
                                btrfs-superblock-volume-name)
        (partition-field-reader read-fat32-superblock
                                fat32-superblock-volume-name)
        (partition-field-reader read-fat16-superblock
                                fat16-superblock-volume-name)
        (partition-field-reader read-jfs-superblock
                                jfs-superblock-volume-name)
        (partition-field-reader read-f2fs-superblock
                                f2fs-superblock-volume-name)))

(define %partition-uuid-readers
  (list (partition-field-reader read-iso9660-superblock
                                iso9660-superblock-uuid)
        (partition-field-reader read-ext2-superblock
                                ext2-superblock-uuid)
        (partition-field-reader read-linux-swap-superblock
                                linux-swap-superblock-uuid)
        (partition-field-reader read-bcachefs-superblock
                                bcachefs-superblock-external-uuid)
        (partition-field-reader read-btrfs-superblock
                                btrfs-superblock-uuid)
        (partition-field-reader read-fat32-superblock
                                fat32-superblock-uuid)
        (partition-field-reader read-fat16-superblock
                                fat16-superblock-uuid)
        (partition-field-reader read-jfs-superblock
                                jfs-superblock-uuid)
        (partition-field-reader read-f2fs-superblock
                                f2fs-superblock-uuid)
        (partition-field-reader read-ntfs-superblock
                                ntfs-superblock-uuid)))

(define read-partition-label
  (cut read-partition-field <> %partition-label-readers))

(define read-partition-uuid
  (cut read-partition-field <> %partition-uuid-readers))

(define luks-partition-field-reader
  (partition-field-reader read-luks-header luks-header-uuid))

(define read-luks-partition-uuid
  (cut read-partition-field <> (list luks-partition-field-reader)))

(define (partition-predicate reader =)
  "Return a predicate that returns true if the FIELD of partition header that
was READ is = to the given value."
  ;; When running on the hand-made /dev, 'disk-partitions' could return
  ;; partitions for which we have no /dev node.  Handle that gracefully.
  (let ((reader (ENOENT-safe reader)))
    (lambda (expected)
      (lambda (device)
        (let ((actual (reader device)))
          (and actual
               (= actual expected)))))))

(define partition-label-predicate
  (partition-predicate read-partition-label string=?))

(define partition-uuid-predicate
  (partition-predicate read-partition-uuid uuid=?))

(define luks-partition-uuid-predicate
  (partition-predicate luks-partition-field-reader uuid=?))

(define (find-partition predicate)
  "Return the first partition found that matches PREDICATE, or #f if none
were found."
  (lambda (expected)
    (find (predicate expected)
          (map (cut string-append "/dev/" <>)
               (disk-partitions)))))

(define find-partition-by-label
  (find-partition partition-label-predicate))

(define find-partition-by-uuid
  (find-partition partition-uuid-predicate))

(define find-partition-by-luks-uuid
  (find-partition luks-partition-uuid-predicate))

(define (canonicalize-device-spec spec)
  "Return the device name corresponding to SPEC, which can be a <uuid>, a
<file-system-label>, or a string (typically a /dev file name or an nfs-root
containing ':/')."
  (define max-trials
    ;; Number of times we retry partition label resolution, 1 second per
    ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
    ;; USB key would be detected by the kernel, so we must wait for at least
    ;; this long.
    20)

  (define (resolve find-partition spec fmt)
    (let loop ((count 0))
      (let ((device (find-partition spec)))
        (or device
            ;; Some devices take a bit of time to appear, most notably USB
            ;; storage devices.  Thus, wait for the device to appear.
            (if (> count max-trials)
                (error "failed to resolve partition" (fmt spec))
                (begin
                  (format #t "waiting for partition '~a' to appear...~%"
                          (fmt spec))
                  (sleep 1)
                  (loop (+ 1 count))))))))

  (match spec
    ((? string?)
     (if (string-contains spec ":/")
         spec                  ; do not resolve NFS devices
         ;; Nothing to do, but wait until SPEC shows up.
         (resolve identity spec identity)))
    ((? file-system-label?)
     ;; Resolve the label.
     (resolve find-partition-by-label
              (file-system-label->string spec)
              identity))
    ((? uuid?)
     (resolve find-partition-by-uuid
              (uuid-bytevector spec)
              uuid->string))))

(define (check-file-system device type)
  "Run a file system check of TYPE on DEVICE."
  (define check-procedure
    (cond
     ((string-prefix? "ext" type) check-ext2-file-system)
     ((string-prefix? "bcachefs" type) check-bcachefs-file-system)
     ((string-prefix? "btrfs" type) check-btrfs-file-system)
     ((string-suffix? "fat" type) check-fat-file-system)
     ((string-prefix? "jfs" type) check-jfs-file-system)
     ((string-prefix? "f2fs" type) check-f2fs-file-system)
     ((string-prefix? "ntfs" type) check-ntfs-file-system)
     ((string-prefix? "nfs" type) (const 'pass))
     (else #f)))

  (if check-procedure
      (match (check-procedure device)
        ('pass
         #t)
        ('errors-corrected
         (format (current-error-port)
                 "File system check corrected errors on ~a; continuing~%"
                 device))
        ('reboot-required
         (format (current-error-port)
                 "File system check corrected errors on ~a; rebooting~%"
                 device)
         (sleep 3)
         (reboot))
        ('fatal-error
         (format (current-error-port) "File system check on ~a failed~%"
                 device)

         ;; Spawn a REPL only if someone would be able to interact with it.
         (when (isatty? (current-input-port))
           (format (current-error-port) "Spawning Bourne-like REPL.~%")

           ;; 'current-output-port' is typically connected to /dev/klog (in
           ;; PID 1), but here we want to make sure we talk directly to the
           ;; user.
           (with-output-to-file "/dev/console"
             (lambda ()
               (start-repl %bournish-language))))))
      (format (current-error-port)
              "No file system check procedure for ~a; skipping~%"
              device)))

(define (mount-flags->bit-mask flags)
  "Return the number suitable for the 'flags' argument of 'mount' that
corresponds to the symbols listed in FLAGS."
  (let loop ((flags flags))
    (match flags
      (('read-only rest ...)
       (logior MS_RDONLY (loop rest)))
      (('bind-mount rest ...)
       (logior MS_BIND (loop rest)))
      (('no-suid rest ...)
       (logior MS_NOSUID (loop rest)))
      (('no-dev rest ...)
       (logior MS_NODEV (loop rest)))
      (('no-exec rest ...)
       (logior MS_NOEXEC (loop rest)))
      (('no-atime rest ...)
       (logior MS_NOATIME (loop rest)))
      (('strict-atime rest ...)
       (logior MS_STRICTATIME (loop rest)))
      (('lazy-time rest ...)
       (logior MS_LAZYTIME (loop rest)))
      (()
       0))))

(define* (mount-file-system fs #:key (root "/root"))
  "Mount the file system described by FS, a <file-system> object, under ROOT."

  (define (mount-nfs source mount-point type flags options)
    (let* ((idx (string-rindex source #\:))
           (host-part (string-take source idx))
           ;; Strip [] from around host if present
           (host (match (string-split host-part (string->char-set "[]"))
                 (("" h "") h)
                 ((h) h)))
           (aa (match (getaddrinfo host "nfs") ((x . _) x)))
           (sa (addrinfo:addr aa))
           (inet-addr (inet-ntop (sockaddr:fam sa)
                                 (sockaddr:addr sa))))

      ;; Mounting an NFS file system requires passing the address
      ;; of the server in the addr= option
      (mount source mount-point type flags
             (string-append "addr="
                            inet-addr
                            (if options
                                (string-append "," options)
                                "")))))
  (let* ((type    (file-system-type fs))
         (source  (canonicalize-device-spec (file-system-device fs)))
         (target  (string-append root "/"
                                 (file-system-mount-point fs)))
         (flags   (logior (mount-flags->bit-mask (file-system-flags fs))

                          ;; For bind mounts, preserve the original flags such
                          ;; as MS_NOSUID, etc.  Failing to do that, the
                          ;; MS_REMOUNT call below fails with EPERM.
                          ;; See <https://bugs.gnu.org/46292>
                          (if (memq 'bind-mount (file-system-flags fs))
                              (statfs-flags->mount-flags
                               (file-system-mount-flags (statfs source)))
                              0)))
         (options (file-system-options fs)))
    (when (file-system-check? fs)
      (check-file-system source type))

    (catch 'system-error
      (lambda ()
        ;; Create the mount point.  Most of the time this is a directory, but
        ;; in the case of a bind mount, a regular file or socket may be
        ;; needed.
        (if (and (= MS_BIND (logand flags MS_BIND))
                 (not (file-is-directory? source)))
            (unless (file-exists? target)
              (mkdir-p (dirname target))
              (call-with-output-file target (const #t)))
            (mkdir-p target))

        (cond
         ((string-prefix? "nfs" type)
          (mount-nfs source target type flags options))
         (else
          (mount source target type flags options)))

        ;; For read-only bind mounts, an extra remount is needed, as per
        ;; <http://lwn.net/Articles/281157/>, which still applies to Linux
        ;; 4.0.
        (when (and (= MS_BIND (logand flags MS_BIND))
                   (= MS_RDONLY (logand flags MS_RDONLY)))
          (let ((flags (logior MS_REMOUNT flags)))
            (mount source target type flags options))))
      (lambda args
        (or (file-system-mount-may-fail? fs)
            (apply throw args))))))

;;; file-systems.scm ends here