1 files changed, 145 insertions, 0 deletions
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