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.
master
Ludovic Courtès
parent
aedb72fbe0
commit
0ded70f37d
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
'()))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Reference in New Issue