code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;;
;;; 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 packages zile)
  #:use-module (guix licenses)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (guix build-system gnu)
  #:use-module (gnu packages autotools)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages bdw-gc)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages gnupg)
  #:use-module (gnu packages m4)
  #:use-module (gnu packages man)
  #:use-module (gnu packages ncurses)
  #:use-module (gnu packages perl)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages version-control))

(define-public zile
  (package
    (name "zile")
    (version "2.4.14")
    (source (origin
             (method url-fetch)
             (uri (string-append "mirror://gnu/zile/zile-"
                                 version ".tar.gz"))
             (sha256
              (base32
               "0x3byaddms8l3g7igx6njycqsq98wgapysdb5c7lhcnajlkp8y3s"))))
    (build-system gnu-build-system)
    (arguments
     `(#:phases
       (modify-phases %standard-phases
         (add-before 'configure 'patch-/bin/sh
           (lambda* (#:key inputs #:allow-other-keys)
             (let ((bash (assoc-ref inputs "bash")))
               ;; Refer to the actual shell.
               (substitute* '("lib/spawni.c" "src/funcs.c")
                 (("/bin/sh")
                  (string-append bash "/bin/sh")))
               #t)))
         ;; Zile generates its manual pages by calling the built Zile
         ;; with the --help argument.  That does not work when cross-
         ;; compiling; use the native Zile added below in that case.
         ,@(if (%current-target-system)
               '((add-before 'build 'use-native-zile-for-documentation
                   (lambda _
                     (substitute* "build-aux/zile-help2man-wrapper"
                       (("src/zile")
                        (which "zile")))
                     #t)))
               '()))))
    (inputs
     `(("boehm-gc" ,libgc)
       ("ncurses" ,ncurses)
       ("bash" ,bash)))
    (native-inputs
     `(("perl" ,perl)
       ("help2man" ,help2man)
       ;; When cross-compiling, Zile needs a native version of itself to
       ;; generate the manual pages (see the related phase above).
       ,@(if (%current-target-system)
             `(("self" ,this-package))
             '())
       ("pkg-config" ,pkg-config)))
    (home-page "https://www.gnu.org/software/zile/")
    (synopsis "Lightweight Emacs clone")
    (description
     "GNU Zile is a lightweight Emacs clone.  It usage is similar to the
default Emacs configuration, but it carries a much lighter feature set.")
    (license gpl3+)))

