Add (guix monads).

[jackhill/guix/guix.git] / gnu / system / linux.scm

;;; 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? motd)
      "Return a standard Unix-style PAM service for NAME.  When
ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords.  When MOTD is true, it
should be the name of a file used as the message-of-the-day."
      ;; 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 (if motd
                      (list unix
                            (pam-entry
                             (control "optional")
                             (module "pam_motd.so")
                             (arguments (list (string-append "motd=" motd)))))
                      (list unix))))))))

;;; linux.scm ends here