;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013-2020, 2022, 2023 Ludovic Courtès ;;; Copyright © 2016 Alex Griffin ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2020, 2023 Efraim Flashner ;;; Copyright © 2020 Maxim Cournoyer ;;; ;;; 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 w
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.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 tests linux-modules)
  #:use-module (gnu packages linux)
  #:use-module (gnu services)
  #:use-module (gnu services linux)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu tests)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:export (%test-loadable-kernel-modules-0
            %test-loadable-kernel-modules-1
            %test-loadable-kernel-modules-2
            %test-loadable-kernel-modules-service-0
            %test-loadable-kernel-modules-service-1
            %test-loadable-kernel-modules-service-2))

;;; Commentary:
;;;
;;; Test <operating-system> kernel-loadable-modules.
;;;
;;; Code:

(define* (modules-loaded?-program os modules)
  "Return an executable store item that, upon being evaluated, will verify
that MODULES are actually loaded."
  (program-file
   "verify-kernel-modules-loaded.scm"
   #~(begin
     (use-modules (ice-9 rdelim)
                  (ice-9 popen)
                  (srfi srfi-1)
                  (srfi srfi-13))
     (let* ((port (open-input-pipe (string-append #$kmod "/bin/lsmod")))
            (lines (string-split (read-string port) #\newline))
            (separators (char-set #\space #\tab))
            (modules (map (lambda (line)
                            (string-take line
                                         (or (string-index line separators)
                                             0)))
                          lines))
            (status (close-pipe port)))
       (and (= status 0)
            (and-map (lambda (module)
                       (member module modules string=?))
                     '#$modules))))))

(define* (run-loadable-kernel-modules-test-base base-os module-names)
  "Run a test of BASE-OS, verifying that MODULE-NAMES are loaded in memory."
  (define os
    (marionette-operating-system
     base-os
     #:imported-modules '((guix combinators))))

  (define vm (virtual-machine os))

  (define (test script)
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64))

          (define marionette
            (make-marionette (list #$vm)))

          (test-runner-current (system-test-runner #$output))
          (test-begin "loadable-kernel-modules")
          (test-assert "script successfully evaluated"
            (marionette-eval
             '(primitive-load #$script)
             marionette))
          (test-end))))

  (gexp->derivation "loadable-kernel-modules"
                    (test (modules-loaded?-program os module-names))))

(define* (run-loadable-kernel-modules-test module-packages module-names)
  "Run a test of an OS having MODULE-PACKAGES, and verify that MODULE-NAMES
are loaded in memory."
  (run-loadable-kernel-modules-test-base
    (operating-system
      (inherit (simple-operating-system))
      (services (cons (service kernel-module-loader-service-type module-names)
                      (operating-system-user-services
                       (simple-operating-system))))
      (kernel-loadable-modules module-packages))
    module-names))

(define* (run-loadable-kernel-modules-service-test module-packages module-names)
  "Run a test of an OS having MODULE-PACKAGES, which are loaded by creating a
service that extends LINUXL-LOADABLE-MODULE-SERVICE-TYPE. Then verify that
MODULE-NAMES are loaded in memory."
  (run-loadable-kernel-modules-test-base
    (operating-system
      (inherit (simple-operating-system))
      (services (cons* (simple-service 'installing-module
                                       linux-loadable-module-service-type
                                       module-packages)
                       (service kernel-module-loader-service-type module-names)
                       (operating-system-user-services
                        (simple-operating-system)))))
    module-names))

(define %test-loadable-kernel-modules-0
  (system-test
   (name "loadable-kernel-modules-0")
   (description "Tests loadable kernel modules facility of <operating-system>
with no extra modules.")
   (value (run-loadable-kernel-modules-test '() '()))))

(define %test-loadable-kernel-modules-1
  (system-test
   (name "loadable-kernel-modules-1")
   (description "Tests loadable kernel modules facility of <operating-system>
with one extra module.")
   (value (run-loadable-kernel-modules-test
           (list ddcci-driver-linux)
           '("ddcci")))))

(define %test-loadable-kernel-modules-2
  (system-test
   (name "loadable-kernel-modules-2")
   (description "Tests loadable kernel modules facility of <operating-system>
with two extra modules.")
   (value (run-loadable-kernel-modules-test
           (list acpi-call-linux-module
                 (package
                   (inherit ddcci-driver-linux)
                   (arguments
                    `(#:linux #f
                      ,@(strip-keyword-arguments '(#:linux)
                                                 (package-arguments
                                                  ddcci-driver-linux))))))
           '("acpi_call" "ddcci")))))

(define %test-loadable-kernel-modules-service-0
  (system-test
   (name "loadable-kernel-modules-service-0")
   (description "Tests loadable kernel modules extensible service with no
extra modules.")
   (value (run-loadable-kernel-modules-service-test '() '()))))

(define %test-loadable-kernel-modules-service-1
  (system-test
   (name "loadable-kernel-modules-service-1")
   (description "Tests loadable kernel modules extensible service with one
extra module.")
   (value (run-loadable-kernel-modules-service-test
           (list ddcci-driver-linux)
           '("ddcci")))))

(define %test-loadable-kernel-modules-service-2
  (system-test
   (name "loadable-kernel-modules-service-2")
   (description "Tests loadable kernel modules extensible service with two
extra modules.")
   (value (run-loadable-kernel-modules-service-test
           (list acpi-call-linux-module
                 (package
                   (inherit ddcci-driver-linux)
                   (arguments
                    `(#:linux #f
                      ,@(strip-keyword-arguments '(#:linux)
                                                 (package-arguments
                                                  ddcci-driver-linux))))))
           '("acpi_call" "ddcci")))))
generated by cgit
ates} through the internal use of hash tables." (let loop ((list list) ;; We actually modify table in-place, but still allocate it here ;; so that we only need one level of indentation. (table (make-hash-table))) (match list (() (hash-fold (lambda (key value seed) (if (> value 1) (cons key seed) seed)) '() table)) ((first . rest) (hash-set! table first (1+ (hash-ref table first 0))) (loop rest table))))) (define (assert-unique-account-names users) (match (find-duplicates (map user-account-name users)) (() *unspecified*) (duplicates (warning (G_ "the following accounts appear more than once:~{ ~a~}~%") duplicates)))) (define (assert-unique-group-names groups) (match (find-duplicates (map user-group-name groups)) (() *unspecified*) (duplicates (warning (G_ "the following groups appear more than once:~{ ~a~}~%") duplicates)))) (define (assert-valid-users/groups users groups) "Raise an error if USERS refer to groups not listed in GROUPS." (let ((groups (list->set (map user-group-name groups)))) (define (validate-supplementary-group user group) (unless (set-contains? groups group) (raise (condition (&message (message (format #f (G_ "supplementary group '~a' \ of user '~a' is undeclared") group (user-account-name user)))))))) (for-each (lambda (user) (unless (set-contains? groups (user-account-group user)) (raise (condition (&message (message (format #f (G_ "primary group '~a' \ of user '~a' is undeclared") (user-account-group user) (user-account-name user))))))) (for-each (cut validate-supplementary-group user <>) (user-account-supplementary-groups user))) users))) ;;; ;;; Service. ;;; (define (user-group->gexp group) "Turn GROUP, a object, into a list-valued gexp suitable for 'active-groups'." #~(list #$(user-group-name group) #$(user-group-password group) #$(user-group-id group) #$(user-group-system? group))) (define (user-account->gexp account) "Turn ACCOUNT, a object, into a list-valued gexp suitable for 'activate-users'." #~`(#$(user-account-name account) #$(user-account-uid account) #$(user-account-group account) #$(user-account-supplementary-groups account) #$(user-account-comment account) #$(user-account-home-directory account) #$(user-account-create-home-directory? account) ,#$(user-account-shell account) ; this one is a gexp #$(user-account-password account) #$(user-account-system? account))) (define (account-activation accounts+groups) "Return a gexp that activates ACCOUNTS+GROUPS, a list of and objects. Raise an error if a user account refers to a undefined group." (define accounts (delete-duplicates (filter user-account? accounts+groups) eq?)) (define user-specs (map user-account->gexp accounts)) (define groups (delete-duplicates (filter user-group? accounts+groups) eq?)) (define group-specs (map user-group->gexp groups)) (assert-unique-account-names accounts) (assert-unique-group-names groups) (assert-valid-users/groups accounts groups) ;; Add users and user groups. (with-imported-modules (source-module-closure '((gnu system accounts))) #~(begin (use-modules (gnu system accounts)) (activate-users+groups (map sexp->user-account (list #$@user-specs)) (map sexp->user-group (list #$@group-specs)))))) (define (account-shepherd-service accounts+groups) "Return a Shepherd service that creates the home directories for the user accounts among ACCOUNTS+GROUPS." (define accounts (filter user-account? accounts+groups)) ;; Create home directories only once 'file-systems' is up. This makes sure ;; they are created in the right place if /home lives on a separate ;; partition. ;; ;; XXX: We arrange for this service to stop right after it's done its job so ;; that 'guix system reconfigure' knows that it can reload it fearlessly ;; (and thus create new home directories). (list (shepherd-service (requirement '(file-systems)) (provision '(user-homes)) (one-shot? #t) (modules '((gnu build activation) (gnu system accounts))) (start (with-imported-modules (source-module-closure '((gnu build activation) (gnu system accounts))) #~(lambda () (activate-user-home (map sexp->user-account (list #$@(map user-account->gexp accounts)))) #t))) ;success (documentation "Create user home directories.")))) (define (shells-file shells) "Return a file-like object that builds a shell list for use as /etc/shells based on SHELLS. /etc/shells is used by xterm, polkit, and other programs." (computed-file "shells" #~(begin (use-modules (srfi srfi-1)) (define shells (delete-duplicates (list #$@shells))) (call-with-output-file #$output (lambda (port) (display "\ /bin/sh /run/current-system/profile/bin/sh /run/current-system/profile/bin/bash\n" port) (for-each (lambda (shell) (display shell port) (newline port)) shells)))))) (define (etc-files arguments) "Filter out among ARGUMENTS things corresponding to skeletons, and return the /etc/skel directory for those." (let ((skels (filter pair? arguments)) (users (filter user-account? arguments))) `(("skel" ,(skeleton-directory skels)) ("shells" ,(shells-file (map user-account-shell users)))))) (define account-service-type (service-type (name 'account) ;; Concatenate , , and skeleton ;; lists. (compose concatenate) (extend append) (extensions (list (service-extension activation-service-type account-activation) (service-extension shepherd-root-service-type account-shepherd-service) ;; Have 'user-processes' depend on 'user-homes' so that ;; daemons start after their home directory has been ;; created. (service-extension user-processes-service-type (const '(user-homes))) (service-extension etc-service-type etc-files))) (default-value '()) (description "Ensure the specified user accounts and groups exist, as well as each account home directory."))) (define (account-service accounts+groups skeletons) "Return a that takes care of user accounts and user groups, with ACCOUNTS+GROUPS as its initial list of accounts and groups." (service account-service-type (append skeletons accounts+groups))) ;;; shadow.scm ends here