summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/grub.scm84
-rw-r--r--gnu/system/linux.scm145
-rw-r--r--gnu/system/shadow.scm57
-rw-r--r--gnu/system/vm.scm33
4 files changed, 292 insertions, 27 deletions
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
new file mode 100644
index 0000000000..695a044bfa
--- /dev/null
+++ b/gnu/system/grub.scm
@@ -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
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
new file mode 100644
index 0000000000..b2daa13e06
--- /dev/null
+++ b/gnu/system/linux.scm
@@ -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
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
new file mode 100644
index 0000000000..71f8e0d771
--- /dev/null
+++ b/gnu/system/shadow.scm
@@ -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
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 6886e67c21..192ed1d5a3 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -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
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-07 19:17:32 +0000