gnu: Move helper code to (gnu system …) modules.

* gnu/packages/grub.scm (<menu-entry>, grub-configuration-file): Move
  to...
* gnu/system/grub.scm: ... here.  New file.
* gnu/packages/linux.scm (<pam-service>, <pam-entry>,
  pam-service->configuration, pam-service->directory,
  %pam-other-services, unix-pam-service): Move to...
* gnu/system/linux.scm: ... here.  New file.
* gnu/system/vm.scm (passwd-file): Move to...
* gnu/system/shadow.scm: ... here.  New file.
* gnu-system.am (GNU_SYSTEM_MODULES): Add
  gnu/system/{grub,linux,shadow}.scm.
This commit is contained in:
Ludovic Courtès 2013-09-11 22:36:50 +02:00
parent aedb72fbe0
commit 0ded70f37d
7 changed files with 298 additions and 205 deletions

View File

@ -179,6 +179,10 @@ GNU_SYSTEM_MODULES = \
gnu/packages/yasm.scm \
gnu/packages/zile.scm \
gnu/packages/zip.scm \
\
gnu/system/grub.scm \
gnu/system/linux.scm \
gnu/system/shadow.scm \
gnu/system/vm.scm
patchdir = $(guilemoduledir)/gnu/packages/patches

View File

