code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.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 linux-modules)
  #:use-module (guix elf)
  #:use-module (guix glob)
  #:use-module (guix build syscalls)
  #:use-module ((guix build utils) #:select (find-files invoke))
  #:use-module (guix build union)
  #:autoload   (zlib) (call-with-gzip-input-port)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:export (dot-ko
            ensure-dot-ko
            module-formal-name
            module-aliases
            module-dependencies
            module-soft-dependencies
            normalize-module-name
            file-name->module-name
            find-module-file
            recursive-module-dependencies
            modules-loaded
            module-loaded?
            load-linux-module*
            load-linux-modules-from-directory

            current-module-debugging-port

            device-module-aliases
            known-module-aliases
            matching-modules
            missing-modules

            write-module-name-database
            write-module-alias-database
            write-module-device-database

            make-linux-module-directory))

;;; Commentary:
;;;
;;; Tools to deal with Linux kernel modules.
;;;
;;; Code:

(define current-module-debugging-port
  (make-parameter (%make-void-port "w")))

(define (section-contents elf section)
  "Return the contents of SECTION in ELF as a bytevector."
  (let ((contents (make-bytevector (elf-section-size section))))
    (bytevector-copy! (elf-bytes elf) (elf-section-offset section)
                      contents 0
                      (elf-section-size section))
    contents))