(define-public zile-on-guile
  ;; This is a fork of Zile that uses Guile, announced here:
  ;; <http://lists.gnu.org/archive/html/guile-user/2012-02/msg00033.html>.
  (let ((commit "fd097811a60e58696d734c35b0eb7da3afc1adb7")
        (revision "0"))
    (package
      (inherit zile)
      (name "zile-on-guile")
      (version (string-append (package-version zile)
                              "-" revision "."
                              (string-take commit 7)))
      (home-page "https://github.com/spk121/zile")
      (source (origin
                (method git-fetch)
                (uri (git-reference
                      (url home-page)
                      (commit commit)
                      (recursive? #t)))           ;for the Gnulib sub-module
                (sha256
                 (base32
                  "0wlli8hqal9ikmbl3a49kyhzyf164jk6mdbir3bclq2gxszs532d"))
                (file-name (string-append name "-" version "-checkout"))))
      (inputs
       `(("guile" ,guile-2.0)
         ,@(package-inputs zile)))
      (native-inputs
       `(("m4" ,m4)                               ;for 'bootstrap'
         ("autoconf" ,autoconf-wrapper)
         ("automake" ,automake)

         ;; For some reason, 'bootstrap' insists on having these.
         ("git" ,git)
         ("gpg" ,gnupg)

         ,@(package-native-inputs zile)))
      (arguments
       (substitute-keyword-arguments (package-arguments zile)
         ((#:phases phases)
          `(modify-phases ,phases
             (replace 'bootstrap
               (lambda _
                 ;; Make sure all the files are writable so that ./bootstrap
                 ;; can proceed.
                 (for-each (lambda (file)
                             (chmod file #o755))
                           (find-files "."))
                 (patch-shebang "gnulib/gnulib-tool")
                 (invoke "sh" "./bootstrap"
                         "--gnulib-srcdir=gnulib"
                         "--skip-git" "--skip-po"
                         "--verbose")))
             (add-after 'install 'wrap-command
               (lambda* (#:key outputs #:allow-other-keys)
                 ;; Add zile.scm to the search path.
                 (let* ((out    (assoc-ref outputs "out"))
                        (scheme (dirname
                                 (car (find-files out "^zile\\.scm$")))))
                   (wrap-program (string-append out "/bin/zile-on-guile")
                     `("GUILE_LOAD_PATH" ":" prefix (,scheme)))
                   #t)))))))
      (synopsis "Lightweight clone of the Emacs editor using Guile")
      (description
       "GNU Zile is a lightweight clone of the Emacs editor, and Zile-on-Guile
is a variant of Zile that can be extended in Guile Scheme.  Hitting
@kbd{M-C} (or: @kbd{Alt} and @kbd{C}) brings up a Guile REPL from which
interactive functions akin to those of Emacs can be invoked."))))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 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 packages zwave)
  #:use-module (guix packages)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix git-download)
  #:use-module (guix build-system gnu)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages libusb)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages perl)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages xml))

(define-public open-zwave
  (package
    (name "open-zwave")
    (version "1.6")
    (source (origin
              (method git-fetch)
              (uri (git-reference
                    (url "https://github.com/OpenZWave/open-zwave/")
                    (commit (string-append "v" version))))
              (file-name (git-file-name name version))
              (sha256
               (base32
                "0xgs4mmr0480c269wx9xkk67ikjzxkh8xcssrdx0f5xcl1lyd333"))
              (patches (search-patches "open-zwave-hidapi.patch"))
              (modules '((guix build utils)))
              (snippet
               '(begin
                  ;; Set RUNPATH on the 'MinOZW' executable.
                  (substitute* "cpp/examples/MinOZW/Makefile"
                    (("\\$\\(LDFLAGS\\)")
                     "$(LDFLAGS) -Wl,-rpath=$(PREFIX)/lib"))

                  ;; XXX: There's a bundled TinyXML under cpp/tinyxml.  Keep
                  ;; it because using our own TinyXML leads to double-free
                  ;; down the road.

                  ;; Delete the bundled HIDAPI.
                  (delete-file-recursively "cpp/hidapi")
                  #t))))
    (build-system gnu-build-system)
    (arguments
     '(#:phases (modify-phases %standard-phases
                  (delete 'configure))            ;no 'configure' script

       #:make-flags (list "BUILD=debug"
                          (string-append "PREFIX="
                                         (assoc-ref %outputs "out"))
                          (string-append "pkgconfigdir="
                                         (assoc-ref %outputs "out")
                                         "/lib/pkgconfig"))

       ;; "make check" and "make fulltest" are only concerned with checking
       ;; the device XML database and it's not entirely clear what to get from
       ;; them.
       #:tests? #f))
    (native-inputs `(("which" ,which)
                     ("pkg-config" ,pkg-config)
                     ("perl" ,perl)               ;for tests
                     ("perl-xml-simple" ,perl-xml-simple)))
    (inputs `(("hidapi" ,hidapi)
              ("eudev" ,eudev)))
    (home-page "http://www.openzwave.net/")
    (synopsis "Access Z-Wave devices from C++ programs")
    (description
     "OpenZWave (or OZW) is a C++ library that interfaces with selected Z-Wave
PC controllers.  It allows developers to create applications that manipulate
and respond to devices on a Z-Wave network, without requiring in-depth
knowledge of the Z-Wave protocol.")
    (license license:lgpl3+)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@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 services)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix records)
  #:use-module (guix profiles)
  #:use-module (guix discovery)
  #:use-module (guix combinators)
  #:use-module (guix channels)
  #:use-module (guix describe)
  #:use-module (guix sets)
  #:use-module (guix ui)
  #:use-module (guix diagnostics)
  #:autoload   (guix openpgp) (openpgp-format-fingerprint)
  #:use-module (guix modules)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages hurd)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:export (service-extension
            service-extension?
            service-extension-target
            service-extension-compute

            service-type
            service-type?
            service-type-name
            service-type-extensions
            service-type-compose
            service-type-extend
            service-type-default-value
            service-type-description
            service-type-location

            %service-type-path
            fold-service-types
            lookup-service-types

            service
            service?
            service-kind
            service-value
            service-parameters                    ;deprecated

            simple-service
            modify-services
            service-back-edges
            instantiate-missing-services
            fold-services

            service-error?
            missing-value-service-error?
            missing-value-service-error-type
            missing-value-service-error-location
            missing-target-service-error?
            missing-target-service-error-service
            missing-target-service-error-target-type
            ambiguous-target-service-error?
            ambiguous-target-service-error-service
            ambiguous-target-service-error-target-type

            system-service-type
            provenance-service-type
            sexp->system-provenance
            system-provenance
            boot-service-type
            cleanup-service-type
            activation-service-type
            activation-service->script
            %linux-bare-metal-service
            %hurd-rc-script
            %hurd-startup-service
            special-files-service-type
            extra-special-file
            etc-service-type
            etc-directory
            setuid-program-service-type
            profile-service-type
            firmware-service-type
            gc-root-service-type

            %boot-service
            %activation-service
            etc-service))

;;; Comment:
;;;
;;; This module defines a broad notion of "service types" and "services."
;;;
;;; A service type describe how its instances extend instances of other
;;; service types.  For instance, some services extend the instance of
;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
;;; others extend SHEPHERD-ROOT-SERVICE-TYPE by passing it instances of
;;; <shepherd-service>.
;;;
;;; When applicable, the service type defines how it can itself be extended,
;;; by providing one procedure to compose extensions, and one procedure to
;;; extend itself.
;;;
;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single
;;; instance, which is the root of the service DAG.  Its value is the
;;; derivation that produces the 'system' directory as returned by
;;; 'operating-system-derivation'.
;;;
;;; The 'fold-services' procedure can be passed a list of procedures, which it
;;; "folds" by propagating extensions down the graph; it returns the root
;;; service after the applying all its extensions.
;;;
;;; Code:

(define-record-type <service-extension>
  (service-extension target compute)
  service-extension?
  (target  service-extension-target)              ;<service-type>
  (compute service-extension-compute))            ;params -> params

(define &no-default-value
  ;; Value used to denote service types that have no associated default value.
  '(no default value))

(define-record-type* <service-type> service-type make-service-type
  service-type?
  (name       service-type-name)                  ;symbol (for debugging)

  ;; Things extended by services of this type.
  (extensions service-type-extensions)            ;list of <service-extensions>

  ;; Given a list of extensions, "compose" them.
  (compose    service-type-compose                ;list of Any -> Any
              (default #f))

  ;; Extend the services' own parameters with the extension composition.
  (extend     service-type-extend                 ;list of Any -> parameters
              (default #f))

  ;; Optional default value for instances of this type.
  (default-value service-type-default-value       ;Any
                 (default &no-default-value))

  ;; Meta-data.
  (description  service-type-description          ;string
                (default #f))
  (location     service-type-location             ;<location>
                (default (and=> (current-source-location)
                                source-properties->location))
                (innate)))

(define (write-service-type type port)
  (format port "#<service-type ~a ~a>"
          (service-type-name type)
          (number->string (object-address type) 16)))

(set-record-type-printer! <service-type> write-service-type)

(define %distro-root-directory
  ;; Absolute file name of the module hierarchy.
  (dirname (search-path %load-path "guix.scm")))

(define %service-type-path
  ;; Search path for service types.
  (make-parameter `((,%distro-root-directory . "gnu/services")
                    (,%distro-root-directory . "gnu/system"))))

(define (all-service-modules)
  "Return the default set of service modules."
  (cons (resolve-interface '(gnu services))
        (all-modules (%service-type-path)
                     #:warn warn-about-load-error)))

(define* (fold-service-types proc seed
                             #:optional
                             (modules (all-service-modules)))
  "For each service type exported by one of MODULES, call (PROC RESULT).  SEED
is used as the initial value of RESULT."
  (fold-module-public-variables (lambda (object result)
                                  (if (service-type? object)
                                      (proc object result)
                                      result))
                                seed
                                modules))

(define lookup-service-types
  (let ((table
         (delay (fold-service-types (lambda (type result)
                                      (vhash-consq (service-type-name type)
                                                   type result))
                                    vlist-null))))
    (lambda (name)
      "Return the list of services with the given NAME (a symbol)."
      (vhash-foldq* cons '() name (force table)))))

;; Services of a given type.
(define-record-type <service>
  (make-service type value)
  service?
  (type       service-kind)
  (value      service-value))

(define-syntax service
  (syntax-rules ()
    "Return a service instance of TYPE.  The service value is VALUE or, if
omitted, TYPE's default value."
    ((_ type value)
     (make-service type value))
    ((_ type)
     (%service-with-default-value (current-source-location)
                                  type))))

(define (%service-with-default-value location type)
  "Return a instance of service type TYPE with its default value, if any.  If
TYPE does not have a default value, an error is raised."
  ;; TODO: Currently this is a run-time error but with a little bit macrology
  ;; we could turn it into an expansion-time error.
  (let ((default (service-type-default-value type)))
    (if (eq? default &no-default-value)
        (let ((location (source-properties->location location)))
          (raise
           (make-compound-condition
            (condition
             (&missing-value-service-error (type type) (location location)))
            (formatted-message (G_ "~a: no value specified \
for service of type '~a'")
                               (location->string location)
                               (service-type-name type)))))
        (service type default))))

(define-condition-type &service-error &error
  service-error?)

(define-condition-type &missing-value-service-error &service-error
  missing-value-service-error?
  (type     missing-value-service-error-type)
  (location missing-value-service-error-location))

;;;
;;; Helpers.
;;;

(define service-parameters
  ;; Deprecated alias.
  service-value)

(define (simple-service name target value)
  "Return a service that extends TARGET with VALUE.  This works by creating a
singleton service type NAME, of which the returned service is an instance."
  (let* ((extension (service-extension target identity))
         (type      (service-type (name name)
                                  (extensions (list extension)))))
    (service type value)))

(define-syntax %modify-service
  (syntax-rules (=>)
    ((_ service)
     service)
    ((_ svc (kind param => exp ...) clauses ...)
     (if (eq? (service-kind svc) kind)
         (let ((param (service-value svc)))
           (service (service-kind svc)
                    (begin exp ...)))
         (%modify-service svc clauses ...)))))

(define-syntax modify-services
  (syntax-rules ()
    "Modify the services listed in SERVICES according to CLAUSES and return
the resulting list of services.  Each clause must have the form:

  (TYPE VARIABLE => BODY)

where TYPE is a service type, such as 'guix-service-type', and VARIABLE is an
identifier that is bound within BODY to the value of the service of that
TYPE.  Consider this example:

  (modify-services %base-services
    (guix-service-type config =>
                       (guix-configuration
                        (inherit config)
                        (use-substitutes? #f)
                        (extra-options '(\"--gc-keep-derivations\"))))
    (mingetty-service-type config =>
                           (mingetty-configuration
                            (inherit config)
                            (motd (plain-file \"motd\" \"Hi there!\")))))

It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of
all the MINGETTY-SERVICE-TYPE instances.

This is a shorthand for (map (lambda (svc) ...) %base-services)."
    ((_ services clauses ...)
     (map (lambda (service)
            (%modify-service service clauses ...))
          services))))

;;;
;;; Core services.
;;;

(define (system-derivation entries mextensions)
  "Return as a monadic value the derivation of the 'system' directory
containing the given entries."
  (mlet %store-monad ((extensions (mapm/accumulate-builds identity
                                                          mextensions)))
    (lower-object
     (file-union "system"
                 (append entries (concatenate extensions))))))

(define system-service-type
  ;; This is the ultimate service type, the root of the service DAG.  The
  ;; service of this type is extended by monadic name/item pairs.  These items
  ;; end up in the "system directory" as returned by
  ;; 'operating-system-derivation'.
  (service-type (name 'system)
                (extensions '())
                (compose identity)
                (extend system-derivation)
                (description
                 "Build the operating system top-level directory, which in
turn refers to everything the operating system needs: its kernel, initrd,
system profile, boot script, and so on.")))

(define (compute-boot-script _ gexps)
  ;; Reverse GEXPS so that extensions appear in the boot script in the right
  ;; order.  That is, user extensions would come first, and extensions added
  ;; by 'essential-services' (e.g., running shepherd) are guaranteed to come
  ;; last.
  (gexp->file "boot"
              ;; Clean up and activate the system, then spawn shepherd.
              #~(begin #$@(reverse gexps))))

(define (boot-script-entry mboot)
  "Return, as a monadic value, an entry for the boot script in the system
directory."
  (mlet %store-monad ((boot mboot))
    (return `(("boot" ,boot)))))

(define boot-service-type
  ;; The service of this type is extended by being passed gexps.  It
  ;; aggregates them in a single script, as a monadic value, which becomes its
  ;; value.
  (service-type (name 'boot)
                (extensions
                 (list (service-extension system-service-type
                                          boot-script-entry)))
                (compose identity)
                (extend compute-boot-script)
                (description
                 "Produce the operating system's boot script, which is spawned
by the initrd once the root file system is mounted.")))

(define %boot-service
  ;; The service that produces the boot script.
  (service boot-service-type #t))

;;;
;;; Provenance tracking.
;;;

(define (object->pretty-string obj)
  "Like 'object->string', but using 'pretty-print'."
  (call-with-output-string
    (lambda (port)
      (pretty-print obj port))))

(define (channel->code channel)
  "Return code to build CHANNEL, ready to be dropped in a 'channels.scm'
file."
  ;; Since the 'introduction' field is backward-incompatible, and since it's
  ;; optional when using the "official" 'guix channel, include it if and only
  ;; if we're referring to a different channel.
  (let ((intro (and (not (equal? (list channel) %default-channels))
                    (channel-introduction channel))))
    `(channel (name ',(channel-name channel))
              (url ,(channel-url channel))
              (branch ,(channel-branch channel))
              (commit ,(channel-commit channel))
              ,@(if intro
                    `((introduction
                       (make-channel-introduction
                        ,(channel-introduction-first-signed-commit intro)
                        (openpgp-fingerprint
                         ,(openpgp-format-fingerprint
                           (channel-introduction-first-commit-signer
                            intro))))))
                    '()))))

(define (channel->sexp channel)
  "Return an sexp describing CHANNEL.  The sexp is _not_ code and is meant to
be parsed by tools; it's potentially more future-proof than code."
  ;; TODO: Add CHANNEL's introduction.  Currently we can't do that because
  ;; older 'guix system describe' expect exactly name/url/branch/commit
  ;; without any additional fields.
  `(channel (name ,(channel-name channel))
            (url ,(channel-url channel))
            (branch ,(channel-branch channel))
            (commit ,(channel-commit channel))))

(define (sexp->channel sexp)
  "Return the channel corresponding to SEXP, an sexp as found in the
\"provenance\" file produced by 'provenance-service-type'."
  (match sexp
    (('channel ('name name)
               ('url url)
               ('branch branch)
               ('commit commit)
               rest ...)
     ;; XXX: In the future REST may include a channel introduction.
     (channel (name name) (url url)
              (branch branch) (commit commit)))))

(define (provenance-file channels config-file)
  "Return a 'provenance' file describing CHANNELS, a list of channels, and
CONFIG-FILE, which can be either #f or a <local-file> containing the OS
configuration being used."
  (scheme-file "provenance"
               #~(provenance
                  (version 0)
                  (channels #+@(if channels
                                   (map channel->sexp channels)
                                   '()))
                  (configuration-file #+config-file))))

(define (provenance-entry config-file)
  "Return system entries describing the operating system provenance: the
channels in use and CONFIG-FILE, if it is true."
  (define profile
    (current-profile))

  (define channels
    (and=> profile profile-channels))

  (mbegin %store-monad
    (let ((config-file (cond ((string? config-file)
                              (local-file config-file "configuration.scm"))
                             ((not config-file)
                              #f)
                             (else
                              config-file))))
      (return `(("provenance" ,(provenance-file channels config-file))
                ,@(if channels
                      `(("channels.scm"
                         ,(plain-file "channels.scm"
                                      (object->pretty-string
                                       `(list
                                         ,@(map channel->code channels))))))
                      '())
                ,@(if config-file
                      `(("configuration.scm" ,config-file))
                      '()))))))

(define provenance-service-type
  (service-type (name 'provenance)
                (extensions
                 (list (service-extension system-service-type
                                          provenance-entry)))
                (default-value #f)                ;the OS config file
                (description
                 "Store provenance information about the system in the system
itself: the channels used when building the system, and its configuration
file, when available.")))

(define (sexp->system-provenance sexp)
  "Parse SEXP, an s-expression read from /run/current-system/provenance or
similar, and return two values: the list of channels listed therein, and the
OS configuration file or #f."
  (match sexp
    (('provenance ('version 0)
                  ('channels channels ...)
                  ('configuration-file config-file))
     (values (map sexp->channel channels)
             config-file))
    (_
     (values '() #f))))

(define (system-provenance system)
  "Given SYSTEM, the file name of a system generation, return two values: the
list of channels SYSTEM is built from, and its configuration file.  If that
information is missing, return the empty list (for channels) and possibly
#false (for the configuration file)."
  (catch 'system-error
    (lambda ()
      (sexp->system-provenance
       (call-with-input-file (string-append system "/provenance")
         read)))
    (lambda _
      (values '() #f))))

;;;
;;; Cleanup.
;;;

(define (cleanup-gexp _)
  "Return a gexp to clean up /tmp and similar places upon boot."
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))

        ;; Clean out /tmp and /var/run.
        ;;
        ;; XXX This needs to happen before service activations, so it
        ;; has to be here, but this also implicitly assumes that /tmp
        ;; and /var/run are on the root partition.
        (letrec-syntax ((fail-safe (syntax-rules ()
                                     ((_ exp rest ...)
                                      (begin
                                        (catch 'system-error
                                          (lambda () exp)
                                          (const #f))
                                        (fail-safe rest ...)))
                                     ((_)
                                      #t))))
          ;; Ignore I/O errors so the system can boot.
          (fail-safe
           ;; Remove stale Shadow lock files as they would lead to
           ;; failures of 'useradd' & co.
           (delete-file "/etc/group.lock")
           (delete-file "/etc/passwd.lock")
           (delete-file "/etc/.pwd.lock")         ;from 'lckpwdf'

           ;; Force file names to be decoded as UTF-8.  See
           ;; <https://bugs.gnu.org/26353>.
           (setenv "GUIX_LOCPATH"
                   #+(file-append glibc-utf8-locales "/lib/locale"))
           (setlocale LC_CTYPE "en_US.utf8")
           (delete-file-recursively "/tmp")
           (delete-file-recursively "/var/run")

           (mkdir "/tmp")
           (chmod "/tmp" #o1777)
           (mkdir "/var/run")
           (chmod "/var/run" #o755)
           (delete-file-recursively "/run/udev/watch.old"))))))

(define cleanup-service-type
  ;; Service that cleans things up in /tmp and similar.
  (service-type (name 'cleanup)
                (extensions
                 (list (service-extension boot-service-type
                                          cleanup-gexp)))
                (description
                 "Delete files from @file{/tmp}, @file{/var/run}, and other
temporary locations at boot time.")))

(define* (activation-service->script service)
  "Return as a monadic value the activation script for SERVICE, a service of
ACTIVATION-SCRIPT-TYPE."
  (activation-script (service-value service)))

(define (activation-script gexps)
  "Return the system's activation script, which evaluates GEXPS."
  (define actions
    (map (cut program-file "activate-service.scm" <>) gexps))

  (program-file "activate.scm"
                (with-imported-modules (source-module-closure
                                        '((gnu build activation)
                                          (guix build utils)))
                  #~(begin
                      (use-modules (gnu build activation)
                                   (guix build utils))

                      ;; Make sure the user accounting database exists.  If it
                      ;; does not exist, 'setutxent' does not create it and
                      ;; thus there is no accounting at all.
                      (close-port (open-file "/var/run/utmpx" "a0"))

                      ;; Same for 'wtmp', which is populated by mingetty et
                      ;; al.
                      (mkdir-p "/var/log")
                      (close-port (open-file "/var/log/wtmp" "a0"))

                      ;; Set up /run/current-system.  Among other things this
                      ;; sets up locales, which the activation snippets
                      ;; executed below may expect.
                      (activate-current-system)

                      ;; Run the services' activation snippets.
                      ;; TODO: Use 'load-compiled'.
                      (for-each primitive-load '#$actions)))))

(define (gexps->activation-gexp gexps)
  "Return a gexp that runs the activation script containing GEXPS."
  #~(primitive-load #$(activation-script gexps)))

(define (second-argument a b) b)

(define activation-service-type
  (service-type (name 'activate)
                (extensions
                 (list (service-extension boot-service-type
                                          gexps->activation-gexp)))
                (compose identity)
                (extend second-argument)
                (description
                 "Run @dfn{activation} code at boot time and upon
@command{guix system reconfigure} completion.")))

(define %activation-service
  ;; The activation service produces the activation script from the gexps it
  ;; receives.
  (service activation-service-type #t))

(define %modprobe-wrapper
  ;; Wrapper for the 'modprobe' command that knows where modules live.
  ;;
  ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe',
  ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY'
  ;; environment variable is not set---hence the need for this wrapper.
  (let ((modprobe "/run/current-system/profile/bin/modprobe"))
    (program-file "modprobe"
                  #~(begin
                      (setenv "LINUX_MODULE_DIRECTORY"
                              "/run/booted-system/kernel/lib/modules")
                      ;; FIXME: Remove this crutch when the patch #40422,
                      ;; updating to kmod 27 is merged.
                      (setenv "MODPROBE_OPTIONS"
                              "-C /etc/modprobe.d")
                      (apply execl #$modprobe
                             (cons #$modprobe (cdr (command-line))))))))

(define %linux-kernel-activation
  ;; Activation of the Linux kernel running on the bare metal (as opposed to
  ;; running in a container.)
  #~(begin
      ;; Tell the kernel to use our 'modprobe' command.
      (activate-modprobe #$%modprobe-wrapper)

      ;; Let users debug their own processes!
      (activate-ptrace-attach)))

(define %linux-bare-metal-service
  ;; The service that does things that are needed on the "bare metal", but not
  ;; necessary or impossible in a container.
  (simple-service 'linux-bare-metal
                  activation-service-type
                  %linux-kernel-activation))

(define %hurd-rc-script
  ;; The RC script to be started upon boot.
  (program-file "rc"
                (with-imported-modules (source-module-closure
                                        '((guix build utils)
                                          (gnu build hurd-boot)
                                          (guix build syscalls)))
                  #~(begin
                      (use-modules (guix build utils)
                                   (gnu build hurd-boot)
                                   (guix build syscalls)
                                   (ice-9 match)
                                   (system repl repl)
                                   (srfi srfi-1)
                                   (srfi srfi-26))
                      (boot-hurd-system)))))

(define (hurd-rc-entry rc)
  "Return, as a monadic value, an entry for the RC script in the system
directory."
  (mlet %store-monad ((rc (lower-object rc)))
    (return `(("rc" ,rc)))))

(define hurd-startup-service-type
  ;; The service that creates the initial SYSTEM/rc startup file.
  (service-type (name 'startup)
                (extensions
                 (list (service-extension system-service-type hurd-rc-entry)))
                (default-value %hurd-rc-script)))

(define %hurd-startup-service
  ;; The service that produces the RC script.
  (service hurd-startup-service-type %hurd-rc-script))

(define special-files-service-type
  ;; Service to install "special files" such as /bin/sh and /usr/bin/env.
  (service-type
   (name 'special-files)
   (extensions
    (list (service-extension activation-service-type
                             (lambda (files)
                               #~(activate-special-files '#$files)))))
   (compose concatenate)
   (extend append)
   (description
    "Add special files to the root file system---e.g.,
@file{/usr/bin/env}.")))

(define (extra-special-file file target)
  "Use TARGET as the \"special file\" FILE.  For example, TARGET might be
  (file-append coreutils \"/bin/env\")
and FILE could be \"/usr/bin/env\"."
  (simple-service (string->symbol (string-append "special-file-" file))
                  special-files-service-type
                  `((,file ,target))))

(define (etc-directory service)
  "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
  (files->etc-directory (service-value service)))

(define (files->etc-directory files)
  (define (assert-no-duplicates files)
    (let loop ((files files)
               (seen (set)))
      (match files
        (() #t)
        (((file _) rest ...)
         (when (set-contains? seen file)
           (raise (formatted-message (G_ "duplicate '~a' entry for /etc")
                                     file)))
         (loop rest (set-insert file seen))))))

  ;; Detect duplicates early instead of letting them through, eventually
  ;; leading to a build failure of "etc.drv".
  (assert-no-duplicates files)

  (file-union "etc" files))

(define (etc-entry files)
  "Return an entry for the /etc directory consisting of FILES in the system
directory."
  (with-monad %store-monad
    (return `(("etc" ,(files->etc-directory files))))))

(define etc-service-type
  (service-type (name 'etc)
                (extensions
                 (list
                  (service-extension activation-service-type
                                     (lambda (files)
                                       (let ((etc
                                              (files->etc-directory files)))
                                         #~(activate-etc #$etc))))
                  (service-extension system-service-type etc-entry)))
                (compose concatenate)
                (extend append)
                (description "Populate the @file{/etc} directory.")))

(define (etc-service files)
  "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES.
FILES must be a list of name/file-like object pairs."
  (service etc-service-type files))

(define setuid-program-service-type
  (service-type (name 'setuid-program)
                (extensions
                 (list (service-extension activation-service-type
                                          (lambda (programs)
                                            #~(activate-setuid-programs
                                               (list #$@programs))))))
                (compose concatenate)
                (extend append)
                (description
                 "Populate @file{/run/setuid-programs} with the specified
executables, making them setuid-root.")))

(define (packages->profile-entry packages)
  "Return a system entry for the profile containing PACKAGES."
  (with-monad %store-monad
    (return `(("profile" ,(profile
                           (content (packages->manifest
                                     (delete-duplicates packages eq?)))))))))

(define profile-service-type
  ;; The service that populates the system's profile---i.e.,
  ;; /run/current-system/profile.  It is extended by package lists.
  (service-type (name 'profile)
                (extensions
                 (list (service-extension system-service-type
                                          packages->profile-entry)))
                (compose concatenate)
                (extend append)
                (description
                 "This is the @dfn{system profile}, available as
@file{/run/current-system/profile}.  It contains packages that the sysadmin
wants to be globally available to all the system users.")))

(define (firmware->activation-gexp firmware)
  "Return a gexp to make the packages listed in FIRMWARE loadable by the
kernel."
  (let ((directory (directory-union "firmware" firmware)))
    ;; Tell the kernel where firmware is.
    #~(activate-firmware (string-append #$directory "/lib/firmware"))))

(define firmware-service-type
  ;; The service that collects firmware.
  (service-type (name 'firmware)
                (extensions
                 (list (service-extension activation-service-type
                                          firmware->activation-gexp)))
                (compose concatenate)
                (extend append)
                (description
                 "Make ``firmware'' files loadable by the operating system
kernel.  Firmware may then be uploaded to some of the machine's devices, such
as Wifi cards.")))

(define (gc-roots->system-entry roots)
  "Return an entry in the system's output containing symlinks to ROOTS."
  (mlet %store-monad ((entry (gexp->derivation
                              "gc-roots"
                              #~(let ((roots '#$roots))
                                  (mkdir #$output)
                                  (chdir #$output)
                                  (for-each symlink
                                            roots
                                            (map number->string
                                                 (iota (length roots))))))))
    (return (if (null? roots)
                '()
                `(("gc-roots" ,entry))))))

(define gc-root-service-type
  ;; A service to associate extra garbage-collector roots to the system.  This
  ;; is a simple hack that guarantees that the system retains references to
  ;; the given list of roots.  Roots must be "lowerable" objects like
  ;; packages, or derivations.
  (service-type (name 'gc-roots)
                (extensions
                 (list (service-extension system-service-type
                                          gc-roots->system-entry)))
                (compose concatenate)
                (extend append)
                (description
                 "Register garbage-collector roots---i.e., store items that
will not be reclaimed by the garbage collector.")
                (default-value '())))

;;;
;;; Service folding.
;;;

(define-condition-type &missing-target-service-error &service-error
  missing-target-service-error?
  (service      missing-target-service-error-service)
  (target-type  missing-target-service-error-target-type))

(define-condition-type &ambiguous-target-service-error &service-error
  ambiguous-target-service-error?
  (service      ambiguous-target-service-error-service)
  (target-type  ambiguous-target-service-error-target-type))

(define (missing-target-error service target-type)
  (raise
   (condition (&missing-target-service-error
               (service service)
               (target-type target-type))
              (&message
               (message
                (format #f (G_ "no target of type '~a' for service '~a'")
                        (service-type-name target-type)
                        (service-type-name
                         (service-kind service))))))))

(define (service-back-edges services)
  "Return a procedure that, when passed a <service>, returns the list of
<service> objects that depend on it."
  (define (add-edges service edges)
    (define (add-edge extension edges)
      (let ((target-type (service-extension-target extension)))
        (match (filter (lambda (service)
                         (eq? (service-kind service) target-type))
                       services)
          ((target)
           (vhash-consq target service edges))
          (()
           (missing-target-error service target-type))
          (x
           (raise
            (condition (&ambiguous-target-service-error
                        (service service)
                        (target-type target-type))
                       (&message
                        (message
                         (format #f
                                 (G_ "more than one target service of type '~a'")
                                 (service-type-name target-type))))))))))

    (fold add-edge edges (service-type-extensions (service-kind service))))

  (let ((edges (fold add-edges vlist-null services)))
    (lambda (node)
      (reverse (vhash-foldq* cons '() node edges)))))

(define (instantiate-missing-services services)
  "Return SERVICES, a list, augmented with any services targeted by extensions
and missing from SERVICES.  Only service types with a default value can be
instantiated; other missing services lead to a
'&missing-target-service-error'."
  (define (adjust-service-list svc result instances)
    (fold2 (lambda (extension result instances)
             (define target-type
               (service-extension-target extension))

             (match (vhash-assq target-type instances)
               (#f
                (let ((default (service-type-default-value target-type)))
                  (if (eq? &no-default-value default)
                      (missing-target-error svc target-type)
                      (let ((new (service target-type)))
                        (values (cons new result)
                                (vhash-consq target-type new instances))))))
               (_
                (values result instances))))
           result
           instances
           (service-type-extensions (service-kind svc))))

  (let loop ((services services))
    (define instances
      (fold (lambda (service result)
              (vhash-consq (service-kind service) service
                           result))
            vlist-null services))

    (define adjusted
      (fold2 adjust-service-list
             services instances
             services))

    ;; If we instantiated services, they might in turn depend on missing
    ;; services.  Loop until we've reached fixed point.
    (if (= (length adjusted) (vlist-length instances))
        adjusted
        (loop adjusted))))

(define* (fold-services services
                        #:key (target-type system-service-type))
  "Fold SERVICES by propagating their extensions down to the root of type
TARGET-TYPE; return the root service adjusted accordingly."
  (define dependents
    (service-back-edges services))

  (define (matching-extension target)
    (let ((target (service-kind target)))
      (match-lambda
        (($ <service-extension> type)
         (eq? type target)))))

  (define (apply-extension target)
    (lambda (service)
      (match (find (matching-extension target)
                   (service-type-extensions (service-kind service)))
        (($ <service-extension> _ compute)
         (compute (service-value service))))))

  (match (filter (lambda (service)
                   (eq? (service-kind service) target-type))
                 services)
    ((sink)
     ;; Use the state monad to keep track of already-visited services in the
     ;; graph and to memoize their value once folded.
     (run-with-state
         (let loop ((sink sink))
           (mlet %state-monad ((visited (current-state)))
             (match (vhash-assq sink visited)
               (#f
                (mlet* %state-monad
                    ((dependents (mapm %state-monad loop (dependents sink)))
                     (visited    (current-state))
                     (extensions -> (map (apply-extension sink) dependents))
                     (extend     -> (service-type-extend (service-kind sink)))
                     (compose    -> (service-type-compose (service-kind sink)))
                     (params     -> (service-value sink))
                     (service
                      ->
                      ;; Distinguish COMPOSE and EXTEND because PARAMS typically
                      ;; has a different type than the elements of EXTENSIONS.
                      (if extend
                          (service (service-kind sink)
                                   (extend params (compose extensions)))
                          sink)))
                  (mbegin %state-monad
                    (set-current-state (vhash-consq sink service visited))
                    (return service))))
               ((_ . service)                     ;SINK was already visited
                (return service)))))
       vlist-null))
    (()
     (raise
      (make-compound-condition
       (condition (&missing-target-service-error
                   (service #f)
                   (target-type target-type)))
       (formatted-message (G_ "service of type '~a' not found")
                          (service-type-name target-type)))))
    (x
     (raise
      (condition (&ambiguous-target-service-error
                  (service #f)
                  (target-type target-type))
                 (&message
                  (message
                   (format #f
                           (G_ "more than one target service of type '~a'")
                           (service-type-name target-type)))))))))

;;; services.scm ends here.


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;;
;;; 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 services admin)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages certs)
  #:use-module (gnu packages package-management)
  #:use-module (gnu services)
  #:use-module (gnu services mcron)
  #:use-module (gnu services shepherd)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 vlist)
  #:export (%default-rotations
            %rotated-files

            log-rotation
            log-rotation?
            log-rotation-frequency
            log-rotation-files
            log-rotation-options
            log-rotation-post-rotate

            rottlog-configuration
            rottlog-configuration?
            rottlog-service
            rottlog-service-type

            unattended-upgrade-service-type
            unattended-upgrade-configuration
            unattended-upgrade-configuration?
            unattended-upgrade-configuration-operating-system-file
            unattended-upgrade-configuration-channels
            unattended-upgrade-configuration-schedule
            unattended-upgrade-configuration-services-to-restart
            unattended-upgrade-configuration-system-expiration
            unattended-upgrade-configuration-maximum-duration
            unattended-upgrade-configuration-log-file))

;;; Commentary:
;;;
;;; This module implements configuration of rottlog by writing
;;; /etc/rottlog/{rc,hourly|daily|weekly}.  Example usage
;;;
;;;     (mcron-service)
;;;     (service rottlog-service-type)
;;;
;;; Code:

(define-record-type* <log-rotation> log-rotation make-log-rotation
  log-rotation?
  (files       log-rotation-files)                ;list of strings
  (frequency   log-rotation-frequency             ;symbol
               (default 'weekly))
  (post-rotate log-rotation-post-rotate           ;#f | gexp
               (default #f))
  (options     log-rotation-options               ;list of strings
               (default '())))

(define %rotated-files
  ;; Syslog files subject to rotation.
  '("/var/log/messages" "/var/log/secure" "/var/log/debug"
    "/var/log/maillog"))

(define %default-rotations
  (list (log-rotation                             ;syslog files
         (files %rotated-files)

         (options '(;; Run post-rotate once per rotation
                    "sharedscripts"
                    ;; Append .gz to rotated files
                    "storefile @FILENAME.@COMP_EXT"))
         ;; Restart syslogd after rotation.
         (post-rotate #~(let ((pid (call-with-input-file "/var/run/syslog.pid"
                                     read)))
                          (kill pid SIGHUP))))
        (log-rotation
         (files '("/var/log/guix-daemon.log")))))

(define (log-rotation->config rotation)
  "Return a string-valued gexp representing the rottlog configuration snippet
for ROTATION."
  (define post-rotate
    (let ((post (log-rotation-post-rotate rotation)))
      (and post
           (program-file "rottlog-post-rotate.scm" post))))

  #~(let ((post #$post-rotate))
      (string-append (string-join '#$(log-rotation-files rotation) ",")
                     " {"
                     #$(string-join (log-rotation-options rotation)
                                    "\n  " 'prefix)
                     (if post
                         (string-append "\n  postrotate\n    " post
                                        "\n  endscript\n")
                         "")
                     "\n}\n")))

(define (log-rotations->/etc-entries rotations)
  "Return the list of /etc entries for ROTATIONS, a list of <log-rotation>."
  (define (frequency-file frequency rotations)
    (computed-file (string-append "rottlog." (symbol->string frequency))
                   #~(call-with-output-file #$output
                       (lambda (port)
                         (for-each (lambda (str)
                                     (display str port))
                                   (list #$@(map log-rotation->config
                                                 rotations)))))))

  (let* ((frequencies (delete-duplicates
                       (map log-rotation-frequency rotations)))
         (table       (fold (lambda (rotation table)
                              (vhash-consq (log-rotation-frequency rotation)
                                           rotation table))
                            vlist-null
                            rotations)))
    (map (lambda (frequency)
           `(,(symbol->string frequency)
             ,(frequency-file frequency
                              (vhash-foldq* cons '() frequency table))))
         frequencies)))

(define (default-jobs rottlog)
  (list #~(job '(next-hour '(0))                  ;midnight
               #$(file-append rottlog "/sbin/rottlog"))
        #~(job '(next-hour '(12))                 ;noon
               #$(file-append rottlog "/sbin/rottlog"))))

(define-record-type* <rottlog-configuration>
  rottlog-configuration make-rottlog-configuration
  rottlog-configuration?
  (rottlog            rottlog-rottlog             ;package
                      (default rottlog))
  (rc-file            rottlog-rc-file             ;file-like
                      (default (file-append rottlog "/etc/rc")))
  (rotations          rottlog-rotations           ;list of <log-rotation>
                      (default %default-rotations))
  (jobs               rottlog-jobs                ;list of <mcron-job>
                      (default #f)))

(define (rottlog-etc config)
  `(("rottlog"
     ,(file-union "rottlog"
                  (cons `("rc" ,(rottlog-rc-file config))
                        (log-rotations->/etc-entries
                         (rottlog-rotations config)))))))

(define (rottlog-jobs-or-default config)
  (or (rottlog-jobs config)
      (default-jobs (rottlog-rottlog config))))

(define rottlog-service-type
  (service-type
   (name 'rottlog)
   (description
    "Periodically rotate log files using GNU@tie{}Rottlog and GNU@tie{}mcron.
Old log files are removed or compressed according to the configuration.")
   (extensions (list (service-extension etc-service-type rottlog-etc)
                     (service-extension mcron-service-type
                                        rottlog-jobs-or-default)

                     ;; Add Rottlog to the global profile so users can access
                     ;; the documentation.
                     (service-extension profile-service-type
                                        (compose list rottlog-rottlog))))
   (compose concatenate)
   (extend (lambda (config rotations)
             (rottlog-configuration
              (inherit config)
              (rotations (append (rottlog-rotations config)
                                 rotations)))))
   (default-value (rottlog-configuration))))

;;;
;;; Unattended upgrade.
;;;

(define-record-type* <unattended-upgrade-configuration>
  unattended-upgrade-configuration make-unattended-upgrade-configuration
  unattended-upgrade-configuration?
  (operating-system-file unattended-upgrade-operating-system-file
                         (default "/run/current-system/configuration.scm"))
  (schedule             unattended-upgrade-configuration-schedule
                        (default "30 01 * * 0"))
  (channels             unattended-upgrade-configuration-channels
                        (default #~%default-channels))
  (services-to-restart  unattended-upgrade-configuration-services-to-restart
                        (default '(mcron)))
  (system-expiration    unattended-upgrade-system-expiration
                        (default (* 3 30 24 3600)))
  (maximum-duration     unattended-upgrade-maximum-duration
                        (default 3600))
  (log-file             unattended-upgrade-configuration-log-file
                        (default %unattended-upgrade-log-file)))

(define %unattended-upgrade-log-file
  "/var/log/unattended-upgrade.log")

(define (unattended-upgrade-mcron-jobs config)
  (define channels
    (scheme-file "channels.scm"
                 (unattended-upgrade-configuration-channels config)))

  (define log
    (unattended-upgrade-configuration-log-file config))

  (define services
    (unattended-upgrade-configuration-services-to-restart config))

  (define expiration
    (unattended-upgrade-system-expiration config))

  (define config-file
    (unattended-upgrade-operating-system-file config))

  (define code
    (with-imported-modules (source-module-closure '((guix build utils)
                                                    (gnu services herd)))
      #~(begin
          (use-modules (guix build utils)
                       (gnu services herd)
                       (srfi srfi-19)
                       (srfi srfi-34))

          (define log
            (open-file #$log "a0"))

          (define (timestamp)
            (date->string (time-utc->date (current-time time-utc))
                          "[~4]"))

          (define (alarm-handler . _)
            (format #t "~a time is up, aborting upgrade~%"
                    (timestamp))
            (exit 1))

          ;; 'guix time-machine' needs X.509 certificates to authenticate the
          ;; Git host.
          (setenv "SSL_CERT_DIR"
                  #$(file-append nss-certs "/etc/ssl/certs"))

          ;; Make sure the upgrade doesn't take too long.
          (sigaction SIGALRM alarm-handler)
          (alarm #$(unattended-upgrade-maximum-duration config))

          ;; Redirect stdout/stderr to LOG to save the output of 'guix' below.
          (redirect-port log (current-output-port))
          (redirect-port log (current-error-port))

          (format #t "~a starting upgrade...~%" (timestamp))
          (guard (c ((invoke-error? c)
                     (report-invoke-error c)))
            (invoke #$(file-append guix "/bin/guix")
                    "time-machine" "-C" #$channels
                    "--" "system" "reconfigure" #$config-file)

            ;; 'guix system delete-generations' fails when there's no
            ;; matching generation.  Thus, catch 'invoke-error?'.
            (guard (c ((invoke-error? c)
                       (report-invoke-error c)))
              (invoke #$(file-append guix "/bin/guix")
                      "system" "delete-generations"
                      #$(string-append (number->string expiration)
                                       "s")))

            (format #t "~a restarting services...~%" (timestamp))
            (for-each restart-service '#$services)

            ;; XXX: If 'mcron' has been restarted, perhaps this isn't
            ;; reached.
            (format #t "~a upgrade complete~%" (timestamp))))))

  (define upgrade
    (program-file "unattended-upgrade" code))

  (list #~(job #$(unattended-upgrade-configuration-schedule config)
               #$upgrade)))

(define (unattended-upgrade-log-rotations config)
  (list (log-rotation
         (files
          (list (unattended-upgrade-configuration-log-file config))))))

(define unattended-upgrade-service-type
  (service-type
   (name 'unattended-upgrade)
   (extensions
    (list (service-extension mcron-service-type
                             unattended-upgrade-mcron-jobs)
          (service-extension rottlog-service-type
                             unattended-upgrade-log-rotations)))
   (description
    "Periodically upgrade the system from the current configuration.")
   (default-value (unattended-upgrade-configuration))))

;;; admin.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 services audio)
  #:use-module (guix gexp)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages mpd)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (mpd-output
            mpd-output?
            mpd-configuration
            mpd-configuration?
            mpd-service-type))

;;; Commentary:
;;;
;;; Audio related services
;;;
;;; Code:

(define-record-type* <mpd-output>
  mpd-output make-mpd-output
  mpd-output?
  (type          mpd-output-type
                 (default "pulse"))
  (name          mpd-output-name
                 (default "MPD"))
  (enabled?      mpd-output-enabled?
                 (default #t))
  (tags?         mpd-output-tags?
                 (default #t))
  (always-on?    mpd-output-always-on?
                 (default #f))
  (mixer-type    mpd-output-mixer-type
                 ;; valid: hardware, software, null, none
                 (default #f))
  (extra-options mpd-output-extra-options
                 (default '())))

(define-record-type* <mpd-configuration>
  mpd-configuration make-mpd-configuration
  mpd-configuration?
  (user         mpd-configuration-user
                (default "mpd"))
  (music-dir    mpd-configuration-music-dir
                (default "~/Music"))
  (playlist-dir mpd-configuration-playlist-dir
                (default "~/.mpd/playlists"))
  (db-file      mpd-configuration-db-file
                (default "~/.mpd/tag_cache"))
  (state-file   mpd-configuration-state-file
                (default "~/.mpd/state"))
  (sticker-file mpd-configuration-sticker-file
                (default "~/.mpd/sticker.sql"))
  (port         mpd-configuration-port
                (default "6600"))
  (address      mpd-configuration-address
                (default "any"))
  (outputs      mpd-configuration-outputs
                (default (list (mpd-output)))))

(define (mpd-output->string output)
  "Convert the OUTPUT of type <mpd-output> to a configuration file snippet."
  (let ((extra (string-join
                (map (match-lambda
                       ((key . value)
                        (format #f "  ~a \"~a\""
                                (string-map
                                 (lambda (c) (if (char=? c #\-) #\_ c))
                                 (symbol->string key))
                                value)))
                     (mpd-output-extra-options output))
                "\n")))
    (format #f "\
audio_output {
  type \"~a\"
  name \"~a\"
~:[  enabled \"no\"~%~;~]\
~:[  tags \"no\"~%~;~]\
~:[~;  always_on \"yes\"~%~]\
~@[  mixer_type \"~a\"~%~]\
~a~%}~%"
            (mpd-output-type output)
            (mpd-output-name output)
            (mpd-output-enabled? output)
            (mpd-output-tags? output)
            (mpd-output-always-on? output)
            (mpd-output-mixer-type output)
            extra)))

(define (mpd-config->file config)
  (apply
   mixed-text-file "mpd.conf"
   "pid_file \"" (mpd-file-name config "pid") "\"\n"
   (append (map mpd-output->string
                (mpd-configuration-outputs config))
           (map (match-lambda
                  ((config-name config-val)
                   (string-append config-name " \"" (config-val config) "\"\n")))
                `(("user" ,mpd-configuration-user)
                  ("music_directory" ,mpd-configuration-music-dir)
                  ("playlist_directory" ,mpd-configuration-playlist-dir)
                  ("db_file" ,mpd-configuration-db-file)
                  ("state_file" ,mpd-configuration-state-file)
                  ("sticker_file" ,mpd-configuration-sticker-file)
                  ("port" ,mpd-configuration-port)
                  ("bind_to_address" ,mpd-configuration-address))))))

(define (mpd-file-name config file)
  "Return a path in /var/run/mpd/ that is writable
   by @code{user} from @code{config}."
  (string-append "/var/run/mpd/"
                 (mpd-configuration-user config)
                 "/" file))

(define (mpd-shepherd-service config)
  (shepherd-service
   (documentation "Run the MPD (Music Player Daemon)")
   (provision '(mpd))
   (start #~(make-forkexec-constructor
             (list #$(file-append mpd "/bin/mpd")
                   "--no-daemon"
                   #$(mpd-config->file config))
             #:pid-file #$(mpd-file-name config "pid")
             #:environment-variables
             ;; Required to detect PulseAudio when run under a user account.
             '(#$(string-append
                   "XDG_RUNTIME_DIR=/run/user/"
                   (number->string
                     (passwd:uid
                       (getpwnam (mpd-configuration-user config))))))
             #:log-file #$(mpd-file-name config "log")))
   (stop  #~(make-kill-destructor))))

(define (mpd-service-activation config)
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))
        (define %user
          (getpw #$(mpd-configuration-user config)))

        (let ((directory #$(mpd-file-name config "")))
          (mkdir-p directory)
          (chown directory (passwd:uid %user) (passwd:gid %user))))))

(define mpd-service-type
  (service-type
   (name 'mpd)
   (description "Run the Music Player Daemon (MPD).")
   (extensions
    (list (service-extension shepherd-root-service-type
                             (compose list mpd-shepherd-service))
          (service-extension activation-service-type
                             mpd-service-activation)))
   (default-value (mpd-configuration))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Robin Green <greenrd@greenrd.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 services auditd)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages admin)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:export (auditd-configuration
            auditd-service-type
            %default-auditd-configuration-directory))

(define auditd.conf
  (plain-file "auditd.conf" "log_file = /var/log/audit.log\nlog_format = \
ENRICHED\nfreq = 1\nspace_left = 5%\nspace_left_action = \
syslog\nadmin_space_left_action = ignore\ndisk_full_action = \
ignore\ndisk_error_action = syslog\n"))

(define %default-auditd-configuration-directory
  (computed-file "auditd"
                 #~(begin
                     (mkdir #$output)
                     (copy-file #$auditd.conf
                                (string-append #$output "/auditd.conf")))))

(define-record-type* <auditd-configuration>
  auditd-configuration make-auditd-configuration
  auditd-configuration?
  (audit                   auditd-configuration-audit                          ; package
                           (default audit))
  (configuration-directory auditd-configuration-configuration-directory))      ; file-like

(define (auditd-shepherd-service config)
  (let* ((audit (auditd-configuration-audit config))
         (configuration-directory (auditd-configuration-configuration-directory config)))
    (list (shepherd-service
           (documentation "Auditd allows you to audit file system accesses and process execution.")
           (provision '(auditd))
           (start #~(make-forkexec-constructor
                     (list (string-append #$audit "/sbin/auditd") "-c" #$configuration-directory)
                     #:pid-file "/var/run/auditd.pid"))
           (stop #~(make-kill-destructor))))))

(define auditd-service-type
  (service-type (name 'auditd)
                (description "Allows auditing file system accesses and process execution.")
                (extensions
                 (list
                  (service-extension shepherd-root-service-type
                                     auditd-shepherd-service)))
                (default-value
                  (auditd-configuration
                   (configuration-directory %default-auditd-configuration-directory)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 services authentication)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services dbus)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages freedesktop)
  #:use-module (gnu packages openldap)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (fprintd-configuration
            fprintd-configuration?
            fprintd-service-type

            nslcd-configuration
            nslcd-configuration?
            nslcd-service-type))

(define-configuration fprintd-configuration
  (fprintd      (package fprintd)
                "The fprintd package"))

(define (fprintd-dbus-service config)
  (list (fprintd-configuration-fprintd config)))

(define fprintd-service-type
  (service-type (name 'fprintd)
                (extensions
                 (list (service-extension dbus-root-service-type
                                          fprintd-dbus-service)
                       (service-extension polkit-service-type
                                          fprintd-dbus-service)))
                (default-value (fprintd-configuration))
                (description
                 "Run fprintd, a fingerprint management daemon.")))

;;;
;;; NSS Pam LDAP service (nslcd)
;;;

(define (uglify-field-name name)
  (match name
    ('filters "filter")
    ('maps "map")
    (_ (string-map (match-lambda
                     (#\- #\_)
                     (chr chr))
                   (symbol->string name)))))

(define (value->string val)
  (cond
   ((boolean? val)
    (if val "on" "off"))
   ((number? val)
    (number->string val))
   ((symbol? val)
    (string-map (match-lambda
                     (#\- #\_)
                     (chr chr))
                   (symbol->string val)))
   (else val)))

(define (serialize-field field-name val)
  (if (eq? field-name 'pam-services)
      #t
      (format #t "~a ~a\n"
              (uglify-field-name field-name)
              (value->string val))))

(define serialize-string serialize-field)
(define serialize-boolean serialize-field)
(define serialize-number serialize-field)
(define (serialize-list field-name val)
  (map (cut serialize-field field-name <>) val))
(define-maybe string)
(define-maybe boolean)
(define-maybe number)

(define (ssl-option? val)
  (or (boolean? val)
      (eq? val 'start-tls)))
(define serialize-ssl-option serialize-field)
(define-maybe ssl-option)

(define (tls-reqcert-option? val)
  (member val '(never allow try demand hard)))
(define serialize-tls-reqcert-option serialize-field)
(define-maybe tls-reqcert-option)

(define (deref-option? val)
  (member val '(never searching finding always)))
(define serialize-deref-option serialize-field)
(define-maybe deref-option)

(define (comma-separated-list-of-strings? val)
  (and (list? val)
       (every string? val)))
(define (ignore-users-option? val)
  (or (comma-separated-list-of-strings? val)
      (eq? 'all-local val)))
(define (serialize-ignore-users-option field-name val)
  (serialize-field field-name (if (eq? 'all-local val)
                                  val
                                  (string-join val ","))))
(define-maybe ignore-users-option)

(define (log-option? val)
  (let ((valid-scheme? (lambda (scheme)
                         (or (string? scheme)
                             (member scheme '(none syslog))))))
    (match val
      ((scheme level)
       (and (valid-scheme? scheme)
            (member level '(crit error warning notice info debug))))
      ((scheme)
       (valid-scheme? scheme)))))
(define (serialize-log-option field-name val)
  (serialize-field field-name
                   (string-join (map (cut format #f "~a" <>) val))))

(define (valid-map? val)
  "Is VAL a supported map name?"
  (member val
          '(alias aliases ether ethers group host hosts netgroup network networks
            passwd protocol protocols rpc service services shadow)))

(define (scope-option? val)
  (let ((valid-scopes '(subtree onelevel base children)))
    (match val
      ((map-name scope)
       (and (valid-map? map-name)
            (member scope valid-scopes)))
      ((scope)
       (member scope valid-scopes)))))
(define (serialize-scope-option field-name val)
  (serialize-field field-name
                   (string-join (map (cut format #f "~a" <>) val))))

(define (map-entry? val)
  (match val
    (((? valid-map? map-name)
      (? string? attribute)
      (? string? new-attribute)) #t)
    (_ #f)))

(define (list-of-map-entries? val)
  (and (list? val)
       (every map-entry? val)))

(define (filter-entry? val)
  (match val
    (((? valid-map? map-name)
      (? string? filter-expression)) #t)
    (_ #f)))

(define (list-of-filter-entries? val)
  (and (list? val)
       (every filter-entry? val)))

(define (serialize-filter-entry field-name val)
  (serialize-field 'filter
                   (match val
                     (((? valid-map? map-name)
                       (? string? filter-expression))
                      (string-append (symbol->string map-name)
                                     " " filter-expression)))))

(define (serialize-list-of-filter-entries field-name val)
  (for-each (cut serialize-filter-entry field-name <>) val))

(define (serialize-map-entry field-name val)
  (serialize-field 'map
                   (match val
                     (((? valid-map? map-name)
                       (? string? attribute)
                       (? string? new-attribute))
                      (string-append (symbol->string map-name)
                                     " " attribute
                                     " " new-attribute)))))

(define (serialize-list-of-map-entries field-name val)
  (for-each (cut serialize-map-entry field-name <>) val))

(define-configuration nslcd-configuration
  (nss-pam-ldapd
   (package nss-pam-ldapd)
   "The NSS-PAM-LDAPD package to use.")

  ;; Runtime options
  (threads
   (maybe-number 'disabled)
   "The number of threads to start that can handle requests and perform LDAP
queries.  Each thread opens a separate connection to the LDAP server.  The
default is to start 5 threads.")
  (uid
   (string "nslcd")
   "This specifies the user id with which the daemon should be run.")
  (gid
   (string "nslcd")
   "This specifies the group id with which the daemon should be run.")
  (log
   (log-option '("/var/log/nslcd" info))
   "This option controls the way logging is done via a list containing SCHEME
and LEVEL.  The SCHEME argument may either be the symbols \"none\" or
\"syslog\", or an absolute file name.  The LEVEL argument is optional and
specifies the log level.  The log level may be one of the following symbols:
\"crit\", \"error\", \"warning\", \"notice\", \"info\" or \"debug\".  All
messages with the specified log level or higher are logged.")

  ;; LDAP connection settings
  (uri
   (list '("ldap://localhost:389/"))
   "The list of LDAP server URIs.  Normally, only the first server will be
used with the following servers as fall-back.")
  (ldap-version
   (maybe-string 'disabled)
   "The version of the LDAP protocol to use.  The default is to use the
maximum version supported by the LDAP library.")
  (binddn
   (maybe-string 'disabled)
   "Specifies the distinguished name with which to bind to the directory
server for lookups.  The default is to bind anonymously.")
  (bindpw
   (maybe-string 'disabled)
   "Specifies the credentials with which to bind.  This option is only
applicable when used with binddn.")
  (rootpwmoddn
   (maybe-string 'disabled)
   "Specifies the distinguished name to use when the root user tries to modify
a user's password using the PAM module.")
  (rootpwmodpw
   (maybe-string 'disabled)
   "Specifies the credentials with which to bind if the root user tries to
change a user's password.  This option is only applicable when used with
rootpwmoddn")

  ;; SASL authentication options
  (sasl-mech
   (maybe-string 'disabled)
   "Specifies the SASL mechanism to be used when performing SASL
authentication.")
  (sasl-realm
   (maybe-string 'disabled)
   "Specifies the SASL realm to be used when performing SASL authentication.")
  (sasl-authcid
   (maybe-string 'disabled)
   "Specifies the authentication identity to be used when performing SASL
authentication.")
  (sasl-authzid
   (maybe-string 'disabled)
   "Specifies the authorization identity to be used when performing SASL
authentication.")
  (sasl-canonicalize?
   (maybe-boolean 'disabled)
   "Determines whether the LDAP server host name should be canonicalised.  If
this is enabled the LDAP library will do a reverse host name lookup.  By
default, it is left up to the LDAP library whether this check is performed or
not.")

  ;; Kerberos authentication options
  (krb5-ccname
   (maybe-string 'disabled)
   "Set the name for the GSS-API Kerberos credentials cache.")

  ;; Search / mapping options
  (base
   (string "dc=example,dc=com")
   "The directory search base.")
  (scope
   (scope-option '(subtree))
   "Specifies the search scope (subtree, onelevel, base or children).  The
default scope is subtree; base scope is almost never useful for name service
lookups; children scope is not supported on all servers.")
  (deref
   (maybe-deref-option 'disabled)
   "Specifies the policy for dereferencing aliases.  The default policy is to
never dereference aliases.")
  (referrals
   (maybe-boolean 'disabled)
   "Specifies whether automatic referral chasing should be enabled.  The
default behaviour is to chase referrals.")
  (maps
   (list-of-map-entries '())
   "This option allows for custom attributes to be looked up instead of the
default RFC 2307 attributes.  It is a list of maps, each consisting of the
name of a map, the RFC 2307 attribute to match and the query expression for
the attribute as it is available in the directory.")
  (filters
   (list-of-filter-entries '())
   "A list of filters consisting of the name of a map to which the filter
applies and an LDAP search filter expression.")

  ;; Timing / reconnect options
  (bind-timelimit
   (maybe-number 'disabled)
   "Specifies the time limit in seconds to use when connecting to the
directory server.  The default value is 10 seconds.")
  (timelimit
   (maybe-number 'disabled)
   "Specifies the time limit (in seconds) to wait for a response from the LDAP
server.  A value of zero, which is the default, is to wait indefinitely for
searches to be completed.")
  (idle-timelimit
   (maybe-number 'disabled)
   "Specifies the period if inactivity (in seconds) after which the con‐
nection to the LDAP server will be closed.  The default is not to time out
connections.")
  (reconnect-sleeptime
   (maybe-number 'disabled)
   "Specifies the number of seconds to sleep when connecting to all LDAP
servers fails.  By default one second is waited between the first failure and
the first retry.")
  (reconnect-retrytime
   (maybe-number 'disabled)
   "Specifies the time after which the LDAP server is considered to be
permanently unavailable.  Once this time is reached retries will be done only
once per this time period.  The default value is 10 seconds.")

  ;; TLS options
  (ssl
   (maybe-ssl-option 'disabled)
   "Specifies whether to use SSL/TLS or not (the default is not to).  If
'start-tls is specified then StartTLS is used rather than raw LDAP over SSL.")
  (tls-reqcert
   (maybe-tls-reqcert-option 'disabled)
   "Specifies what checks to perform on a server-supplied certificate.
The meaning of the values is described in the ldap.conf(5) manual page.")
  (tls-cacertdir
   (maybe-string 'disabled)
   "Specifies the directory containing X.509 certificates for peer authen‐
tication.  This parameter is ignored when using GnuTLS.")
  (tls-cacertfile
   (maybe-string 'disabled)
   "Specifies the path to the X.509 certificate for peer authentication.")
  (tls-randfile
   (maybe-string 'disabled)
   "Specifies the path to an entropy source.  This parameter is ignored when
using GnuTLS.")
  (tls-ciphers
   (maybe-string 'disabled)
   "Specifies the ciphers to use for TLS as a string.")
  (tls-cert
   (maybe-string 'disabled)
   "Specifies the path to the file containing the local certificate for client
TLS authentication.")
  (tls-key
   (maybe-string 'disabled)
   "Specifies the path to the file containing the private key for client TLS
authentication.")

  ;; Other options
  (pagesize
   (maybe-number 'disabled)
   "Set this to a number greater than 0 to request paged results from the LDAP
server in accordance with RFC2696.  The default (0) is to not request paged
results.")
  (nss-initgroups-ignoreusers
   (maybe-ignore-users-option 'disabled)
   "This option prevents group membership lookups through LDAP for the
specified users.  Alternatively, the value 'all-local may be used.  With that
value nslcd builds a full list of non-LDAP users on startup.")
  (nss-min-uid
   (maybe-number 'disabled)
   "This option ensures that LDAP users with a numeric user id lower than the
specified value are ignored.")
  (nss-uid-offset
   (maybe-number 'disabled)
   "This option specifies an offset that is added to all LDAP numeric user
ids.  This can be used to avoid user id collisions with local users.")
  (nss-gid-offset
   (maybe-number 'disabled)
   "This option specifies an offset that is added to all LDAP numeric group
ids.  This can be used to avoid user id collisions with local groups.")
  (nss-nested-groups
   (maybe-boolean 'disabled)
   "If this option is set, the member attribute of a group may point to
another group.  Members of nested groups are also returned in the higher level
group and parent groups are returned when finding groups for a specific user.
The default is not to perform extra searches for nested groups.")
  (nss-getgrent-skipmembers
   (maybe-boolean 'disabled)
   "If this option is set, the group member list is not retrieved when looking
up groups.  Lookups for finding which groups a user belongs to will remain
functional so the user will likely still get the correct groups assigned on
login.")
  (nss-disable-enumeration
   (maybe-boolean 'disabled)
   "If this option is set, functions which cause all user/group entries to be
loaded from the directory will not succeed in doing so.  This can dramatically
reduce LDAP server load in situations where there are a great number of users
and/or groups.  This option is not recommended for most configurations.")
  (validnames
   (maybe-string 'disabled)
   "This option can be used to specify how user and group names are verified
within the system.  This pattern is used to check all user and group names
that are requested and returned from LDAP.")
  (ignorecase
   (maybe-boolean 'disabled)
   "This specifies whether or not to perform searches using case-insensitive
matching.  Enabling this could open up the system to authorization bypass
vulnerabilities and introduce nscd cache poisoning vulnerabilities which allow
denial of service.")
  (pam-authc-ppolicy
   (maybe-boolean 'disabled)
   "This option specifies whether password policy controls are requested and
handled from the LDAP server when performing user authentication.")
  (pam-authc-search
   (maybe-string 'disabled)
   "By default nslcd performs an LDAP search with the user's credentials after
BIND (authentication) to ensure that the BIND operation was successful.  The
default search is a simple check to see if the user's DN exists.  A search
filter can be specified that will be used instead.  It should return at least
one entry.")
  (pam-authz-search
   (maybe-string 'disabled)
   "This option allows flexible fine tuning of the authorisation check that
should be performed.  The search filter specified is executed and if any
entries match, access is granted, otherwise access is denied.")
  (pam-password-prohibit-message
   (maybe-string 'disabled)
   "If this option is set password modification using pam_ldap will be denied
and the specified message will be presented to the user instead.  The message
can be used to direct the user to an alternative means of changing their
password.")

  ;; Options for extension of pam-root-service-type.
  (pam-services
   (list '())
   "List of pam service names for which LDAP authentication should suffice."))

(define %nslcd-accounts
  (list (user-group
         (name "nslcd")
         (system? #t))
        (user-account
         (name "nslcd")
         (group "nslcd")
         (comment "NSLCD service account")
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin"))
         (system? #t))))

(define (nslcd-config-file config)
  "Return an NSLCD configuration file."
  (plain-file "nslcd.conf"
              (with-output-to-string
                (lambda ()
                  (serialize-configuration config nslcd-configuration-fields)
                  ;; The file must end with a newline character.
                  (format #t "\n")))))

;; XXX: The file should only be readable by root if it contains a "bindpw"
;; declaration.  Unfortunately, this etc-service-type extension does not
;; support setting file modes, so we do this in the activation service.
(define (nslcd-etc-service config)
  `(("nslcd.conf" ,(nslcd-config-file config))))

(define (nslcd-shepherd-service config)
  (list (shepherd-service
         (documentation "Run the nslcd service for resolving names from LDAP.")
         (provision '(nslcd))
         (requirement '(networking user-processes))
         (start #~(make-forkexec-constructor
                   (list (string-append #$(nslcd-configuration-nss-pam-ldapd config)
                                        "/sbin/nslcd")
                         "--nofork")
                   #:pid-file "/var/run/nslcd/nslcd.pid"
                   #:environment-variables
                   (list (string-append "LD_LIBRARY_PATH="
                                        #$(nslcd-configuration-nss-pam-ldapd config)
                                        "/lib"))))
         (stop #~(make-kill-destructor)))))

(define (pam-ldap-pam-service config)
  "Return a PAM service for LDAP authentication."
  (define pam-ldap-module
    #~(string-append #$(nslcd-configuration-nss-pam-ldapd config)
                     "/lib/security/pam_ldap.so"))
  (lambda (pam)
    (if (member (pam-service-name pam)
                (nslcd-configuration-pam-services config))
        (let ((sufficient
               (pam-entry
                (control "sufficient")
                (module pam-ldap-module))))
          (pam-service
           (inherit pam)
           (auth (cons sufficient (pam-service-auth pam)))
           (session (cons sufficient (pam-service-session pam)))
           (account (cons sufficient (pam-service-account pam)))))
        pam)))

(define (pam-ldap-pam-services config)
  (list (pam-ldap-pam-service config)))

(define nslcd-service-type
  (service-type
   (name 'nslcd)
   (description "Run the NSLCD service for looking up names from LDAP.")
   (extensions
    (list (service-extension account-service-type
                             (const %nslcd-accounts))
          (service-extension etc-service-type
                             nslcd-etc-service)
          (service-extension activation-service-type
                             (const #~(begin
                                        (use-modules (guix build utils))
                                        (let ((rundir "/var/run/nslcd")
                                              (user (getpwnam "nslcd")))
                                          (mkdir-p rundir)
                                          (chown rundir (passwd:uid user) (passwd:gid user))
                                          (chmod rundir #o755)
                                          (when (file-exists? "/etc/nslcd.conf")
                                            (chmod "/etc/nslcd.conf" #o400))))))
          (service-extension pam-root-service-type
                             pam-ldap-pam-services)
          (service-extension nscd-service-type
                             (const (list nss-pam-ldapd)))
          (service-extension shepherd-root-service-type
                             nslcd-shepherd-service)))
   (default-value (nslcd-configuration))))

(define (generate-nslcd-documentation)
  (generate-documentation
   `((nslcd-configuration ,nslcd-configuration-fields))
   'nslcd-configuration))