@ -19,9 +19,6 @@
(define-module (gnu packages grub)
#:use-module (guix download)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module ((guix licenses) #:select (gpl3+))
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
@ -33,11 +30,7 @@
#:use-module (gnu packages qemu)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages cdrom)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (menu-entry
menu-entry?
grub-configuration-file))
#:use-module (srfi srfi-1))
(define qemu-for-tests
;; Newer QEMU versions, such as 1.5.1, no longer support the 'shutdown'
@ -117,56 +110,3 @@ computer starts. It is responsible for loading and transferring control to
the operating system kernel software (such as the Hurd or the Linux). The
kernel, in turn, initializes the rest of the operating system (e.g., GNU).")
(license gpl3+)))
;;;
;;; Configuration.
;;;
(define-record-type* <menu-entry>
menu-entry make-menu-entry
menu-entry?
(label menu-entry-label)
(linux menu-entry-linux)
(linux-arguments menu-entry-linux-arguments
(default '()))
(initrd menu-entry-initrd))
(define* (grub-configuration-file store entries
#:key (default-entry 1) (timeout 5)
(system (%current-system)))
"Return the GRUB configuration file in STORE for ENTRIES, a list of
<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
(define prologue
(format #f "
set default=~a
set timeout=~a
search.file ~a~%"
default-entry timeout
(any (match-lambda
(($ <menu-entry> _ linux)
(let* ((drv (package-derivation store linux system))
(out (derivation-path->output-path drv)))
(string-append out "/bzImage"))))
entries)))
(define entry->text
(match-lambda
(($ <menu-entry> label linux arguments initrd)
(let ((linux-drv (package-derivation store linux system))
(initrd-drv (package-derivation store initrd system)))
;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
(format #f "menuentry ~s {
linux ~a/bzImage ~a
initrd ~a/initrd
}~%"
label
(derivation-path->output-path linux-drv)
(string-join arguments)
(derivation-path->output-path initrd-drv))))))
(add-text-to-store store "grub.cfg"
(string-append prologue
(string-concatenate
(map entry->text entries)))
'()))

View File

@ -32,18 +32,7 @@
#:use-module (gnu packages algebra)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix records)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (pam-service
pam-entry
pam-services->directory
%pam-other-services
unix-pam-service))
#:use-module (guix build-system gnu))
(define-public (system->linux-architecture arch)
"Return the Linux architecture name for ARCH, a Guix system name such as
@ -271,111 +260,6 @@ be used through the PAM API to perform tasks, like authenticating a user
at login. Local and dynamic reconfiguration are its key features")
(license bsd-3)))
;; PAM services (see
;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-file.html>.)
(define-record-type* <pam-service> pam-service
make-pam-service
pam-service?
(name pam-service-name) ; string
;; The four "management groups".
(account pam-service-account ; list of <pam-entry>
(default '()))
(auth pam-service-auth
(default '()))
(password pam-service-password
(default '()))
(session pam-service-session
(default '())))
(define-record-type* <pam-entry> pam-entry
make-pam-entry
pam-entry?
(control pam-entry-control) ; string
(module pam-entry-module) ; file name
(arguments pam-entry-arguments ; list of strings
(default '())))
(define (pam-service->configuration service)
"Return the configuration string for SERVICE, to be dumped in
/etc/pam.d/NAME, where NAME is the name of SERVICE."
(define (entry->string type entry)
(match entry
(($ <pam-entry> control module (arguments ...))
(string-append type " "
control " " module " "
(string-join arguments)
"\n"))))
(match service
(($ <pam-service> name account auth password session)
(string-concatenate
(append (map (cut entry->string "account" <>) account)
(map (cut entry->string "auth" <>) auth)
(map (cut entry->string "password" <>) password)
(map (cut entry->string "session" <>) session))))))
(define (pam-services->directory store services)
"Return the derivation to build the configuration directory to be used as
/etc/pam.d for SERVICES."
(let ((names (map pam-service-name services))
(files (map (match-lambda
((and service ($ <pam-service> name))
(let ((config (pam-service->configuration service)))
(add-text-to-store store
(string-append name ".pam")
config '()))))
services)))
(define builder
'(begin
(use-modules (ice-9 match))
(let ((out (assoc-ref %outputs "out")))
(mkdir out)
(for-each (match-lambda
((name . file)
(symlink file (string-append out "/" name))))
%build-inputs)
#t)))
(build-expression->derivation store "pam.d" (%current-system)
builder
(zip names files))))
(define %pam-other-services
;; The "other" PAM configuration, which denies everything (see
;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.)
(let ((deny (pam-entry
(control "required")
(module "pam_deny.so"))))
(pam-service
(name "other")
(account (list deny))
(auth (list deny))
(password (list deny))
(session (list deny)))))
(define unix-pam-service
(let ((unix (pam-entry
(control "required")
(module "pam_unix.so"))))
(lambda* (name #:key allow-empty-passwords?)
"Return a standard Unix-style PAM service for NAME. When
ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
(let ((name* name))
(pam-service
(name name*)
(account (list unix))
(auth (list (if allow-empty-passwords?
(pam-entry
(control "required")
(module "pam_unix.so")
(arguments '("nullok")))
unix)))
(password (list unix))
(session (list unix)))))))
;;;
;;; Miscellaneous.

84
gnu/system/grub.scm Normal file
View File

@ -0,0 +1,84 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 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 system grub)
#:use-module (guix store)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (menu-entry
menu-entry?
grub-configuration-file))
;;; Commentary:
;;;
;;; Configuration of GNU GRUB.
;;;
;;; Code:
(define-record-type* <menu-entry>
menu-entry make-menu-entry
menu-entry?
(label menu-entry-label)
(linux menu-entry-linux)
(linux-arguments menu-entry-linux-arguments
(default '()))
(initrd menu-entry-initrd))
(define* (grub-configuration-file store entries
#:key (default-entry 1) (timeout 5)
(system (%current-system)))
"Return the GRUB configuration file in STORE for ENTRIES, a list of
<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT."
(define prologue
(format #f "
set default=~a
set timeout=~a
search.file ~a~%"
default-entry timeout
(any (match-lambda
(($ <menu-entry> _ linux)
(let* ((drv (package-derivation store linux system))
(out (derivation-path->output-path drv)))
(string-append out "/bzImage"))))
entries)))
(define entry->text
(match-lambda
(($ <menu-entry> label linux arguments initrd)
(let ((linux-drv (package-derivation store linux system))
(initrd-drv (package-derivation store initrd system)))
;; XXX: Assume that INITRD is a directory containing an 'initrd' file.
(format #f "menuentry ~s {
linux ~a/bzImage ~a
initrd ~a/initrd
}~%"
label
(derivation-path->output-path linux-drv)
(string-join arguments)
(derivation-path->output-path initrd-drv))))))
(add-text-to-store store "grub.cfg"
(string-append prologue
(string-concatenate
(map entry->text entries)))
'()))
;;; grub.scm ends here

145
gnu/system/linux.scm Normal file
View File

@ -0,0 +1,145 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 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 system linux)
#:use-module (guix store)
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module ((guix utils) #:select (%current-system))
#:export (pam-service
pam-entry
pam-services->directory
%pam-other-services
unix-pam-service))
;;; Commentary:
;;;
;;; Configuration of Linux-related things, including pluggable authentication
;;; modules (PAM).
;;;
;;; Code:
;; PAM services (see
;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-file.html>.)
(define-record-type* <pam-service> pam-service
make-pam-service
pam-service?
(name pam-service-name) ; string
;; The four "management groups".
(account pam-service-account ; list of <pam-entry>
(default '()))
(auth pam-service-auth
(default '()))
(password pam-service-password
(default '()))
(session pam-service-session
(default '())))
(define-record-type* <pam-entry> pam-entry
make-pam-entry
pam-entry?
(control pam-entry-control) ; string
(module pam-entry-module) ; file name
(arguments pam-entry-arguments ; list of strings
(default '())))
(define (pam-service->configuration service)
"Return the configuration string for SERVICE, to be dumped in
/etc/pam.d/NAME, where NAME is the name of SERVICE."
(define (entry->string type entry)
(match entry
(($ <pam-entry> control module (arguments ...))
(string-append type " "
control " " module " "
(string-join arguments)
"\n"))))
(match service
(($ <pam-service> name account auth password session)
(string-concatenate
(append (map (cut entry->string "account" <>) account)
(map (cut entry->string "auth" <>) auth)
(map (cut entry->string "password" <>) password)
(map (cut entry->string "session" <>) session))))))
(define (pam-services->directory store services)
"Return the derivation to build the configuration directory to be used as
/etc/pam.d for SERVICES."
(let ((names (map pam-service-name services))
(files (map (match-lambda
((and service ($ <pam-service> name))
(let ((config (pam-service->configuration service)))
(add-text-to-store store
(string-append name ".pam")
config '()))))
services)))
(define builder
'(begin
(use-modules (ice-9 match))
(let ((out (assoc-ref %outputs "out")))
(mkdir out)
(for-each (match-lambda
((name . file)
(symlink file (string-append out "/" name))))
%build-inputs)
#t)))
(build-expression->derivation store "pam.d" (%current-system)
builder
(zip names files))))
(define %pam-other-services
;; The "other" PAM configuration, which denies everything (see
;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.)
(let ((deny (pam-entry
(control "required")
(module "pam_deny.so"))))
(pam-service
(name "other")
(account (list deny))
(auth (list deny))
(password (list deny))
(session (list deny)))))
(define unix-pam-service
(let ((unix (pam-entry
(control "required")
(module "pam_unix.so"))))
(lambda* (name #:key allow-empty-passwords?)
"Return a standard Unix-style PAM service for NAME. When
ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
(let ((name* name))
(pam-service
(name name*)
(account (list unix))
(auth (list (if allow-empty-passwords?
(pam-entry
(control "required")
(module "pam_unix.so")
(arguments '("nullok")))
unix)))
(password (list unix))
(session (list unix)))))))
;;; linux.scm ends here

57
gnu/system/shadow.scm Normal file
View File

@ -0,0 +1,57 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 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 system shadow)
#:use-module (guix store)
#:use-module (ice-9 match)
#:export (passwd-file))
;;; Commentary:
;;;
;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
;;;
;;; Code:
(define* (passwd-file store accounts #:key shadow?)
"Return a password file for ACCOUNTS, a list of vectors as returned by
'getpwnam'. If SHADOW? is true, then it is a /etc/shadow file, otherwise it
is a /etc/passwd file."
;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t!
(define contents
(let loop ((accounts accounts)
(result '()))
(match accounts
((#(name pass uid gid comment home-dir shell) rest ...)
(loop rest
(cons (if shadow?
(string-append name
":" ; XXX: use (crypt PASS …)?
":::::::")
(string-append name
":" "x"
":" (number->string uid)
":" (number->string gid)
":" comment ":" home-dir ":" shell))
result)))
(()
(string-join (reverse result) "\n" 'suffix)))))
(add-text-to-store store (if shadow? "shadow" "passwd")
contents '()))
;;; shadow.scm ends here

View File

@ -34,9 +34,15 @@
#:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped))
#:use-module (gnu packages system)
#:use-module (gnu system shadow)
#:use-module (gnu system linux)
#:use-module (gnu system grub)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (expression->derivation-in-linux-vm
qemu-image
system-qemu-image))
@ -346,33 +352,6 @@ It can be used to provide additional files, such as /etc files."
;;; Stand-alone VM image.
;;;
(define* (passwd-file store accounts #:key shadow?)
"Return a password file for ACCOUNTS, a list of vectors as returned by
'getpwnam'. If SHADOW? is true, then it is a /etc/shadow file, otherwise it
is a /etc/passwd file."
;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t!
(define contents
(let loop ((accounts accounts)
(result '()))
(match accounts
((#(name pass uid gid comment home-dir shell) rest ...)
(loop rest
(cons (if shadow?
(string-append name
":" ; XXX: use (crypt PASS …)?
":::::::")
(string-append name
":" "x"
":" (number->string uid)
":" (number->string gid)
":" comment ":" home-dir ":" shell))
result)))
(()
(string-join (reverse result) "\n" 'suffix)))))
(add-text-to-store store (if shadow? "shadow" "passwd")
contents '()))
(define (system-qemu-image store)
"Return the derivation of a QEMU image of the GNU system."
(define %pam-services