(define %not-nul
  (char-set-complement (char-set #\nul)))

(define (nul-separated-string->list str)
  "Split STR at occurrences of the NUL character and return the resulting
string list."
  (string-tokenize str %not-nul))

(define (key=value->pair str)
  "Assuming STR has the form \"KEY=VALUE\", return a pair like (KEY
. \"VALUE\")."
  (let ((= (string-index str #\=)))
    (cons (string->symbol (string-take str =))
          (string-drop str (+ 1 =)))))

;; Matches kernel modules, without compression, with GZIP compression or with
;; XZ compression.
(define module-regex "\\.ko(\\.gz|\\.xz)?$")

(define (modinfo-section-contents file)
  "Return the contents of the '.modinfo' section of FILE as a list of
key/value pairs.."
  (define (get-bytevector file)
    (cond
     ((string-suffix? ".ko.gz" file)
      (let ((port (open-file file "r0")))
        (dynamic-wind
          (lambda ()
            #t)
          (lambda ()
            (call-with-gzip-input-port port get-bytevector-all))
          (lambda ()
            (close-port port)))))
     (else
      (call-with-input-file file get-bytevector-all))))

  (let* ((bv      (get-bytevector file))
         (elf     (parse-elf bv))
         (section (elf-section-by-name elf ".modinfo"))
         (modinfo (section-contents elf section)))
    (map key=value->pair
         (nul-separated-string->list (utf8->string modinfo)))))

(define %not-comma
  (char-set-complement (char-set #\,)))

(define (module-formal-name file)
  "Return the module name of FILE as it appears in its info section.  Usually
the module name is the same as the base name of FILE, modulo hyphens and minus
the \".ko[.gz|.xz]\" extension."
  (match (assq 'name (modinfo-section-contents file))
    (('name . name) name)
    (#f #f)))

(define (module-dependencies file)
  "Return the list of modules that FILE depends on.  The returned list
contains module names, not actual file names."
  (let ((info (modinfo-section-contents file)))
    (match (assq 'depends info)
      (('depends . what)
       (string-tokenize what %not-comma)))))

(define not-softdep-whitespace
  (char-set-complement (char-set #\space #\tab)))

(define (module-soft-dependencies file)
  "Return the list of modules that can be preloaded, and then the list of
modules that can be postloaded, of the soft dependencies of module FILE."
  ;; TEXT: "pre: baz blubb foo post: bax bar"
  (define (parse-softdep text)
    (let loop ((value '())
               (tokens (string-tokenize text not-softdep-whitespace))
               (section #f))
      (match tokens
       ((token rest ...)
        (if (string=? (string-take-right token 1) ":") ; section
            (loop value rest (string-trim-both (string-drop-right token 1)))
            (loop (cons (cons section token) value) rest section)))
       (()
        value))))

  ;; Note: Multiple 'softdep sections are allowed.
  (let* ((info (modinfo-section-contents file))
         (entries (concatenate
                   (filter-map (match-lambda
                                (('softdep . value)
                                 (parse-softdep value))
                                (_ #f))
                               (modinfo-section-contents file)))))
    (let-values (((pres posts)
                  (partition (match-lambda
                              (("pre" . _) #t)
                              (("post" . _) #f))
                             entries)))
      (values (map (match-lambda
                    ((_ . value) value))
                   pres)
              (map (match-lambda
                    ((_ . value) value))
                   posts)))))

(define (module-aliases file)
  "Return the list of aliases of module FILE."
  (let ((info (modinfo-section-contents file)))
    (filter-map (match-lambda
                 (('alias . value)
                  value)
                 (_ #f))
                (modinfo-section-contents file))))

(define (strip-extension filename)
  (let ((extension (string-index filename #\.)))
    (if extension
        (string-take filename extension)
        filename)))

(define (dot-ko name compression)
  (let ((suffix (match compression
                  ('xz   ".ko.xz")
                  ('gzip ".ko.gz")
                  (else  ".ko"))))
    (string-append name suffix)))

(define (ensure-dot-ko name compression)
  "Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has
it."
  (if (string-contains name ".ko")
      name
      (dot-ko name compression)))

(define (normalize-module-name module)
  "Return the \"canonical\" name for MODULE, replacing hyphens with
underscores."
  ;; See 'modname_normalize' in libkmod.
  (string-map (lambda (chr)
                (case chr
                  ((#\-) #\_)
                  (else chr)))
              module))

(define (file-name->module-name file)
  "Return the module name corresponding to FILE, stripping the trailing
'.ko[.gz|.xz]' and normalizing it."
  (normalize-module-name (strip-extension (basename file))))

(define (find-module-file directory module)
  "Lookup module NAME under DIRECTORY, and return its absolute file name.
NAME can be a file name with or without '.ko', or it can be a module name.
Raise an error if it could not be found.

Module names can differ from file names in interesting ways; for instance,
module names usually (always?) use underscores as the inter-word separator,
whereas file names often, but not always, use hyphens.  Examples:
\"usb-storage.ko\", \"serpent_generic.ko\"."
  (define names
    ;; List of possible file names.  XXX: It would of course be cleaner to
    ;; have a database that maps module names to file names and vice versa,
    ;; but everyone seems to be doing hacks like this one.  Oh well!
    (delete-duplicates
     (list module
           (normalize-module-name module)
           (string-map (lambda (chr) ;converse of 'normalize-module-name'
                         (case chr
                           ((#\_) #\-)
                           (else chr)))
                       module))))

  (match (find-files directory
                     (lambda (file stat)
                       (member (strip-extension
                                (basename file)) names)))
    ((file)
     file)
    (()
     (error "kernel module not found" module directory))
    ((_ ...)
     (error "several modules by that name" module directory))))

(define* (recursive-module-dependencies files
                                        #:key (lookup-module dot-ko))
  "Return the topologically-sorted list of file names of the modules depended
on by FILES, recursively.  File names of modules are determined by applying
LOOKUP-MODULE to the module name."
  (let loop ((files   files)
             (result  '())
             (visited vlist-null))
    (match files
      (()
       (delete-duplicates (reverse result)))
      ((head . tail)
       (let* ((visited? (vhash-assoc head visited))
              (deps     (if visited?
                            '()
                            (map lookup-module (module-dependencies head))))
              (visited  (if visited?
                            visited
                            (vhash-cons head #t visited))))
         (loop (append deps tail)
               (append result deps) visited))))))

(define %not-newline
  (char-set-complement (char-set #\newline)))

(define (modules-loaded)
  "Return the list of names of currently loaded Linux modules."
  (let* ((contents (call-with-input-file "/proc/modules"
                     get-string-all))
         (lines    (string-tokenize contents %not-newline)))
    (match (map string-tokenize lines)
      (((modules . _) ...)
       modules))))

(define (module-black-list)
  "Return the black list of modules that must not be loaded.  This black list
is specified using 'modprobe.blacklist=MODULE1,MODULE2,...' on the kernel
command line; it is honored by libkmod for users that pass
'KMOD_PROBE_APPLY_BLACKLIST', which includes 'modprobe --use-blacklist' and
udev."
  (define parameter
    "modprobe.blacklist=")

  (let ((command (call-with-input-file "/proc/cmdline"
                   get-string-all)))
    (append-map (lambda (arg)
                  (if (string-prefix? parameter arg)
                      (string-tokenize (string-drop arg (string-length parameter))
                                       %not-comma)
                      '()))
                (string-tokenize command))))

(define (module-loaded? module)
  "Return #t if MODULE is already loaded.  MODULE must be a Linux module name,
not a file name."
  (member module (modules-loaded)))

(define* (load-linux-module* file
                             #:key
                             (recursive? #t)
                             (lookup-module dot-ko)
                             (black-list (module-black-list)))
  "Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true
on success, false otherwise.  When RECURSIVE? is true, load its dependencies
first (à la 'modprobe'.)  The actual files containing modules depended on are
obtained by calling LOOKUP-MODULE with the module name.  Modules whose name
appears in BLACK-LIST are not loaded."
  (define (black-listed? module)
    (let ((result (member module black-list)))
      (when result
        (format (current-module-debugging-port)
                "not loading module '~a' because it's black-listed~%"
                module))
      result))

  (define (load-dependencies file)
    (let ((dependencies (module-dependencies file)))
      (every (cut load-linux-module* <>
                  #:lookup-module lookup-module
                  #:black-list black-list)
             (map lookup-module dependencies))))

  (and (not (black-listed? (file-name->module-name file)))
       (or (not recursive?)
           (load-dependencies file))
       (let ((fd #f))
         (format (current-module-debugging-port)
                 "loading Linux module from '~a'...~%" file)

         (catch 'system-error
           (lambda ()
             (set! fd (open-fdes file O_RDONLY))
             (load-linux-module/fd fd)
             (close-fdes fd)
             #t)
           (lambda args
             ;; If this module was already loaded and we're in modprobe style, ignore
             ;; the error.
             (when fd (close-fdes fd))
             (or (and recursive? (= EEXIST (system-error-errno args)))
                 (apply throw args)))))))

(define (load-linux-modules-from-directory modules directory)
  "Load MODULES and their dependencies from DIRECTORY, a directory containing
the '.ko' files.  The '.ko' suffix is automatically added to MODULES if
needed."
  (define module-name->file-name
    (module-name-lookup directory))

  (for-each (lambda (module)
              (load-linux-module* (module-name->file-name module)
                                  #:lookup-module module-name->file-name))
            modules))

;;;
;;; Device modules.
;;;

;; Copied from (guix utils).  FIXME: Factorize.
(define (readlink* file)
  "Call 'readlink' until the result is not a symlink."
  (define %max-symlink-depth 50)

  (let loop ((file  file)
             (depth 0))
    (define (absolute target)
      (if (absolute-file-name? target)
          target
          (string-append (dirname file) "/" target)))

    (if (>= depth %max-symlink-depth)
        file
        (call-with-values
            (lambda ()
              (catch 'system-error
                (lambda ()
                  (values #t (readlink file)))
                (lambda args
                  (let ((errno (system-error-errno args)))
                    (if (or (= errno EINVAL))
                        (values #f file)
                        (apply throw args))))))
          (lambda (success? target)
            (if success?
                (loop (absolute target) (+ depth 1))
                file))))))

;; See 'major' and 'minor' in <sys/sysmacros.h>.

(define (stat->device-major st)
  (ash (logand #xfff00 (stat:rdev st)) -8))

(define (stat->device-minor st)
  (logand #xff (stat:rdev st)))

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

(define (read-uevent port)
  "Read a /sys 'uevent' file from PORT and return an alist where each car is a
key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
  (let loop ((result '()))
    (match (read-line port)
      ((? eof-object?)
       (reverse result))
      (line
       (loop (cons (key=value->pair line) result))))))

(define (device-module-aliases device)
  "Return the list of module aliases required by DEVICE, a /dev file name, as
in this example:

  (device-module-aliases \"/dev/sda\")
  => (\"scsi:t-0x00\" \"pci:v00008086d00009D03sv0000103Csd000080FAbc01sc06i01\")

The modules corresponding to these aliases can then be found using
'matching-modules'."
  ;; The approach is adapted from
  ;; <https://unix.stackexchange.com/questions/97676/how-to-find-the-driver-module-associated-with-a-device-on-linux>.
  (let* ((st        (stat device))
         (type      (stat:type st))
         (major     (stat->device-major st))
         (minor     (stat->device-minor st))
         (sys-name  (string-append "/sys/dev/"
                                   (case type
                                     ((block-special) "block")
                                     ((char-special)  "char")
                                     (else (symbol->string type)))
                                   "/" (number->string major) ":"
                                   (number->string minor)))
         (directory (canonicalize-path (readlink* sys-name))))
    (let loop ((components (string-tokenize directory %not-slash))
               (aliases    '()))
      (match components
        (("sys" "devices" _)
         (reverse aliases))
        ((head ... _)
         (let ((uevent (string-append (string-join components "/" 'prefix)
                                      "/uevent")))
           (if (file-exists? uevent)
               (let ((props (call-with-input-file uevent read-uevent)))
                 (match (assq-ref props 'MODALIAS)
                   (#f    (loop head aliases))
                   (alias (loop head (cons alias aliases)))))
               (loop head aliases))))))))

(define (read-module-aliases port)
  "Read from PORT data in the Linux 'modules.alias' file format.  Return a
list of alias/module pairs where each alias is a glob pattern as like the
result of:

  (string->compiled-sglob \"scsi:t-0x01*\")

and each module is a module name like \"snd_hda_intel\"."
  (define (comment? str)
    (string-prefix? "#" str))

  (define (tokenize str)
    ;; Lines have the form "alias ALIAS MODULE", where ALIAS can contain
    ;; whitespace.  This is why we don't use 'string-tokenize'.
    (let* ((str   (string-trim-both str))
           (left  (string-index str #\space))
           (right (string-rindex str #\space)))
      (list (string-take str left)
            (string-trim-both (substring str left right))
            (string-trim-both (string-drop str right)))))

  (let loop ((aliases '()))
    (match (read-line port)
      ((? eof-object?)
       (reverse aliases))
      ((? comment?)
       (loop aliases))
      (line
       (match (tokenize line)
         (("alias" alias module)
          (loop (alist-cons (string->compiled-sglob alias) module
                            aliases)))
         (()                                      ;empty line
          (loop aliases)))))))

(define (current-kernel-directory)
  "Return the directory of the currently running Linux kernel."
  (string-append (or (getenv "LINUX_MODULE_DIRECTORY")
                     "/run/booted-system/kernel/lib/modules")
                 "/" (utsname:release (uname))))

(define (current-alias-file)
  "Return the absolute file name of the default 'modules.alias' file."
  (string-append (current-kernel-directory) "/modules.alias"))

(define* (known-module-aliases #:optional (alias-file (current-alias-file)))
  "Return the list of alias/module pairs read from ALIAS-FILE.  Each alias is
actually a pattern."
  (call-with-input-file alias-file read-module-aliases))

(define* (matching-modules alias
                           #:optional (known-aliases (known-module-aliases)))
  "Return the list of modules that match ALIAS according to KNOWN-ALIASES.
ALIAS is a string like \"scsi:t-0x00\" as returned by
'device-module-aliases'."
  (filter-map (match-lambda
                ((pattern . module)
                 (and (glob-match? pattern alias)
                      module)))
              known-aliases))

(define* (missing-modules device modules-provided)
  "Assuming MODULES-PROVIDED lists kernel modules that are already
provided--e.g., in the initrd, return the list of missing kernel modules that
are required to access DEVICE."
  (define aliases
    ;; Attempt to load 'modules.alias' from the current kernel, assuming we're
    ;; on Guix System, and assuming that corresponds to the kernel we'll be
    ;; installing.
    (known-module-aliases))

  (if aliases
      (let* ((modules  (delete-duplicates
                        (append-map (cut matching-modules <> aliases)
                                    (device-module-aliases device))))

             ;; Module names (not file names) are supposed to use underscores
             ;; instead of hyphens.  MODULES is a list of module names, whereas
             ;; LINUX-MODULES is file names without '.ko', so normalize them.
             (provided (map file-name->module-name modules-provided)))
        (remove (cut member <> provided) modules))
      '()))

;;;
;;; Module databases.
;;;

(define* (module-name->file-name/guess directory name
                                       #:key compression)
  "Guess the file name corresponding to NAME, a module name.  That doesn't
always work because sometimes underscores in NAME map to hyphens (e.g.,
\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\").  If the module is
compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the
compression type."
  (string-append directory "/" (ensure-dot-ko name compression)))

(define (module-name-lookup directory)
  "Return a one argument procedure that takes a module name (e.g.,
\"input_leds\") and returns its absolute file name (e.g.,
\"/.../input-leds.ko\")."
  (define (guess-file-name name)
    (let ((names (list
                  (module-name->file-name/guess directory name)
                  (module-name->file-name/guess directory name
                                                #:compression 'xz)
                  (module-name->file-name/guess directory name
                                                #:compression 'gzip))))
      (or (find file-exists? names)
          (first names))))

  (catch 'system-error
    (lambda ()
      (define mapping
        (call-with-input-file (string-append directory "/modules.name")
          read))

      (lambda (name)
        (or (assoc-ref mapping name)
            (guess-file-name name))))
    (lambda args
      (if (= ENOENT (system-error-errno args))
          (cut guess-file-name <>)
          (apply throw args)))))

(define (write-module-name-database directory)
  "Write a database that maps \"module names\" as they appear in the relevant
ELF section of '.ko[.gz|.xz]' files, to actual file names.  This format is
Guix-specific.  It aims to deal with inconsistent naming, in particular
hyphens vs. underscores."
  (define mapping
    (map (lambda (file)
           (match (module-formal-name file)
             (#f   (cons (strip-extension (basename file)) file))
             (name (cons name file))))
         (find-files directory module-regex)))

  (call-with-output-file (string-append directory "/modules.name")
    (lambda (port)
      (display ";; Module name to file name mapping.
;;
;; This format is Guix-specific; it is not supported by upstream Linux tools.
\n"
               port)
      (pretty-print mapping port))))

(define (write-module-alias-database directory)
  "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
'modules.alias' file."
  (define aliases
    (map (lambda (file)
           (cons (file-name->module-name file) (module-aliases file)))
         (find-files directory module-regex)))

  (call-with-output-file (string-append directory "/modules.alias")
    (lambda (port)
      (display "# Aliases extracted from modules themselves.\n" port)
      (for-each (match-lambda
                  ((module . aliases)
                   (for-each (lambda (alias)
                               (format port "alias ~a ~a\n" alias module))
                             aliases)))
                aliases))))

(define (aliases->device-tuple aliases)
  "Traverse ALIASES, a list of module aliases, and search for
\"char-major-M-N\", \"block-major-M-N\", or \"devname:\" aliases.  When they
are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f."
  (define (char/block-major? alias)
    (or (string-prefix? "char-major-" alias)
        (string-prefix? "block-major-" alias)))

  (define (char/block-major->tuple alias)
    (match (string-tokenize alias %not-dash)
      ((type "major" (= string->number major) (= string->number minor))
       (list (match type
               ("char" "c")
               ("block" "b"))
             major minor))))

  (let* ((devname     (any (lambda (alias)
                             (and (string-prefix? "devname:" alias)
                                  (string-drop alias 8)))
                           aliases))
         (major/minor (match (find char/block-major? aliases)
                        (#f #f)
                        (str (char/block-major->tuple str)))))
    (and devname major/minor
         (cons devname major/minor))))

(define %not-dash
  (char-set-complement (char-set #\-)))

(define (write-module-device-database directory)
  "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
'modules.devname' file.  This file contains information about modules that can
be loaded on-demand, such as file system modules."
  (define aliases
    (filter-map (lambda (file)
                  (match (aliases->device-tuple (module-aliases file))
                    (#f #f)
                    (tuple (cons (file-name->module-name file) tuple))))
                (find-files directory module-regex)))

  (call-with-output-file (string-append directory "/modules.devname")
    (lambda (port)
      (display "# Device nodes to trigger on-demand module loading.\n" port)
      (for-each (match-lambda
                  ((module devname type major minor)
                   (format port "~a ~a ~a~a:~a~%"
                           module devname type major minor)))
                aliases))))

(define (depmod version directory)
  "Given an (existing) DIRECTORY, invoke depmod on it for
kernel version VERSION."
  (let ((destination-directory (string-append directory "/lib/modules/"
                                              version))
        ;; Note: "System.map" is an input file.
        (maps-file (string-append directory "/System.map"))
        ;; Note: "Module.symvers" is an input file.
        (symvers-file (string-append directory "/Module.symvers")))
    ;; These files will be regenerated by depmod below.
    (for-each (lambda (basename)
                (when (and (string-prefix? "modules." basename)
                           ;; Note: "modules.builtin" is an input file.
                           (not (string=? "modules.builtin" basename))
                           ;; Note: "modules.order" is an input file.
                           (not (string=? "modules.order" basename)))
                  (delete-file (string-append destination-directory "/"
                                              basename))))
              (scandir destination-directory))
    (invoke "depmod"
            "-e" ; Report symbols that aren't supplied
            ;"-w" ; Warn on duplicates
            "-b" directory
            "-F" maps-file
            ;"-E" symvers-file ; using both "-E" and "-F" is not possible.
            version)))

(define (make-linux-module-directory inputs version output)
  "Create a new directory OUTPUT and ensure that the directory
OUTPUT/lib/modules/VERSION can be used as a source of Linux
kernel modules for the first kmod in PATH now to eventually
load.  Take modules to put into OUTPUT from INPUTS.

Right now that means it creates @code{modules.*.bin} which
@command{modprobe} will use to find loadable modules."
  (union-build output inputs #:create-all-directories? #t)
  (depmod version output))

;;; linux-modules.scm ends here


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 locale)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (build-locale
            normalize-codeset
            locale->name+codeset
            read-supported-locales))

(define locale-rx
  ;; Regexp matching a locale line in 'localedata/SUPPORTED'.
  (make-regexp
   "^[[:space:]]*([[:graph:]]+)/([[:graph:]]+)[[:space:]]*\\\\$"))

(define (read-supported-locales port)
  "Read the 'localedata/SUPPORTED' file from PORT.  That file is actually a
makefile snippet, with one locale per line, and a header that can be
discarded."
  (let loop ((locales '()))
    (define line
      (read-line port))

    (cond ((eof-object? line)
           (reverse locales))
          ((string-prefix? "#" (string-trim line)) ;comment
           (loop locales))
          ((string-contains line "=")            ;makefile variable assignment
           (loop locales))
          (else
           (match (regexp-exec locale-rx line)
             (#f
              (loop locales))
             (m
              (loop (alist-cons (match:substring m 1)
                                (match:substring m 2)
                                locales))))))))

(define (normalize-codeset codeset)
  "Compute the \"normalized\" variant of CODESET."
  ;; info "(libc) Using gettextized software", for the algorithm used to
  ;; compute the normalized codeset.
  (letrec-syntax ((-> (syntax-rules ()
                        ((_ proc value)
                         (proc value))
                        ((_ proc rest ...)
                         (proc (-> rest ...))))))
    (-> (lambda (str)
          (if (string-every char-set:digit str)
              (string-append "iso" str)
              str))
        string-downcase
        (lambda (str)
          (string-filter char-set:letter+digit str))
        codeset)))

(define* (build-locale locale
                       #:key
                       (localedef "localedef")
                       (directory ".")
                       (codeset "UTF-8")
                       (name (string-append locale "." codeset)))
  "Compute locale data for LOCALE and CODESET--e.g., \"en_US\" and
\"UTF-8\"--with LOCALEDEF, and store it in DIRECTORY under NAME."
  (format #t "building locale '~a'...~%" name)
  (invoke localedef "--no-archive" "--prefix" directory
          "-i" locale "-f" codeset
          (string-append directory "/" name)))

(define (locale->name+codeset locale)
  "Split a locale name such as \"aa_ER@saaho.UTF-8\" into two values: the
language/territory/modifier part, and the codeset."
  (match (string-rindex locale #\.)
    (#f  (values locale #f))
    (dot (values (string-take locale dot)
                 (string-drop locale (+ dot 1))))))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@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 marionette)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:export (marionette?
            make-marionette
            marionette-eval
            wait-for-file
            wait-for-tcp-port
            wait-for-unix-socket
            marionette-control
            marionette-screen-text
            wait-for-screen-text
            %qwerty-us-keystrokes
            marionette-type))

;;; Commentary:
;;;
;;; Instrumentation tools for QEMU virtual machines (VMs).  A "marionette" is
;;; essentially a VM (a QEMU instance) with its monitor connected to a
;;; Unix-domain socket, and with a REPL inside the guest listening on a
;;; virtual console, which is itself connected to the host via a Unix-domain
;;; socket--these are the marionette's strings, connecting it to the almighty
;;; puppeteer.
;;;
;;; Code:

(define-record-type <marionette>
  (marionette command pid monitor repl)
  marionette?
  (command    marionette-command)                 ;list of strings
  (pid        marionette-pid)                     ;integer
  (monitor    marionette-monitor)                 ;port
  (repl       %marionette-repl))                  ;promise of a port

(define-syntax-rule (marionette-repl marionette)
  (force (%marionette-repl marionette)))

(define* (wait-for-monitor-prompt port #:key (quiet? #t))
  "Read from PORT until we have seen all of QEMU's monitor prompt.  When
QUIET? is false, the monitor's output is written to the current output port."
  (define full-prompt
    (string->list "(qemu) "))

  (let loop ((prompt full-prompt)
             (matches '())
             (prefix  '()))
    (match prompt
      (()
       ;; It's useful to set QUIET? so we don't display the echo of our own
       ;; commands.
       (unless quiet?
         (for-each (lambda (line)
                     (format #t "qemu monitor: ~a~%" line))
                   (string-tokenize (list->string (reverse prefix))
                                    (char-set-complement (char-set #\newline))))))
      ((chr rest ...)
       (let ((read (read-char port)))
         (cond ((eqv? read chr)
                (loop rest (cons read matches) prefix))
               ((eof-object? read)
                (error "EOF while waiting for QEMU monitor prompt"
                       (list->string (reverse prefix))))
               (else
                (loop full-prompt
                      '()
                      (cons read (append matches prefix))))))))))

(define* (make-marionette command
                          #:key (socket-directory "/tmp") (timeout 20))
  "Return a QEMU marionette--i.e., a virtual machine with open connections to the
QEMU monitor and to the guest's backdoor REPL."
  (define (file->sockaddr file)
    (make-socket-address AF_UNIX
                         (string-append socket-directory "/" file)))

  (define extra-options
    (list "-nographic"
          "-monitor" (string-append "unix:" socket-directory "/monitor")
          "-chardev" (string-append "socket,id=repl,path=" socket-directory
                                    "/repl")

          ;; See
          ;; <http://www.linux-kvm.org/page/VMchannel_Requirements#Invocation>.
          "-device" "virtio-serial"
          "-device" "virtserialport,chardev=repl,name=org.gnu.guix.port.0"))

  (define (accept* port)
    (match (select (list port) '() (list port) timeout)
      (((port) () ())
       (accept port))
      (_
       (error "timeout in 'accept'" port))))

  (let ((monitor (socket AF_UNIX SOCK_STREAM 0))
        (repl    (socket AF_UNIX SOCK_STREAM 0)))
    (bind monitor (file->sockaddr "monitor"))
    (listen monitor 1)
    (bind repl (file->sockaddr "repl"))
    (listen repl 1)

    (match (primitive-fork)
      (0
       (catch #t
         (lambda ()
           (close monitor)
           (close repl)
           (match command
             ((program . args)
              (apply execl program program
                     (append args extra-options)))))
         (lambda (key . args)
           (print-exception (current-error-port)
                            (stack-ref (make-stack #t) 1)
                            key args)
           (primitive-exit 1))))
      (pid
       (format #t "QEMU runs as PID ~a~%" pid)

       (match (accept* monitor)
         ((monitor-conn . _)
          (display "connected to QEMU's monitor\n")
          (close-port monitor)
          (wait-for-monitor-prompt monitor-conn)
          (display "read QEMU monitor prompt\n")

          (marionette (append command extra-options) pid
                      monitor-conn

                      ;; The following 'accept' call connects immediately, but
                      ;; we don't know whether the guest has connected until
                      ;; we actually receive the 'ready' message.
                      (match (accept* repl)
                        ((repl-conn . addr)
                         (display "connected to guest REPL\n")
                         (close-port repl)
                         ;; Delay reception of the 'ready' message so that the
                         ;; caller can already send monitor commands.
                         (delay
                           (match (read repl-conn)
                             ('ready
                              (display "marionette is ready\n")
                              repl-conn))))))))))))

(define (marionette-eval exp marionette)
  "Evaluate EXP in MARIONETTE's backdoor REPL.  Return the result."
  (match marionette
    (($ <marionette> command pid monitor (= force repl))
     (write exp repl)
     (newline repl)
     (read repl))))

(define* (wait-for-file file marionette
                        #:key (timeout 10) (read 'read))
  "Wait until FILE exists in MARIONETTE; READ its content and return it.  If
FILE has not shown up after TIMEOUT seconds, raise an error."
  (match (marionette-eval
          `(let loop ((i ,timeout))
             (cond ((file-exists? ,file)
                    (cons 'success (call-with-input-file ,file ,read)))
                   ((> i 0)
                    (sleep 1)
                    (loop (- i 1)))
                   (else
                    'failure)))
          marionette)
    (('success . result)
     result)
    ('failure
     (error "file didn't show up" file))))

(define* (wait-for-tcp-port port marionette
                            #:key (timeout 20))
  "Wait for up to TIMEOUT seconds for PORT to accept connections in
MARIONETTE.  Raise an error on failure."
  ;; Note: The 'connect' loop has to run within the guest because, when we
  ;; forward ports to the host, connecting to the host never raises
  ;; ECONNREFUSED.
  (match (marionette-eval
          `(begin
             (let ((sock (socket PF_INET SOCK_STREAM 0)))
               (let loop ((i 0))
                 (catch 'system-error
                   (lambda ()
                     (connect sock AF_INET INADDR_LOOPBACK ,port)
                     (close-port sock)
                     'success)
                   (lambda args
                     (if (< i ,timeout)
                         (begin
                           (sleep 1)
                           (loop (+ 1 i)))
                         'failure))))))
          marionette)
    ('success #t)
    ('failure
     (error "nobody's listening on port" port))))

(define* (wait-for-unix-socket file-name marionette
                                #:key (timeout 20))
  "Wait for up to TIMEOUT seconds for FILE-NAME, a Unix domain socket, to
accept connections in MARIONETTE.  Raise an error on failure."
  (match (marionette-eval
          `(begin
             (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
               (let loop ((i 0))
                 (catch 'system-error
                   (lambda ()
                     (connect sock AF_UNIX ,file-name)
                     (close-port sock)
                     'success)
                   (lambda args
                     (if (< i ,timeout)
                         (begin
                           (sleep 1)
                           (loop (+ 1 i)))
                         'failure))))))
          marionette)
    ('success #t)
    ('failure
     (error "nobody's listening on unix domain socket" file-name))))

(define (marionette-control command marionette)
  "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
pcsys_monitor\")."
  (match marionette
    (($ <marionette> _ _ monitor)
     (display command monitor)
     (newline monitor)
     ;; The "quit" command terminates QEMU immediately, with no output.
     (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))

(define* (marionette-screen-text marionette
                                 #:key
                                 (ocrad "ocrad"))
  "Take a screenshot of MARIONETTE, perform optical character
recognition (OCR), and return the text read from the screen as a string.  Do
this by invoking OCRAD (file name for GNU Ocrad's command)"
  (define (random-file-name)
    (string-append "/tmp/marionette-screenshot-"
                   (number->string (random (expt 2 32)) 16)
                   ".ppm"))

  (let ((image (random-file-name)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (marionette-control (string-append "screendump " image)
                            marionette)

        ;; Tell Ocrad to invert the image colors (make it black on white) and
        ;; to scale the image up, which significantly improves the quality of
        ;; the result.  In spite of this, be aware that OCR confuses "y" and
        ;; "V" and sometimes erroneously introduces white space.
        (let* ((pipe (open-pipe* OPEN_READ ocrad
                                 "-i" "-s" "10" image))
               (text (get-string-all pipe)))
          (unless (zero? (close-pipe pipe))
            (error "'ocrad' failed" ocrad))
          text))
      (lambda ()
        (false-if-exception (delete-file image))))))

(define* (wait-for-screen-text marionette predicate
                               #:key (timeout 30) (ocrad "ocrad"))
  "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
  (define start
    (car (gettimeofday)))

  (define end
    (+ start timeout))

  (let loop ()
    (if (> (car (gettimeofday)) end)
        (error "'wait-for-screen-text' timeout" predicate)
        (or (predicate (marionette-screen-text marionette #:ocrad ocrad))
            (begin
              (sleep 1)
              (loop))))))

(define %qwerty-us-keystrokes
  ;; Maps "special" characters to their keystrokes.
  '((#\newline . "ret")
    (#\space . "spc")
    (#\- . "minus")
    (#\+ . "shift-equal")
    (#\* . "shift-8")
    (#\= . "equal")
    (#\? . "shift-slash")
    (#\[ . "bracket_left")
    (#\] . "bracket_right")
    (#\{ . "shift-bracket_left")
    (#\} . "shift-bracket_right")
    (#\( . "shift-9")
    (#\) . "shift-0")
    (#\/ . "slash")
    (#\< . "shift-comma")
    (#\> . "shift-dot")
    (#\. . "dot")
    (#\, . "comma")
    (#\; . "semicolon")
    (#\' . "apostrophe")
    (#\" . "shift-apostrophe")
    (#\` . "grave_accent")
    (#\bs . "backspace")
    (#\tab . "tab")))

(define (character->keystroke chr keystrokes)
  "Return the keystroke for CHR according to the keyboard layout defined by
KEYSTROKES."
  (if (char-set-contains? char-set:upper-case chr)
      (string-append "shift-" (string (char-downcase chr)))
      (or (assoc-ref keystrokes chr)
          (string chr))))

(define* (string->keystroke-commands str
                                     #:optional
                                     (keystrokes
                                      %qwerty-us-keystrokes))
  "Return a list of QEMU monitor commands to send the keystrokes corresponding
to STR.  KEYSTROKES is an alist specifying a mapping from characters to
keystrokes."
  (string-fold-right (lambda (chr result)
                       (cons (string-append
                              "sendkey "
                              (character->keystroke chr keystrokes))
                             result))
                     '()
                     str))

(define* (marionette-type str marionette
                          #:key (keystrokes %qwerty-us-keystrokes))
  "Type STR on MARIONETTE's keyboard, using the KEYSTROKES alist to map characters
to actual keystrokes."
  (for-each (cut marionette-control <> marionette)
            (string->keystroke-commands str keystrokes)))

;;; marionette.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@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 secret-service)
  #:use-module (guix build utils)

  #:use-module (srfi srfi-26)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)

  #:export (secret-service-receive-secrets
            secret-service-send-secrets))

;;; Commentary:
;;;
;;; Utility procedures for copying secrets into a VM.
;;;
;;; Code:

(define-syntax log
  (lambda (s)
    "Log the given message."
    (syntax-case s ()
      ((_ fmt args ...)
       (with-syntax ((fmt (string-append "secret service: "
                                         (syntax->datum #'fmt))))
         ;; Log to the current output port.  That way, when
         ;; 'secret-service-send-secrets' is called from shepherd, output goes
         ;; to syslog.
         #'(format (current-output-port) fmt args ...))))))

(define* (secret-service-send-secrets port secret-root
                                      #:key (retry 60)
                                      (handshake-timeout 120))
  "Copy all files under SECRET-ROOT using TCP to secret-service listening at
local PORT.  If connect fails, sleep 1s and retry RETRY times; once connected,
wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
#f on failure."
  (define (file->file+size+mode file-name)
    (let ((stat (stat file-name))
          (target (substring file-name (string-length secret-root))))
      (list target (stat:size stat) (stat:mode stat))))

  (define (send-files sock)
    (let* ((files (if secret-root (find-files secret-root) '()))
           (files-sizes-modes (map file->file+size+mode files))
           (secrets `(secrets
                      (version 0)
                      (files ,files-sizes-modes))))
      (write secrets sock)
      (for-each (lambda (file)
                  (call-with-input-file file
                    (lambda (input)
                      (dump-port input sock))))
                files)))

  (log "sending secrets to ~a~%" port)
  (let ((sock (socket AF_INET SOCK_STREAM 0))
        (addr (make-socket-address AF_INET INADDR_LOOPBACK port)))
    ;; Connect to QEMU on the forwarded port.  The 'connect' call succeeds as
    ;; soon as QEMU is ready, even if there's no server listening on the
    ;; forward port inside the guest.
    (let loop ((retry retry))
      (catch 'system-error
        (cute connect sock addr)
        (lambda (key . args)
          (when (zero? retry)
            (apply throw key args))
          (log "retrying connection [~a attempts left]~%"
               (- retry 1))
          (sleep 1)
          (loop (1- retry)))))

    (log "connected; waiting for handshake...~%")

    ;; Wait for "hello" message from the server.  This is the only way to know
    ;; that we're really connected to the server inside the guest.
    (match (select (list sock) '() '() handshake-timeout)
      (((_) () ())
       (match (read sock)
         (('secret-service-server ('version version ...))
          (log "sending files from ~s...~%" secret-root)
          (send-files sock)
          (log "done sending files to port ~a~%" port)
          (close-port sock)
          secret-root)
         (x
          (log "invalid handshake ~s~%" x)
          (close-port sock)
          #f)))
      ((() () ())                                 ;timeout
       (log "timeout while sending files to ~a~%" port)
       (close-port sock)
       #f))))

(define (secret-service-receive-secrets port)
  "Listen to local PORT and wait for a secret service client to send secrets.
Write them to the file system.  Return the list of files installed on success,
and #f otherwise."

  (define (wait-for-client port)
    ;; Wait for a TCP connection on PORT.  Note: We cannot use the
    ;; virtio-serial ports, which would be safer, because they are
    ;; (presumably) unsupported on GNU/Hurd.
    (let ((sock (socket AF_INET SOCK_STREAM 0)))
      (bind sock AF_INET INADDR_ANY port)
      (listen sock 1)
      (log "waiting for secrets on port ~a...~%" port)
      (match (select (list sock) '() '() 60)
        (((_) () ())
         (match (accept sock)
           ((client . address)
            (log "client connection from ~a~%"
                 (inet-ntop (sockaddr:fam address)
                            (sockaddr:addr address)))

            ;; Send a "hello" message.  This allows the client running on the
            ;; host to know that it's now actually connected to server running
            ;; in the guest.
            (write '(secret-service-server (version 0)) client)
            (force-output client)
            (close-port sock)
            client)))
        ((() () ())
         (log "did not receive any secrets; time out~%")
         (close-port sock)
         #f))))

  ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size'
  ;; parameter.
  (define (dump in out size)
    ;; Copy SIZE bytes from IN to OUT.
    (define buf-size 65536)
    (define buf (make-bytevector buf-size))

    (let loop ((left size))
      (if (<= left 0)
          0
          (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
            (if (eof-object? read)
                left
                (begin
                  (put-bytevector out buf 0 read)
                  (loop (- left read))))))))

  (define (read-secrets port)
    ;; Read secret files from PORT and install them.
    (match (false-if-exception (read port))
      (('secrets ('version 0)
                 ('files ((files sizes modes) ...)))
       (for-each (lambda (file size mode)
                   (log "installing file '~a' (~a bytes)...~%"
                        file size)
                   (mkdir-p (dirname file))
                   (call-with-output-file file
                     (lambda (output)
                       (dump port output size)
                       (chmod file mode))))
                 files sizes modes)
       (log "received ~a secret files~%" (length files))
       files)
      (_
       (log "invalid secrets received~%")
       #f)))

  (let* ((port   (wait-for-client port))
         (result (and=> port read-secrets)))
    (when port
      (close-port port))
    result))

;;; secret-service.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Mathieu Othacehe <othacehe@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 shepherd)
  #:use-module (gnu system file-systems)
  #:use-module (gnu build linux-container)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (make-forkexec-constructor/container
            fork+exec-command/container))

;;; Commentary:
;;;
;;; This module provides extensions to the GNU Shepherd.  In particular, it
;;; provides a helper to start services in a container.
;;;
;;; Code:

(define (clean-up file)
  (when file
    (catch 'system-error
      (lambda ()
        (delete-file file))
      (lambda args
        (unless (= ENOENT (system-error-errno args))
          (apply throw args))))))

(define-syntax-rule (catch-system-error exp)
  (catch 'system-error
    (lambda ()
      exp)
    (const #f)))

(define (default-namespaces args)
  ;; Most daemons are here to talk to the network, and most of them expect to
  ;; run under a non-zero UID.
  (fold delq %namespaces '(net user)))

(define* (default-mounts #:key (namespaces (default-namespaces '())))
  (define (tmpfs directory)
    (file-system
      (device "none")
      (mount-point directory)
      (type "tmpfs")
      (check? #f)))

  (define accounts
    ;; This is for processes in the default user namespace but living in a
    ;; different mount namespace, so that they can lookup users.
    (list (file-system-mapping
           (source "/etc/passwd") (target source))
          (file-system-mapping
           (source "/etc/group") (target source))))

  (append (cons (tmpfs "/tmp") %container-file-systems)
          (let ((mappings `(,@(if (memq 'net namespaces)
                                  '()
                                  %network-file-mappings)
                            ,@(if (and (memq 'mnt namespaces)
                                       (not (memq 'user namespaces)))
                                  accounts
                                  '())

                            ;; Tell the process what timezone we're in.  This
                            ;; makes sure that, for instance, its syslog
                            ;; messages have the correct timestamp.
                            ,(file-system-mapping
                              (source "/etc/localtime")
                              (target source))

                            ,%store-mapping)))    ;XXX: coarse-grain
            (map file-system-mapping->bind-mount
                 (filter (lambda (mapping)
                           (file-exists? (file-system-mapping-source mapping)))
                         mappings)))))

;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
(module-autoload! (current-module)
                  '(shepherd service)
                  '(fork+exec-command read-pid-file exec-command
                    %precious-signals))
(module-autoload! (current-module)
                  '(shepherd system) '(unblock-signals))

(define* (read-pid-file/container pid pid-file #:key (max-delay 5))
  "Read PID-FILE in the container namespaces of PID, which exists in a
separate mount and PID name space.  Return the \"outer\" PID. "
  (match (container-excursion* pid
           (lambda ()
             (read-pid-file pid-file
                            #:max-delay max-delay)))
    (#f
     ;; Send SIGTERM to the whole process group.
     (catch-system-error (kill (- pid) SIGTERM))
     #f)
    ((? integer? container-pid)
     ;; XXX: When COMMAND is started in a separate PID namespace, its
     ;; PID is always 1, but that's not what Shepherd needs to know.
     pid)))

(define* (make-forkexec-constructor/container command
                                              #:key
                                              (namespaces
                                               (default-namespaces args))
                                              (mappings '())
                                              (user #f)
                                              (group #f)
                                              (log-file #f)
                                              pid-file
                                              (pid-file-timeout 5)
                                              (directory "/")
                                              (environment-variables
                                               (environ))
                                              #:rest args)
  "This is a variant of 'make-forkexec-constructor' that starts COMMAND in
NAMESPACES, a list of Linux namespaces such as '(mnt ipc).  MAPPINGS is the
list of <file-system-mapping> to make in the case of a separate mount
namespace, in addition to essential bind-mounts such /proc."
  (define container-directory
    (match command
      ((program _  ...)
       (string-append "/var/run/containers/" (basename program)))))

  (define auto-mappings
    `(,@(if log-file
            (list (file-system-mapping
                   (source log-file)
                   (target source)
                   (writable? #t)))
            '())))

  (define mounts
    (append (map file-system-mapping->bind-mount
                 (append auto-mappings mappings))
            (default-mounts #:namespaces namespaces)))

  (lambda args
    (mkdir-p container-directory)

    (when log-file
      ;; Create LOG-FILE so we can map it in the container.
      (unless (file-exists? log-file)
        (call-with-output-file log-file (const #t))
        (when user
          (let ((pw (getpwnam user)))
            (chown log-file (passwd:uid pw) (passwd:gid pw))))))

    (let ((pid (run-container container-directory
                              mounts namespaces 1
                              (lambda ()
                                ;; First restore the default handlers.
                                (for-each (cut sigaction <> SIG_DFL)
                                          %precious-signals)

                                ;; Unblock any signals that have been blocked
                                ;; by the parent process.
                                (unblock-signals %precious-signals)

                                (mkdir-p "/var/run")
                                (clean-up pid-file)

                                (exec-command command
                                              #:user user
                                              #:group group
                                              #:log-file log-file
                                              #:directory directory
                                              #:environment-variables
                                              environment-variables)))))
      (if pid-file
          (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
              (read-pid-file/container pid pid-file
                                       #:max-delay pid-file-timeout)
              (read-pid-file pid-file #:max-delay pid-file-timeout))
          pid))))

(define* (fork+exec-command/container command
                                      #:key pid
                                      #:allow-other-keys
                                      #:rest args)
  "This is a variant of 'fork+exec-command' procedure, that joins the
namespaces of process PID beforehand.  If there is no support for containers,
on Hurd systems for instance, fallback to direct forking."
  (define (strip-pid args)
    ;; TODO: Replace with 'strip-keyword-arguments' when that no longer pulls
    ;; in (guix config).
    (let loop ((args args)
               (result '()))
      (match args
        (()
         (reverse result))
        ((#:pid _ . rest)
         (loop rest result))
        ((head . rest)
         (loop rest (cons head result))))))

  (let ((container-support?
         (file-exists? "/proc/self/ns"))
        (fork-proc (lambda ()
                     (apply fork+exec-command command
                            (strip-pid args)))))
    (if container-support?
        (container-excursion* pid fork-proc)
        (fork-proc))))

;; Local Variables:
;; eval: (put 'container-excursion* 'scheme-indent-function 1)
;; End:

;;; shepherd.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Andy Wingo <wingo@igalia.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 svg)
  #:use-module (rsvg)
  #:use-module (cairo)
  #:use-module (srfi srfi-11)
  #:export (svg->png))

(define* (downscaled-surface surface
                             #:key
                             source-width source-height
                             width height)
  "Return a new rendering context where SURFACE is scaled to WIDTH x HEIGHT."
  (let ((cr (cairo-create (cairo-image-surface-create 'argb32
                                                      width height))))
    (cairo-scale cr (/ width source-width) (/ height source-height))
    (cairo-set-source-surface cr surface 0 0)
    (cairo-pattern-set-filter (cairo-get-source cr) 'best)
    (cairo-rectangle cr 0 0 source-width source-height)
    (cairo-fill cr)
    cr))

(define* (svg->png in-svg out-png
                   #:key width height)
  "Render the file at IN-SVG as a PNG file in OUT-PNG.  When WIDTH and HEIGHT
are provided, use them as the dimensions of OUT-PNG; otherwise preserve the
dimensions of IN-SVG."
  (define svg
    (rsvg-handle-new-from-file in-svg))

  (let-values (((origin-width origin-height em ex)
                (rsvg-handle-get-dimensions svg)))
    (let* ((surf (cairo-image-surface-create 'argb32
                                             origin-width origin-height))
           (cr   (cairo-create surf)))
      (rsvg-handle-render-cairo svg cr)
      (cairo-surface-flush surf)
      (let ((cr (if (and width height
                         (not (= width origin-width))
                         (not (= height origin-height)))
                    (downscaled-surface surf
                                        #:source-width origin-width
                                        #:source-height origin-height
                                        #:width width
                                        #:height height)
                    cr)))
        (cairo-surface-write-to-png (cairo-get-target cr) out-png)))))

;;; svg.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 vm)
  #:use-module (guix build utils)
  #:use-module (guix build store-copy)
  #:use-module (guix build syscalls)
  #:use-module (guix store database)
  #:use-module (gnu build bootloader)
  #:use-module (gnu build linux-boot)
  #:use-module (gnu build install)
  #:use-module (gnu system uuid)
  #:use-module (guix records)
  #:use-module ((guix combinators) #:select (fold2))
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 popen)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:export (qemu-command
            load-in-linux-vm
            format-partition

            partition
            partition?
            partition-device
            partition-size
            partition-file-system
            partition-label
            partition-flags
            partition-initializer

            estimated-partition-size
            root-partition-initializer
            initialize-partition-table
            initialize-hard-disk))

;;; Commentary:
;;;
;;; This module provides supporting code to run virtual machines and build
;;; virtual machine images using QEMU.
;;;
;;; Code:

(define* (qemu-command #:optional (system %host-type))
  "Return the default name of the QEMU command for SYSTEM."
  (let ((cpu (substring system 0
                        (string-index system #\-))))
    (string-append "qemu-system-"
                   (cond
                    ((string-match "^i[3456]86$" cpu) "i386")
                    ((string-match "armhf" cpu) "arm")
                    (else cpu)))))

(define* (load-in-linux-vm builder
                           #:key
                           output
                           (qemu (qemu-command)) (memory-size 512)
                           linux initrd
                           make-disk-image?
                           single-file-output?
                           (disk-image-size (* 100 (expt 2 20)))
                           (disk-image-format "qcow2")
                           (references-graphs '()))
  "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
the result to OUTPUT.  If SINGLE-FILE-OUTPUT? is true, copy a single file from
/xchg to OUTPUT.  Otherwise, copy the contents of /xchg to a new directory
OUTPUT.

When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
access it via /dev/hda.

REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
the #:references-graphs parameter of 'derivation'."

  (define target-arm32?
    (string-prefix? "arm-" %host-type))

  (define target-aarch64?
    (string-prefix? "aarch64-" %host-type))

  (define target-arm?
    (or target-arm32? target-aarch64?))

  (define arch-specific-flags
    `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
      ;; hardware limits imposed by other machines.
      ,@(if target-arm?
            '("-M" "virt")
            '())

      ;; On ARM32, if the kernel is built without LPAE support, ECAM conflicts
      ;; with VIRT_PCIE_MMIO causing PCI devices not to show up.  Disable
      ;; explicitely highmem to fix it.
      ;; See: https://bugs.launchpad.net/qemu/+bug/1790975.
      ,@(if target-arm32?
            '("-machine" "highmem=off")
            '())

      ;; Only enable kvm if we see /dev/kvm exists.  This allows users without
      ;; hardware virtualization to still use these commands.  KVM support is
      ;; still buggy on some ARM boards. Do not use it even if available.
      ,@(if (and (file-exists? "/dev/kvm")
                 (not target-arm?))
            '("-enable-kvm")
            '())

      ;; Pass "panic=1" so that the guest dies upon error.
      "-append"
      ,(string-append "panic=1 --load=" builder

                      ;; The serial port name differs between emulated
                      ;; architectures/machines.
                      " console="
                      (if target-arm? "ttyAMA0" "ttyS0"))))

  (when make-disk-image?
    (format #t "creating ~a image of ~,2f MiB...~%"
            disk-image-format (/ disk-image-size (expt 2 20)))
    (force-output)
    (invoke "qemu-img" "create" "-f" disk-image-format output
             (number->string disk-image-size)))

  (mkdir "xchg")
  (mkdir "tmp")

  (match references-graphs
    ((graph-files ...)
     ;; Copy the reference-graph files under xchg/ so EXP can access it.
     (map (lambda (file)
            (copy-file file (string-append "xchg/" file)))
          graph-files))
    (_ #f))

  (apply invoke qemu "-nographic" "-no-reboot"
         ;; CPU "max" behaves as "host" when KVM is enabled, and like a system
         ;; CPU with the maximum possible feature set otherwise.
         "-cpu" "max"
         "-m" (number->string memory-size)
         "-nic" "user,model=virtio-net-pci"
         "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
         "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
         "-virtfs"
         (string-append "local,id=store_dev,path="
                        (%store-directory)
                        ",security_model=none,mount_tag=store")
         "-virtfs"
         (string-append "local,id=xchg_dev,path=xchg"
                        ",security_model=none,mount_tag=xchg")
         "-virtfs"
         ;; Some programs require more space in /tmp than is normally
         ;; available in the guest.  Accommodate such programs by sharing a
         ;; temporary directory.
         (string-append "local,id=tmp_dev,path=tmp"
                        ",security_model=none,mount_tag=tmp")
         "-kernel" linux
         "-initrd" initrd
         (append
          (if make-disk-image?
              `("-device" "virtio-blk,drive=myhd"
                "-drive" ,(string-append "if=none,file=" output
                                         ",format=" disk-image-format
                                         ",id=myhd"))
              '())
          arch-specific-flags))

  (unless (file-exists? "xchg/.exit-status")
    (error "VM did not produce an exit code"))

  (match (call-with-input-file "xchg/.exit-status" read)
    (0 #t)
    (status (error "guest VM code exited with a non-zero status" status)))

  (delete-file "xchg/.exit-status")

  ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
  (unless make-disk-image?
    (if single-file-output?
        (let ((graph? (lambda (name stat)
                        (member (basename name) references-graphs))))
          (match (find-files "xchg" (negate graph?))
            ((result)
             (copy-file result output))
            (x
             (error "did not find a single result file" x))))
        (begin
          (mkdir output)
          (copy-recursively "xchg" output)))))

(define* (register-closure prefix closure
                           #:key
                           (schema (sql-schema)))
  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
produced by #:references-graphs."
  (let ((items (call-with-input-file closure read-reference-graph)))
    (parameterize ((sql-schema schema))
      (with-database (store-database-file #:prefix prefix) db
        (register-items db items
                        #:prefix prefix
                        #:registration-time %epoch)))))

;;;
;;; Partitions.
;;;

(define-record-type* <partition> partition make-partition
  partition?
  (device      partition-device (default #f))
  (size        partition-size)
  (file-system partition-file-system (default "ext4"))
  (file-system-options partition-file-system-options ;passed to 'mkfs.FS'
                       (default '()))
  (label       partition-label (default #f))
  (uuid        partition-uuid (default #f))
  (flags       partition-flags (default '()))
  (initializer partition-initializer (default (const #t))))

(define (estimated-partition-size graphs)
  "Return the estimated size of a partition that can store the store items
given by GRAPHS, a list of file names produced by #:references-graphs."
  ;; Simply add a 25% overhead.
  (round (* 1.25 (closure-size graphs))))

(define* (initialize-partition-table device partitions
                                     #:key
                                     (label-type "msdos")
                                     (offset (expt 2 20)))
  "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
PARTITIONS (a list of <partition> objects), starting at OFFSET bytes.  On
success, return PARTITIONS with their 'device' field changed to reflect their
actual /dev name based on DEVICE."
  (define (partition-options part offset index)
    (cons* "mkpart" "primary" "ext2"
           (format #f "~aB" offset)
           (format #f "~aB" (+ offset (partition-size part)))
           (append-map (lambda (flag)
                         (list "set" (number->string index)
                               (symbol->string flag) "on"))
                       (partition-flags part))))

  (define (options partitions offset)
    (let loop ((partitions partitions)
               (offset     offset)
               (index      1)
               (result     '()))
      (match partitions
        (()
         (concatenate (reverse result)))
        ((head tail ...)
         (loop tail
               ;; Leave one sector (512B) between partitions to placate
               ;; Parted.
               (+ offset 512 (partition-size head))
               (+ 1 index)
               (cons (partition-options head offset index)
                     result))))))

  (format #t "creating partition table with ~a partitions (~a)...\n"
          (length partitions)
          (string-join (map (compose (cut string-append <> " MiB")
                                     number->string
                                     (lambda (size)
                                       (round (/ size (expt 2. 20))))
                                     partition-size)
                            partitions)
                       ", "))
  (apply invoke "parted" "--script"
         device "mklabel" label-type
         (options partitions offset))

  ;; Set the 'device' field of each partition.
  (reverse
   (fold2 (lambda (part result index)
            (values (cons  (partition
                            (inherit part)
                            (device (string-append device
                                                   (number->string index))))
                           result)
                    (+ 1 index)))
          '()
          1
          partitions)))

(define MS_BIND 4096)                             ; <sys/mounts.h> again!

(define* (create-ext-file-system partition type
                                 #:key label uuid (options '()))
  "Create an ext-family file system of TYPE on PARTITION.  If LABEL is true,
use that as the volume name.  If UUID is true, use it as the partition UUID."
  (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
          type label (and uuid (uuid->string uuid)))
  (apply invoke (string-append "mkfs." type)
         "-F" partition
         `(,@(if label
                 `("-L" ,label)
                 '())
           ,@(if uuid
                 `("-U" ,(uuid->string uuid))
                 '())
           ,@options)))

(define* (create-fat-file-system partition
                                 #:key label uuid (options '()))
  "Create a FAT file system on PARTITION.  The number of File Allocation Tables
will be determined based on file system size.  If LABEL is true, use that as the
volume name."
  ;; FIXME: UUID is ignored!
  (format #t "creating FAT partition...\n")
  (apply invoke "mkfs.fat" partition
         (append (if label `("-n" ,label) '()) options)))

(define* (format-partition partition type
                           #:key label uuid (options '()))
  "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
volume name.  Options is a list of command-line options passed to 'mkfs.FS'."
  (cond ((string-prefix? "ext" type)
         (create-ext-file-system partition type #:label label #:uuid uuid
                                 #:options options))
        ((or (string-prefix? "fat" type) (string= "vfat" type))
         (create-fat-file-system partition #:label label #:uuid uuid
                                 #:options options))
        (else (error "Unsupported file system."))))

(define (initialize-partition partition)
  "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
it, run its initializer, and unmount it."
  (let ((target "/fs"))
   (format-partition (partition-device partition)
                     (partition-file-system partition)
                     #:label (partition-label partition)
                     #:uuid (partition-uuid partition)
                     #:options (partition-file-system-options partition))
   (mkdir-p target)
   (mount (partition-device partition) target
          (partition-file-system partition))

   ((partition-initializer partition) target)

   (umount target)
   partition))

(define* (root-partition-initializer #:key (closures '())
                                     copy-closures?
                                     (register-closures? #t)
                                     system-directory
                                     (deduplicate? #t)
                                     (make-device-nodes
                                      make-essential-device-nodes)
                                     (extra-directives '()))
  "Return a procedure to initialize a root partition.

If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
store.  If DEDUPLICATE? is true, then also deduplicate files common to
CLOSURES and the rest of the store when registering the closures.  If
COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation.

EXTRA-DIRECTIVES is an optional list of directives to populate the root file
system that is passed to 'populate-root-file-system'."
  (lambda (target)
    (define target-store
      (string-append target (%store-directory)))

    (when copy-closures?
      ;; Populate the store.
      (populate-store (map (cut string-append "/xchg/" <>) closures)
                      target
                      #:deduplicate? deduplicate?))

    ;; Populate /dev.
    (make-device-nodes target)

    ;; Optionally, register the inputs in the image's store.
    (when register-closures?
      (unless copy-closures?
        ;; XXX: 'register-closure' wants to palpate the things it registers, so
        ;; bind-mount the store on the target.
        (mkdir-p target-store)
        (mount (%store-directory) target-store "" MS_BIND))

      (display "registering closures...\n")
      (for-each (lambda (closure)
                  (register-closure target
                                    (string-append "/xchg/" closure)))
                closures)
      (unless copy-closures?
        (umount target-store)))

    ;; Add the non-store directories and files.
    (display "populating...\n")
    (populate-root-file-system system-directory target
                               #:extras extra-directives)

    ;; 'register-closure' resets timestamps and everything, so no need to do it
    ;; once more in that case.
    (unless register-closures?
      ;; 'reset-timestamps' also resets file permissions; do that everywhere
      ;; except on /dev so that /dev/null remains writable, etc.
      (for-each (lambda (directory)
                  (reset-timestamps (string-append target "/" directory)))
                (scandir target
                         (match-lambda
                           ((or "." ".." "dev") #f)
                           (_ #t))))
      (reset-timestamps (string-append target "/dev")
                        #:preserve-permissions? #t))))

(define (register-bootcfg-root target bootcfg)
  "On file system TARGET, register BOOTCFG as a GC root."
  (let ((directory (string-append target "/var/guix/gcroots")))
    (mkdir-p directory)
    (symlink bootcfg (string-append directory "/bootcfg"))))

(define* (initialize-hard-disk device
                               #:key
                               bootloader-package
                               bootcfg
                               bootcfg-location
                               bootloader-installer
                               (grub-efi #f)
                               (partitions '()))
  "Initialize DEVICE as a disk containing all the <partition> objects listed
in PARTITIONS, and using BOOTCFG as its bootloader configuration file.

Each partition is initialized by calling its 'initializer' procedure,
passing it a directory name where it is mounted."

  (define (partition-bootable? partition)
    "Return the first partition found with the boot flag set."
    (member 'boot (partition-flags partition)))

  (define (partition-esp? partition)
    "Return the first EFI System Partition."
    (member 'esp (partition-flags partition)))

  (let* ((partitions (initialize-partition-table device partitions))
         (root       (find partition-bootable? partitions))
         (esp        (find partition-esp? partitions))
         (target     "/fs"))
    (unless root
      (error "no bootable partition specified" partitions))

    (for-each initialize-partition partitions)

    (display "mounting root partition...\n")
    (mkdir-p target)
    (mount (partition-device root) target (partition-file-system root))
    (install-boot-config bootcfg bootcfg-location target)
    (when bootloader-installer
      (display "installing bootloader...\n")
      (bootloader-installer bootloader-package device target))

    (when esp
      ;; Mount the ESP somewhere and install GRUB UEFI image.
      (let ((mount-point (string-append target "/boot/efi")))
        (display "mounting EFI system partition...\n")
        (mkdir-p mount-point)
        (mount (partition-device esp) mount-point
               (partition-file-system esp))

        (display "creating EFI firmware image...")
        (install-efi-loader grub-efi mount-point)
        (display "done.\n")

        (umount mount-point)))

    ;; Register BOOTCFG as a GC root.
    (register-bootcfg-root target bootcfg)

    (umount target)))

;;; vm.scm ends here