code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.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 services nfs)
  #:use-module (gnu)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages onc-rpc)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages nfs)
  #:use-module (guix)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (gnu build file-systems)
  #:export (rpcbind-service-type
            rpcbind-configuration
            rpcbind-configuration?

            pipefs-service-type
            pipefs-configuration
            pipefs-configuration?

            idmap-service-type
            idmap-configuration
            idmap-configuration?

            gss-service-type
            gss-configuration
            gss-configuration?

            nfs-service-type
            nfs-configuration
            nfs-configuration?))

(define default-pipefs-directory "/var/lib/nfs/rpc_pipefs")

(define-record-type* <rpcbind-configuration>
  rpcbind-configuration make-rpcbind-configuration
  rpcbind-configuration?
  (rpcbind             rpcbind-configuration-rpcbind
                       (default rpcbind))
  (warm-start?         rpcbind-configuration-warm-start?
                       (default #t)))

(define rpcbind-service-type
  (let ((proc
         (lambda (config)
           (define rpcbind
             (rpcbind-configuration-rpcbind config))

           (define rpcbind-command
             #~(list (string-append #$rpcbind "/sbin/rpcbind") "-f"
                     #$@(if (rpcbind-configuration-warm-start? config) '("-w") '())))

           (shepherd-service
            (documentation "Start the RPC bind daemon.")
            (requirement '(networking))
            (provision '(rpcbind-daemon))

            (start #~(make-forkexec-constructor #$rpcbind-command))
            (stop #~(make-kill-destructor))))))
    (service-type
     (name 'rpcbind)
     (extensions
      (list (service-extension shepherd-root-service-type
                               (compose list proc))))
     ;; We use the extensions feature to allow other services to automatically
     ;; configure and start this service.  Only one value can be provided.  We
     ;; override it with the value returned by the extending service.
     (compose identity)
     (extend (lambda (config values)
               (match values
                 ((first . rest) first)
                 (_ config))))
     (default-value (rpcbind-configuration)))))

(define-record-type* <pipefs-configuration>
  pipefs-configuration make-pipefs-configuration
  pipefs-configuration?
  (mount-point           pipefs-configuration-mount-point
                         (default default-pipefs-directory)))

(define pipefs-service-type
  (let ((proc
         (lambda (config)
           (define pipefs-directory (pipefs-configuration-mount-point config))

           (shepherd-service
            (documentation "Mount the pipefs pseudo file system.")
            (provision '(rpc-pipefs))

            (start #~(lambda ()
                       (mkdir-p #$pipefs-directory)
                       (mount "rpc_pipefs" #$pipefs-directory "rpc_pipefs")
                       (member #$pipefs-directory (mount-points))))

            (stop #~(lambda (pid . args)
                      (umount #$pipefs-directory MNT_DETACH)
                      (not (member #$pipefs-directory (mount-points)))))))))
    (service-type
     (name 'pipefs)
     (extensions
      (list (service-extension shepherd-root-service-type
                               (compose list proc))))
     ;; We use the extensions feature to allow other services to automatically
     ;; configure and start this service.  Only one value can be provided.  We
     ;; override it with the value returned by the extending service.
     (compose identity)
     (extend (lambda (config values) (first values)))
     (default-value (pipefs-configuration)))))

(define-record-type* <gss-configuration>
  gss-configuration make-gss-configuration
  gss-configuration?
  (pipefs-directory      gss-configuration-pipefs-directory
                         (default default-pipefs-directory))
  (nfs-utils             gss-configuration-gss
                         (default nfs-utils)))

(define gss-service-type
  (let ((proc
         (lambda (config)
           (define nfs-utils
             (gss-configuration-gss config))

           (define pipefs-directory
             (gss-configuration-pipefs-directory config))

           (define gss-command
             #~(list (string-append #$nfs-utils "/sbin/rpc.gssd") "-f"
                     "-p" #$pipefs-directory))

           (shepherd-service
            (documentation "Start the RPC GSS daemon.")
            (requirement '(rpcbind-daemon rpc-pipefs))
            (provision '(gss-daemon))

            (start #~(make-forkexec-constructor #$gss-command))
            (stop #~(make-kill-destructor))))))
    (service-type
     (name 'gss)
     (extensions
      (list (service-extension shepherd-root-service-type
                               (compose list proc))))
     ;; We use the extensions feature to allow other services to automatically
     ;; configure and start this service.  Only one value can be provided.  We
     ;; override it with the value returned by the extending service.
     (compose identity)
     (extend (lambda (config values)
               (match values
                 ((first . rest) first)
                 (_ config))))
     (default-value (gss-configuration)))))

(define-record-type* <idmap-configuration>
  idmap-configuration make-idmap-configuration
  idmap-configuration?
  (pipefs-directory      idmap-configuration-pipefs-directory
                         (default default-pipefs-directory))
  (domain                idmap-configuration-domain
                         (default #f))
  (nfs-utils             idmap-configuration-nfs-utils
                         (default nfs-utils))
  (verbosity             idmap-configuration-verbosity
                         (default 0)))

(define idmap-service-type
  (let ((proc
         (lambda (config)

           (define nfs-utils
             (idmap-configuration-nfs-utils config))

           (define pipefs-directory
             (idmap-configuration-pipefs-directory config))

           (define domain (idmap-configuration-domain config))

           (define (idmap-config-file config)
             (plain-file "idmapd.conf"
                         (string-append
                          "\n[General]\n"
                          "Verbosity = "
                          (number->string
                           (idmap-configuration-verbosity config))
                          "\n"
                          (if domain
                              (format #f "Domain = ~a\n" domain)
                              "")
                          "\n[Mapping]\n"
                          "Nobody-User = nobody\n"
                          "Nobody-Group = nogroup\n")))

           (define idmap-command
             #~(list (string-append #$nfs-utils "/sbin/rpc.idmapd") "-f"
                     "-p" #$pipefs-directory
                     ;; TODO: this is deprecated
                     "-c" #$(idmap-config-file config)))

           (shepherd-service
            (documentation "Start the RPC IDMAP daemon.")
            (requirement '(rpcbind-daemon rpc-pipefs))
            (provision '(idmap-daemon))
            (start #~(make-forkexec-constructor #$idmap-command))
            (stop #~(make-kill-destructor))))))
    (service-type
     (name 'idmap)
     (extensions
      (list (service-extension shepherd-root-service-type
                               (compose list proc))))
     ;; We use the extensions feature to allow other services to automatically
     ;; configure and start this service.  Only one value can be provided.  We
     ;; override it with the value returned by the extending service.
     (compose identity)
     (extend (lambda (config values) (first values)))
     (default-value (idmap-configuration)))))

(define-record-type* <nfs-configuration>
  nfs-configuration make-nfs-configuration
  nfs-configuration?
  (nfs-utils           nfs-configuration-nfs-utils
                       (default nfs-utils))
  (nfs-versions        nfs-configuration-nfs-versions
                       (default '("4.2" "4.1" "4.0")))
  (exports             nfs-configuration-exports
                       (default '()))
  (rpcmountd-port      nfs-configuration-rpcmountd-port
                       (default #f))
  (rpcstatd-port       nfs-configuration-rpcstatd-port
                       (default #f))
  (rpcbind             nfs-configuration-rpcbind
                       (default rpcbind))
  (idmap-domain        nfs-configuration-idmap-domain
                       (default "localdomain"))
  (nfsd-port           nfs-configuration-nfsd-port
                       (default 2049))
  (nfsd-threads        nfs-configuration-nfsd-threads
                       (default 8))
  (nfsd-tcp?           nfs-configuration-nfsd-tcp?
                       (default #t))
  (nfsd-udp?           nfs-configuration-nfsd-udp?
                       (default #f))
  (pipefs-directory    nfs-configuration-pipefs-directory
                       (default default-pipefs-directory))
  ;; List of modules to debug; any of nfsd, nfs, rpc, idmap, statd, or mountd.
  (debug               nfs-configuration-debug
                       (default '())))

(define (nfs-shepherd-services config)
  "Return a list of <shepherd-service> for the NFS daemons with CONFIG."
  (match-record config <nfs-configuration>
    (nfs-utils nfs-versions exports
               rpcmountd-port rpcstatd-port nfsd-port nfsd-threads
               nfsd-tcp? nfsd-udp?
               pipefs-directory debug)
    (list (shepherd-service
           (documentation "Mount the nfsd pseudo file system.")
           (provision '(/proc/fs/nfsd))
           (start #~(lambda ()
                      (mount "nfsd" "/proc/fs/nfsd" "nfsd")
                      (member "/proc/fs/nfsd" (mount-points))))

           (stop #~(lambda (pid . args)
                     (umount "/proc/fs/nfsd" MNT_DETACH)
                     (not (member "/proc/fs/nfsd" (mount-points))))))
          (shepherd-service
           (documentation "Run the NFS statd daemon.")
           (provision '(rpc.statd))
           (requirement '(/proc/fs/nfsd rpcbind-daemon))
           (start
            #~(make-forkexec-constructor
               (list #$(file-append nfs-utils "/sbin/rpc.statd")
                     ;; TODO: notification support may require a little more
                     ;; configuration work.
                     "--no-notify"
                     #$@(if (member 'statd debug)
                            '("--no-syslog") ; verbose logging to stderr
                            '())
                     "--foreground"
                     #$@(if rpcstatd-port
                            '("--port" (number->string rpcstatd-port))
                            '()))
               #:pid-file "/var/run/rpc.statd.pid"))
           (stop #~(make-kill-destructor)))
          (shepherd-service
           (documentation "Run the NFS mountd daemon.")
           (provision '(rpc.mountd))
           (requirement '(/proc/fs/nfsd rpc.statd))
           (start
            #~(make-forkexec-constructor
               (list #$(file-append nfs-utils "/sbin/rpc.mountd")
                     "--foreground"
                     #$@(if (member 'mountd debug)
                            '("--debug" "all")
                            '())
                     #$@(if rpcmountd-port
                            '("--port" (number->string rpcmountd-port))
                            '()))))
           (stop #~(make-kill-destructor)))
          (shepherd-service
           (documentation "Run the NFS daemon.")
           (provision '(rpc.nfsd))
           (requirement '(/proc/fs/nfsd rpc.statd networking))
           (start
            #~(lambda _
                (zero? (apply system* #$(file-append nfs-utils "/sbin/rpc.nfsd")
                              (list
                               #$@(if (member 'nfsd debug)
                                      '("--debug")
                                      '())
                               "--port" #$(number->string nfsd-port)
                               #$@(map (lambda (version)
                                         (string-append "--nfs-version=" version))
                                       nfs-versions)
                               #$(number->string nfsd-threads)
                               #$(if nfsd-tcp?
                                     "--tcp"
                                     "--no-tcp")
                               #$(if nfsd-udp?
                                     "--udp"
                                     "--no-udp"))))))
           (stop
            #~(lambda _
                (zero?
                 (system* #$(file-append nfs-utils "/sbin/rpc.nfsd") "0")))))
          (shepherd-service
           (documentation "Run the NFS mountd daemon and refresh exports.")
           (provision '(nfs))
           (requirement '(/proc/fs/nfsd rpc.nfsd rpc.mountd rpc.statd rpcbind-daemon))
           (start
            #~(lambda _
                (let ((rpcdebug #$(file-append nfs-utils "/sbin/rpcdebug")))
                  (cond
                   ((member 'nfsd '#$debug)
                    (system* rpcdebug "-m" "nfsd" "-s" "all"))
                   ((member 'nfs '#$debug)
                    (system* rpcdebug "-m" "nfs" "-s" "all"))
                   ((member 'rpc '#$debug)
                    (system* rpcdebug "-m" "rpc" "-s" "all"))))
                (zero? (system*
                        #$(file-append nfs-utils "/sbin/exportfs")
                        "-r"            ; re-export
                        "-a"            ; everthing
                        "-v"            ; be verbose
                        "-d" "all"      ; debug
                        ))))
           (stop
            #~(lambda _
                (let ((rpcdebug #$(file-append nfs-utils "/sbin/rpcdebug")))
                  (cond
                   ((member 'nfsd '#$debug)
                    (system* rpcdebug "-m" "nfsd" "-c" "all"))
                   ((member 'nfs '#$debug)
                    (system* rpcdebug "-m" "nfs" "-c" "all"))
                   ((member 'rpc '#$debug)
                    (system* rpcdebug "-m" "rpc" "-c" "all"))))
                #t))
           (respawn? #f)))))

(define %nfs-activation
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))

        ;; directory containing monitor list
        (mkdir-p "/var/lib/nfs/sm")
        ;; Needed for client recovery tracking
        (mkdir-p "/var/lib/nfs/v4recovery")
        (let ((user (getpw "nobody")))
          (chown "/var/lib/nfs"
                 (passwd:uid user)
                 (passwd:gid user))
          (chown "/var/lib/nfs/v4recovery"
                 (passwd:uid user)
                 (passwd:gid user)))
        #t)))

(define nfs-service-type
  (service-type
   (name 'nfs)
   (extensions
    (list
     (service-extension shepherd-root-service-type nfs-shepherd-services)
     (service-extension activation-service-type (const %nfs-activation))
     (service-extension etc-service-type
                        (lambda (config)
                          `(("exports"
                             ,(plain-file "exports"
                                          (string-join
                                           (map string-join
                                                (nfs-configuration-exports config))
                                           "\n"))))))
     ;; The NFS service depends on these other services.  They are extended so
     ;; that users don't need to configure them manually.
     (service-extension idmap-service-type
                        (lambda (config)
                          (idmap-configuration
                           (domain (nfs-configuration-idmap-domain config))
                           (verbosity
                            (if (member 'idmap (nfs-configuration-debug config))
                                10 0))
                           (pipefs-directory (nfs-configuration-pipefs-directory config))
                           (nfs-utils (nfs-configuration-nfs-utils config)))))
     (service-extension pipefs-service-type
                        (lambda (config)
                          (pipefs-configuration
                           (mount-point (nfs-configuration-pipefs-directory config)))))
     (service-extension rpcbind-service-type
                        (lambda (config)
                          (rpcbind-configuration
                           (rpcbind (nfs-configuration-rpcbind config)))))))
   (description
    "Run all NFS daemons and refresh the list of exported file systems.")))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020, 2021 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Peng Mei Yu <i@pengmeiyu.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 services nix)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages package-management)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services web)
  #:use-module (gnu services)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (guix modules)
  #:export (nix-service-type

            nix-configuration
            nix-configuration?))

;;; Commentary:
;;;
;;; This module provides a service definition for the Nix daemon.
;;;
;;; Code:

(define-record-type* <nix-configuration>
  nix-configuration make-nix-configuration
  nix-configuration?
  (package             nix-configuration-package ;package
                       (default nix))
  (sandbox             nix-configuration-sandbox ;boolean
                       (default #t))
  (build-sandbox-items nix-configuration-build-sandbox-items ;list of strings
                       (default '()))
  (extra-config        nix-configuration-extra-config ;list of strings
                       (default '()))
  (extra-options       nix-configuration-extra-options ;list of strings
                       (default '())))

;; Copied from gnu/services/base.scm
(define* (nix-build-accounts count #:key
                             (group "nixbld")
                             (shadow shadow))
  "Return a list of COUNT user accounts for Nix build users with the given
GID."
  (unfold (cut > <> count)
          (lambda (n)
            (user-account
             (name (format #f "nixbld~2,'0d" n))
             (system? #t)
             (group group)
             (supplementary-groups (list group "kvm"))
             (comment (format #f "Nix Build User ~2d" n))
             (home-directory "/var/empty")
             (shell (file-append shadow "/sbin/nologin"))))
          1+
          1))
(define (nix-accounts _)
  "Return the user accounts and user groups."
  (cons (user-group
         (name "nixbld")
         (system? #t)

         ;; Use a fixed GID so that we can create the store with the right
         ;; owner.
         (id 40000))
        (nix-build-accounts 10 #:group "nixbld")))

(define (nix-activation _)
  ;; Return the activation gexp.
  #~(begin
      (use-modules (guix build utils)
                   (srfi srfi-26))
      (for-each (cut mkdir-p <>) '("/nix/store" "/nix/var/log"
                                   "/nix/var/nix/gcroots/per-user"
                                   "/nix/var/nix/profiles/per-user"))
      (chown "/nix/store"
             (passwd:uid (getpw "root")) (group:gid (getpw "nixbld01")))
      (chmod "/nix/store" #o775)
      (for-each (cut chmod <> #o777) '("/nix/var/nix/profiles"
                                       "/nix/var/nix/profiles/per-user"))))

(define nix-service-etc
  (match-lambda
    (($ <nix-configuration> package sandbox build-sandbox-items extra-config)
     (let ((ref-file (references-file package)))
       `(("nix/nix.conf"
          ,(computed-file
            "nix.conf"
            #~(begin
                (use-modules (srfi srfi-26)
                             (ice-9 format))
                (with-output-to-file #$output
                  (lambda _
                    (define internal-sandbox-paths
                      (call-with-input-file #$ref-file read))

                    (format #t "sandbox = ~a~%" (if #$sandbox "true" "false"))
                    ;; config.nix captures store file names.
                    (format #t "build-sandbox-paths = ~{~a ~}~%"
                            (append (list (string-append "/bin/sh=" #$bash-minimal "/bin/sh"))
                                    internal-sandbox-paths
                                    '#$build-sandbox-items))
                    (for-each (cut display <>) '#$extra-config)))))))))))

(define nix-shepherd-service
  ;; Return a <shepherd-service> for Nix.
  (match-lambda
    (($ <nix-configuration> package _ _ _ extra-options)
     (list
      (shepherd-service
       (provision '(nix-daemon))
       (documentation "Run nix-daemon.")
       (requirement '())
       (start #~(make-forkexec-constructor
                 (list (string-append #$package "/bin/nix-daemon")
                       #$@extra-options)))
       (respawn? #f)
       (stop #~(make-kill-destructor)))))))

(define nix-service-type
  (service-type
   (name 'nix)
   (extensions
    (list (service-extension shepherd-root-service-type nix-shepherd-service)
          (service-extension account-service-type nix-accounts)
          (service-extension activation-service-type nix-activation)
          (service-extension etc-service-type nix-service-etc)
          (service-extension profile-service-type
                             (compose list nix-configuration-package))))
   (description "Run the Nix daemon.")
   (default-value (nix-configuration))))

;;; nix.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.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 pam-mount)
  #:use-module (gnu packages admin)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (gnu system pam)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:export (pam-mount-configuration
            pam-mount-configuration?
            pam-mount-service-type))

(define %pam-mount-default-configuration
  `((debug (@ (enable "0")))
    (mntoptions (@ (allow ,(string-join
                            '("nosuid" "nodev" "loop"
                              "encryption" "fsck" "nonempty"
                              "allow_root" "allow_other")
                            ","))))
    (mntoptions (@ (require "nosuid,nodev")))
    (logout (@ (wait "0")
               (hup "0")
               (term "no")
               (kill "no")))
    (mkmountpoint (@ (enable "1")
                     (remove "true")))))

(define (make-pam-mount-configuration-file config)
  (computed-file
   "pam_mount.conf.xml"
   #~(begin
       (use-modules (sxml simple))
       (call-with-output-file #$output
         (lambda (port)
           (sxml->xml
            '(*TOP*
              (*PI* xml "version='1.0' encoding='utf-8'")
              (pam_mount
               #$@(pam-mount-configuration-rules config)
               (pmvarrun
                #$(file-append pam-mount
                               "/sbin/pmvarrun -u '%(USER)' -o '%(OPERATION)'"))
               (cryptmount
                #$(file-append pam-mount
                               (string-append
                                "/sbin/mount.crypt"
                                " '%(if %(CIPHER),-ocipher=%(CIPHER))'"
                                " '%(if %(FSKEYCIPHER),"
                                "-ofsk_cipher=%(FSKEYCIPHER))'"
                                " '%(if %(FSKEYHASH),-ofsk_hash=%(FSKEYHASH))'"
                                " '%(if %(FSKEYPATH),-okeyfile=%(FSKEYPATH))'"
                                " '%(if %(OPTIONS),-o%(OPTIONS))'"
                                " '%(VOLUME)' '%(MNTPT)'")))
               (cryptumount
                #$(file-append pam-mount "/sbin/umount.crypt '%(MNTPT)'"))))
            port))))))

(define-record-type* <pam-mount-configuration>
  pam-mount-configuration
  make-pam-mount-configuration
  pam-mount-configuration?
  (rules pam-mount-configuration-rules
         (default %pam-mount-default-configuration)))

(define (pam-mount-etc-service config)
  `(("security/pam_mount.conf.xml"
     ,(make-pam-mount-configuration-file config))))

(define (pam-mount-pam-service config)
  (define optional-pam-mount
    (pam-entry
     (control "optional")
     (module #~(string-append #$pam-mount "/lib/security/pam_mount.so"))))
  (list (lambda (pam)
          (if (member (pam-service-name pam)
                      '("login" "su" "slim" "gdm-password"))
              (pam-service
               (inherit pam)
               (auth (append (pam-service-auth pam)
                             (list optional-pam-mount)))
               (session (append (pam-service-session pam)
                                (list optional-pam-mount))))
              pam))))

(define pam-mount-service-type
  (service-type
   (name 'pam-mount)
   (extensions (list (service-extension etc-service-type
                                        pam-mount-etc-service)
                     (service-extension pam-root-service-type
                                        pam-mount-pam-service)))
   (default-value (pam-mount-configuration))
   (description "Activate PAM-Mount support.  It allows mounting volumes for
specific users when they log in.")))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.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 services pm)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages linux)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system shadow)
  #:export (tlp-service-type
            tlp-configuration

            thermald-configuration
            thermald-service-type))

(define (uglify-field-name field-name)
  (let ((str (symbol->string field-name)))
    (string-join (string-split
                  (string-upcase
                   (if (string-suffix? "?" str)
                       (substring str 0 (1- (string-length str)))
                       str))
                  #\-)
                 "_")))

(define (serialize-field field-name val)
  (format #t "~a=~a\n" (uglify-field-name field-name) val))

(define (serialize-boolean field-name val)
  (serialize-field field-name (if val "1" "0")))
(define-maybe boolean)

(define (serialize-string field-name val)
  (serialize-field field-name val))
(define-maybe string)

(define (space-separated-string-list? val)
  (and (list? val)
       (and-map (lambda (x)
                  (and (string? x) (not (string-index x #\space))))
                val)))
(define (serialize-space-separated-string-list field-name val)
  (serialize-field field-name
                   (format #f "~s"
                           (string-join val " "))))
(define-maybe space-separated-string-list)

(define (non-negative-integer? val)
  (and (exact-integer? val) (not (negative? val))))
(define (serialize-non-negative-integer field-name val)
  (serialize-field field-name val))
(define-maybe non-negative-integer)

(define (on-off-boolean? val)
  (boolean? val))
(define (serialize-on-off-boolean field-name val)
  (serialize-field field-name (if val "on" "off")))
(define-maybe on-off-boolean)

(define (y-n-boolean? val)
  (boolean? val))
(define (serialize-y-n-boolean field-name val)
  (serialize-field field-name (if val "Y" "N")))

(define-configuration tlp-configuration
  (tlp
   (package tlp)
   "The TLP package.")

  (tlp-enable?
   (boolean #t)
   "Set to true if you wish to enable TLP.")

  (tlp-default-mode
   (string "AC")
   "Default mode when no power supply can be detected.  Alternatives are
AC and BAT.")

  (disk-idle-secs-on-ac
   (non-negative-integer 0)
   "Number of seconds Linux kernel has to wait after the disk goes idle,
before syncing on AC.")

  (disk-idle-secs-on-bat
   (non-negative-integer 2)
   "Same as @code{disk-idle-ac} but on BAT mode.")

  (max-lost-work-secs-on-ac
   (non-negative-integer 15)
   "Dirty pages flushing periodicity, expressed in seconds.")

  (max-lost-work-secs-on-bat
   (non-negative-integer 60)
   "Same as @code{max-lost-work-secs-on-ac} but on BAT mode.")

  (cpu-scaling-governor-on-ac
   (maybe-space-separated-string-list 'disabled)
   "CPU frequency scaling governor on AC mode.  With intel_pstate
driver, alternatives are powersave and performance.  With acpi-cpufreq driver,
alternatives are ondemand, powersave, performance and conservative.")

  (cpu-scaling-governor-on-bat
   (maybe-space-separated-string-list 'disabled)
   "Same as @code{cpu-scaling-governor-on-ac} but on BAT mode.")

  (cpu-scaling-min-freq-on-ac
   (maybe-non-negative-integer 'disabled)
   "Set the min available frequency for the scaling governor on AC.")

  (cpu-scaling-max-freq-on-ac
   (maybe-non-negative-integer 'disabled)
   "Set the max available frequency for the scaling governor on AC.")

  (cpu-scaling-min-freq-on-bat
   (maybe-non-negative-integer 'disabled)
   "Set the min available frequency for the scaling governor on BAT.")

  (cpu-scaling-max-freq-on-bat
   (maybe-non-negative-integer 'disabled)
   "Set the max available frequency for the scaling governor on BAT.")

  (cpu-min-perf-on-ac
   (maybe-non-negative-integer 'disabled)
   "Limit the min P-state to control the power dissipation of the CPU,
in AC mode.  Values are stated as a percentage of the available performance.")

  (cpu-max-perf-on-ac
   (maybe-non-negative-integer 'disabled)
   "Limit the max P-state to control the power dissipation of the CPU,
in AC mode.  Values are stated as a percentage of the available performance.")

  (cpu-min-perf-on-bat
   (maybe-non-negative-integer 'disabled)
   "Same as @code{cpu-min-perf-on-ac} on BAT mode.")

  (cpu-max-perf-on-bat
   (maybe-non-negative-integer 'disabled)
   "Same as @code{cpu-max-perf-on-ac} on BAT mode.")

  (cpu-boost-on-ac?
   (maybe-boolean 'disabled)
   "Enable CPU turbo boost feature on AC mode.")

  (cpu-boost-on-bat?
   (maybe-boolean 'disabled)
   "Same as @code{cpu-boost-on-ac?} on BAT mode.")

  (sched-powersave-on-ac?
   (boolean #f)
   "Allow Linux kernel to minimize the number of CPU cores/hyper-threads
used under light load conditions.")

  (sched-powersave-on-bat?
   (boolean #t)
   "Same as @code{sched-powersave-on-ac?} but on BAT mode.")

  (nmi-watchdog?
   (boolean #f)
   "Enable Linux kernel NMI watchdog.")

  (phc-controls
   (maybe-string 'disabled)
   "For Linux kernels with PHC patch applied, change CPU voltages.
An example value would be @samp{\"F:V F:V F:V F:V\"}.")

  (energy-perf-policy-on-ac
   (string "performance")
   "Set CPU performance versus energy saving policy on AC.  Alternatives are
performance, normal, powersave.")

  (energy-perf-policy-on-bat
   (string "powersave")
   "Same as @code{energy-perf-policy-ac} but on BAT mode.")

  (disks-devices
   (space-separated-string-list '("sda"))
   "Hard disk devices.")

  (disk-apm-level-on-ac
   (space-separated-string-list '("254" "254"))
   "Hard disk advanced power management level.")

  (disk-apm-level-on-bat
   (space-separated-string-list '("128" "128"))
   "Same as @code{disk-apm-bat} but on BAT mode.")

  (disk-spindown-timeout-on-ac
   (maybe-space-separated-string-list 'disabled)
   "Hard disk spin down timeout.  One value has to be specified for
each declared hard disk.")

  (disk-spindown-timeout-on-bat
   (maybe-space-separated-string-list 'disabled)
   "Same as @code{disk-spindown-timeout-on-ac} but on BAT mode.")

  (disk-iosched
   (maybe-space-separated-string-list 'disabled)
   "Select IO scheduler for disk devices.  One value has to be specified
for each declared hard disk.  Example alternatives are cfq, deadline and noop.")

  (sata-linkpwr-on-ac
   (string "max_performance")
   "SATA aggressive link power management (ALPM) level.  Alternatives are
min_power, medium_power, max_performance.")

  (sata-linkpwr-on-bat
   (string "min_power")
   "Same as @code{sata-linkpwr-ac} but on BAT mode.")

  (sata-linkpwr-blacklist
   (maybe-string 'disabled)
   "Exclude specified SATA host devices for link power management.")

  (ahci-runtime-pm-on-ac?
   (maybe-on-off-boolean 'disabled)
   "Enable Runtime Power Management for AHCI controller and disks
on AC mode.")

  (ahci-runtime-pm-on-bat?
   (maybe-on-off-boolean 'disabled)
   "Same as @code{ahci-runtime-pm-on-ac} on BAT mode.")

  (ahci-runtime-pm-timeout
   (non-negative-integer 15)
   "Seconds of inactivity before disk is suspended.")

  (pcie-aspm-on-ac
   (string "performance")
   "PCI Express Active State Power Management level.  Alternatives are
default, performance, powersave.")

  (pcie-aspm-on-bat
   (string "powersave")
   "Same as @code{pcie-aspm-ac} but on BAT mode.")

  (radeon-power-profile-on-ac
   (string "high")
   "Radeon graphics clock speed level.  Alternatives are
low, mid, high, auto, default.")

  (radeon-power-profile-on-bat
   (string "low")
   "Same as @code{radeon-power-ac} but on BAT mode.")

  (radeon-dpm-state-on-ac
   (string "performance")
   "Radeon dynamic power management method (DPM).  Alternatives are
battery, performance.")

  (radeon-dpm-state-on-bat
   (string "battery")
   "Same as @code{radeon-dpm-state-ac} but on BAT mode.")

  (radeon-dpm-perf-level-on-ac
   (string "auto")
   "Radeon DPM performance level.  Alternatives are
auto, low, high.")

  (radeon-dpm-perf-level-on-bat
   (string "auto")
   "Same as @code{radeon-dpm-perf-ac} but on BAT mode.")

  (wifi-pwr-on-ac?
   (on-off-boolean #f)
   "Wifi power saving mode.")

  (wifi-pwr-on-bat?
   (on-off-boolean #t)
   "Same as @code{wifi-power-ac?} but on BAT mode.")

  (wol-disable?
   (y-n-boolean #t)
   "Disable wake on LAN.")

  (sound-power-save-on-ac
   (non-negative-integer 0)
   "Timeout duration in seconds before activating audio power saving
 on Intel HDA and AC97 devices.  A value of 0 disables power saving.")

  (sound-power-save-on-bat
   (non-negative-integer 1)
   "Same as @code{sound-powersave-ac} but on BAT mode.")

  (sound-power-save-controller?
   (y-n-boolean #t)
   "Disable controller in powersaving mode on Intel HDA devices.")

  (bay-poweroff-on-bat?
   (boolean #f)
   "Enable optical drive in UltraBay/MediaBay on BAT mode.
Drive can be powered on again by releasing (and reinserting) the eject lever
or by pressing the disc eject button on newer models.")

  (bay-device
   (string "sr0")
   "Name of the optical drive device to power off.")

  (runtime-pm-on-ac
   (string "on")
   "Runtime Power Management for PCI(e) bus devices.  Alternatives are
on and auto.")

  (runtime-pm-on-bat
   (string "auto")
   "Same as @code{runtime-pm-ac} but on BAT mode.")

  (runtime-pm-all?
   (boolean #t)
   "Runtime Power Management for all PCI(e) bus devices, except
blacklisted ones.")

  (runtime-pm-blacklist
   (maybe-space-separated-string-list 'disabled)
   "Exclude specified PCI(e) device addresses from Runtime Power Management.")

  (runtime-pm-driver-blacklist
   (space-separated-string-list '("radeon" "nouveau"))
   "Exclude PCI(e) devices assigned to the specified drivers from
Runtime Power Management.")

  (usb-autosuspend?
   (boolean #t)
   "Enable USB autosuspend feature.")

  (usb-blacklist
   (maybe-string 'disabled)
   "Exclude specified devices from USB autosuspend.")

  (usb-blacklist-wwan?
   (boolean #t)
   "Exclude WWAN devices from USB autosuspend.")

  (usb-whitelist
   (maybe-string 'disabled)
   "Include specified devices into USB autosuspend, even if they are
already excluded by the driver or via @code{usb-blacklist-wwan?}.")

  (usb-autosuspend-disable-on-shutdown?
   (maybe-boolean 'disabled)
   "Enable USB autosuspend before shutdown.")

  (restore-device-state-on-startup?
   (boolean #f)
   "Restore radio device state (bluetooth, wifi, wwan) from previous
shutdown on system startup."))

(define (tlp-shepherd-service config)
  (let* ((tlp-bin (file-append
                   (tlp-configuration-tlp config) "/bin/tlp"))
         (tlp-action (lambda args
                       #~(lambda _
                           (zero? (system* #$tlp-bin #$@args))))))
    (list (shepherd-service
           (documentation "Run TLP script.")
           (provision '(tlp))
           (requirement '(user-processes))
           (start (tlp-action "init" "start"))
           (stop  (tlp-action "init" "stop"))))))

(define (tlp-activation config)
  (let* ((config-str (with-output-to-string
                       (lambda ()
                         (serialize-configuration
                          config
                          tlp-configuration-fields))))
         (config-file (plain-file "tlp" config-str)))
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))
          (copy-file #$config-file "/etc/tlp.conf")))))

(define tlp-service-type
  (service-type
   (name 'tlp)
   (extensions
    (list
     (service-extension shepherd-root-service-type
                        tlp-shepherd-service)
     (service-extension udev-service-type
                        (compose list tlp-configuration-tlp))
     (service-extension activation-service-type
                        tlp-activation)))
   (default-value (tlp-configuration))
   (description "Run TLP, a power management tool.")))

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

;;;
;;; thermald
;;;
;;; This service implements cpu scaling.  Helps prevent overheating!

(define-record-type* <thermald-configuration>
  thermald-configuration make-thermald-configuration
  thermald-configuration?
  (ignore-cpuid-check? thermald-ignore-cpuid-check?    ;boolean
                       (default #f))
  (thermald            thermald-thermald               ;package
                       (default thermald)))

(define (thermald-shepherd-service config)
  (list
   (shepherd-service
    (provision '(thermald))
    (documentation "Run thermald cpu frequency scaling.")
    (start #~(make-forkexec-constructor
              '(#$(file-append (thermald-thermald config) "/sbin/thermald")
                "--no-daemon"
                #$@(if (thermald-ignore-cpuid-check? config)
                       '("--ignore-cpuid-check")
                       '()))))
    (stop #~(make-kill-destructor)))))

(define thermald-service-type
  (service-type
   (name 'thermald)
   (extensions (list (service-extension shepherd-root-service-type
                                        thermald-shepherd-service)))
   (default-value (thermald-configuration))
   (description "Run thermald, a CPU frequency scaling service that helps
prevent overheating.")))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Oleg Pykhalov <go.wigust@gmail.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 services rsync)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages rsync)
  #:use-module (gnu packages admin)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (rsync-configuration
            rsync-configuration?
            rsync-service-type))

;;;; Commentary:
;;;
;;; This module implements a service that to run instance of Rsync,
;;; files synchronization tool.
;;;
;;;; Code:

(define-record-type* <rsync-configuration>
  rsync-configuration
  make-rsync-configuration
  rsync-configuration?
  (package       rsync-configuration-package              ; package
                 (default rsync))
  (port-number   rsync-configuration-port-number          ; integer
                 (default 873))
  (pid-file      rsync-configuration-pid-file             ; string
                 (default "/var/run/rsyncd/rsyncd.pid"))
  (lock-file     rsync-configuration-lock-file            ; string
                 (default "/var/run/rsyncd/rsyncd.lock"))
  (log-file      rsync-configuration-log-file             ; string
                 (default "/var/log/rsyncd.log"))
  (use-chroot?   rsync-configuration-use-chroot?          ; boolean
                 (default #t))
  (share-path    rsync-configuration-share-path           ; string
                 (default "/srv/rsyncd"))
  (share-comment rsync-configuration-share-comment        ; string
                 (default "Rsync share"))
  (read-only?    rsync-configuration-read-only?           ; boolean
                 (default #f))
  (timeout       rsync-configuration-timeout              ; integer
                 (default 300))
  (user          rsync-configuration-user                 ; string
                 (default "root"))
  (group         rsync-configuration-group                ; string
                 (default "root"))
  (uid           rsync-configuration-uid                  ; string
                 (default "rsyncd"))
  (gid           rsync-configuration-gid                  ; string
                 (default "rsyncd")))

(define (rsync-account config)
  "Return the user accounts and user groups for CONFIG."
  (let ((rsync-user (if (rsync-configuration-uid config)
                        (rsync-configuration-uid config)
                        (rsync-configuration-user config)))
        (rsync-group (if (rsync-configuration-gid config)
                         (rsync-configuration-gid config)
                         (rsync-configuration-group config))))
    (list (user-group (name rsync-group) (system? #t))
          (user-account
           (name rsync-user)
           (system? #t)
           (group rsync-group)
           (comment "rsyncd privilege separation user")
           (home-directory (string-append "/var/run/"
                                          rsync-user))
           (shell (file-append shadow "/sbin/nologin"))))))

(define (rsync-activation config)
  "Return the activation GEXP for CONFIG."
  (with-imported-modules '((guix build utils))
    #~(begin
        (let ((share-directory  #$(rsync-configuration-share-path config))
              (user  (getpw (if #$(rsync-configuration-uid config)
                                #$(rsync-configuration-uid config)
                                #$(rsync-configuration-user config))))
              (group (getpw (if #$(rsync-configuration-gid config)
                                #$(rsync-configuration-gid config)
                                #$(rsync-configuration-group config)))))
          (mkdir-p (dirname #$(rsync-configuration-pid-file config)))
          (and=> share-directory mkdir-p)
          (chown share-directory
                 (passwd:uid user)
                 (group:gid group))))))

(define rsync-config-file
  ;; Return the rsync configuration file corresponding to CONFIG.
  (match-lambda
    (($ <rsync-configuration> package port-number pid-file lock-file log-file
                              use-chroot? share-path share-comment read-only?
                              timeout user group uid gid)
     (if (not (string=? user "root"))
         (cond
          ((<= port-number 1024)
           (error (string-append "rsync-service: to run on port "
                                 (number->string port-number)
                                 ", user must be root.")))
          (use-chroot?
           (error (string-append "rsync-service: to run in a chroot"
                                 ", user must be root.")))
          (uid
           (error "rsync-service: to use uid, user must be root."))
          (gid
           (error "rsync-service: to use gid, user must be root."))))
     (mixed-text-file
      "rsync.conf"
      "# Generated by 'rsync-service'.\n\n"
      "pid file = " pid-file "\n"
      "lock file = " lock-file "\n"
      "log file = " log-file "\n"
      "port = " (number->string port-number) "\n"
      "use chroot = " (if use-chroot? "true" "false") "\n"
      (if uid (string-append "uid = " uid "\n") "")
      "gid = " (if gid gid "nogroup") "\n" ; no group nobody
      "\n"
      "[files]\n"
      "path = " share-path "\n"
      "comment = " share-comment "\n"
      "read only = " (if read-only? "true" "false") "\n"
      "timeout = " (number->string timeout) "\n"))))

(define (rsync-shepherd-service config)
  "Return a <shepherd-service> for rsync with CONFIG."
  (let* ((rsync       (rsync-configuration-package config))
         (pid-file    (rsync-configuration-pid-file config))
         (port-number (rsync-configuration-port-number config))
         (user        (rsync-configuration-user config))
         (group       (rsync-configuration-group config)))
    (list (shepherd-service
           (provision '(rsync))
           (documentation "Run rsync daemon.")
           (start #~(make-forkexec-constructor
                     (list (string-append #$rsync "/bin/rsync")
                           "--config" #$(rsync-config-file config)
                           "--daemon")
                     #:pid-file #$pid-file
                     #:user #$user
                     #:group #$group))
           (stop #~(make-kill-destructor))))))

(define rsync-service-type
  (service-type
   (name 'rsync)
   (extensions
    (list (service-extension shepherd-root-service-type rsync-shepherd-service)
          (service-extension account-service-type rsync-account)
          (service-extension activation-service-type rsync-activation)))
   (default-value (rsync-configuration))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 science)
  #:export (<rshiny-configuration>
            rshiny-configuration
            rshiny-configuration?
            rshiny-configuration-package
            rshiny-configuration-binary
            rshiny-shepherd-service
            rshiny-service-type))

(use-modules (gnu)
             (guix records)
             (ice-9 match))
(use-service-modules shepherd)
(use-package-modules cran)

(define-record-type* <rshiny-configuration>
  rshiny-configuration
  make-rshiny-configuration
  rshiny-configuration?
  (package          rshiny-configuration-package    ; package
                    (default r-shiny))
  (binary           rshiny-configuration-binary     ; string
                    (default "rshiny")))

(define rshiny-shepherd-service
  (match-lambda
    (($ <rshiny-configuration> package binary)
     (list
       (shepherd-service
         (documentation (string-append "R-Shiny service for " binary))
         (provision (list (symbol-append 'rshiny- (string->symbol
                                                    (string-take binary 9)))))
         (requirement '(networking))
         (start
           #~(exec-command
               (list
                 #$(string-append "/run/current-system/profile/bin/" binary))
               ;#:log-file #$(string-append "/var/log/" binary ".log") ; kills shepherd
               #:environment-variables
               (list "R_LIBS_USER=/run/current-system/profile/site-library/")))
         (stop #~(make-kill-destructor)))))))

(define rshiny-service-type
  (service-type
    (name 'rshiny)
    (extensions
      (list
        (service-extension shepherd-root-service-type
                           rshiny-shepherd-service)
        (service-extension profile-service-type
                           ;; We want the package installed so that it
                           ;; pulls in the propagated inputs as well.
                           (lambda (config)
                             (list
                               (rshiny-configuration-package config))))))
    (description
     "Run an R-Shiny webapp as a Guix Service.")))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Jesse Gildersleve <jessejohngildersleve@protonmail.com>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.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 sddm)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages display-managers)
  #:use-module (gnu packages freedesktop)
  #:use-module (gnu packages xorg)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services xorg)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix deprecation)
  #:export (sddm-configuration
            sddm-configuration?
            sddm-service-type
            sddm-service))

(define-record-type* <sddm-configuration>
  sddm-configuration      make-sddm-configuration
  sddm-configuration?
  (sddm                   sddm-configuration-sddm
                          (default sddm))

  ;; [General]
  ;; valid values are x11 and wayland
  ;; currently doesn't do anything is enabled by wayland greeter PR
  (display-server         sddm-configuration-display-server
                          (default "x11"))
  ;; valid values are on, off or none
  (numlock                sddm-configuration-numlock
                          (default "on"))
  (halt-command           sddm-configuration-halt-command
                          (default (file-append shepherd "/sbin/halt")))
  (reboot-command         sddm-configuration-reboot-command
                          (default (file-append shepherd "/sbin/reboot")))

  ;; [Theme]
  ;; valid values are elarun, maldives or maya
  (theme                  sddm-configuration-theme
                          (default "maldives"))
  (themes-directory       sddm-configuration-themes-directory
                          (default "/run/current-system/profile/share/sddm/themes"))
  (faces-directory        sddm-configuration-faces-directory
                          (default "/run/current-system/profile/share/sddm/faces"))

  ;; [Users]
  (default-path           sddm-configuration-default-path
                          (default "/run/current-system/profile/bin"))
  (minimum-uid            sddm-configuration-minimum-uid
                          (default 1000))
  (maximum-uid            sddm-configuration-maximum-uid
                          (default 2000))
  (remember-last-user?    sddm-configuration-remember-last-user?
                          (default #t))
  (remember-last-session? sddm-configuration-remember-last-session?
                          (default #t))
  (hide-users             sddm-configuration-hide-users
                          (default ""))
  (hide-shells            sddm-configuration-hide-shells
                          (default (file-append shadow "/sbin/nologin")))

  ;; [Wayland]
  (session-command        sddm-configuration-session-command
                          (default (file-append sddm "/share/sddm/scripts/wayland-session")))
  (sessions-directory     sddm-configuration-sessions-directory
                          (default "/run/current-system/profile/share/wayland-sessions"))
  ;; [X11]
  (xorg-configuration     sddm-configuration-xorg
                          (default (xorg-configuration)))
  (xauth-path             sddm-configuration-xauth-path
                          (default (file-append xauth "/bin/xauth")))
  (xephyr-path            sddm-configuration-xephyr-path
                          (default (file-append xorg-server "/bin/Xephyr")))
  (xdisplay-start         sddm-configuration-xdisplay-start
                          (default (file-append sddm "/share/sddm/scripts/Xsetup")))
  (xdisplay-stop          sddm-configuration-xdisplay-stop
                          (default (file-append sddm "/share/sddm/scripts/Xstop")))
  (xsession-command       sddm-configuration-xsession-command
                          (default (xinitrc)))
  (xsessions-directory    sddm-configuration-xsessions-directory
                          (default "/run/current-system/profile/share/xsessions"))
  (minimum-vt             sddm-configuration-minimum-vt
                          (default 7))

  ;; [Autologin]
  (auto-login-user        sddm-configuration-auto-login-user
                          (default ""))
  ;; valid values are xfce.desktop gnome.desktop weston.desktop hawaii.desktop
  (auto-login-session     sddm-configuration-auto-login-session
                          (default ""))
  (relogin?               sddm-configuration-relogin?
                          (default #f)))

(define (sddm-configuration-file config)
  (mixed-text-file "sddm.conf" "
[General]
DisplayServer="        (sddm-configuration-display-server config)              "
Numlock="              (sddm-configuration-numlock config)                     "
HaltCommand="          (sddm-configuration-halt-command config)                "
RebootCommand="        (sddm-configuration-reboot-command config)              "

[Users]
DefaultPath="          (sddm-configuration-default-path config)                "
MinimumUid="           (number->string (sddm-configuration-minimum-uid config))"
MaximumUid="           (number->string (sddm-configuration-maximum-uid config))"
RememberLastUser="     (if (sddm-configuration-remember-last-user? config)
                           "true" "false")                                     "
RememberLastSession="  (if (sddm-configuration-remember-last-session? config)
                           "true" "false")                                     "
HideUsers="            (sddm-configuration-hide-users config)                  "
Hideshells="           (sddm-configuration-hide-shells config)                 "

[Theme]
Current="              (sddm-configuration-theme config)                       "
ThemeDir="             (sddm-configuration-themes-directory config)            "
FacesDir="             (sddm-configuration-faces-directory config)             "

[Wayland]
SessionCommand="       (sddm-configuration-session-command config)             "
SessionDir="           (sddm-configuration-sessions-directory config)          "

[X11]
ServerPath="           (xorg-start-command (sddm-configuration-xorg config))   "
XauthPath="            (sddm-configuration-xauth-path config)                  "
XephyrPath="           (sddm-configuration-xephyr-path config)                 "
DisplayCommand="       (sddm-configuration-xdisplay-start config)              "
DisplayStopCommand="   (sddm-configuration-xdisplay-stop config)               "
SessionCommand="       (sddm-configuration-xsession-command config)            "
SessionDir="           (sddm-configuration-xsessions-directory config)         "
MinimumVT="            (number->string (sddm-configuration-minimum-vt config)) "
ServerArguments="      (string-join
                        (xorg-configuration-server-arguments
                         (sddm-configuration-xorg config)))           "

[Autologin]
User="                 (sddm-configuration-auto-login-user config)             "
Session="              (sddm-configuration-auto-login-session config)          "
Relogin="              (if (sddm-configuration-relogin? config)
                           "true" "false")                                     "
"))

(define (sddm-shepherd-service config)
  "Return a <shepherd-service> for sddm with CONFIG."

  (define sddm-command
    #~(list (string-append #$(sddm-configuration-sddm config) "/bin/sddm")))

  (list (shepherd-service
         (documentation "SDDM display manager.")
         (requirement '(user-processes elogind))
         (provision '(xorg-server display-manager))
         (start #~(make-forkexec-constructor #$sddm-command))
         (stop #~(make-kill-destructor)))))

(define (sddm-etc-service config)
  (list `("sddm.conf" ,(sddm-configuration-file config))))

(define (sddm-pam-service config)
  "Return a PAM service for @command{sddm}."
  (pam-service
   (name "sddm")
   (auth
    (list
     (pam-entry
      (control "requisite")
      (module "pam_nologin.so"))
     (pam-entry
      (control "required")
      (module "pam_env.so"))
     (pam-entry
      (control "required")
      (module "pam_succeed_if.so")
      (arguments (list (string-append "uid >= "
                                      (number->string (sddm-configuration-minimum-uid config)))
                       "quiet")))
     ;; should be factored out into system-auth
     (pam-entry
      (control "required")
      (module "pam_unix.so"))))
   (account
    (list
     ;; should be factored out into system-account
     (pam-entry
      (control "required")
      (module "pam_unix.so"))))
   (password
    (list
     ;; should be factored out into system-password
     (pam-entry
      (control "required")
      (module "pam_unix.so")
      (arguments (list "sha512" "shadow" "try_first_pass")))))
   (session
    (list
     ;; lfs has a required pam_limits.so
     ;; should be factored out into system-session
     (pam-entry
      (control "required")
      (module "pam_unix.so"))))))

(define (sddm-greeter-pam-service)
  "Return a PAM service for @command{sddm-greeter}."
  (pam-service
   (name "sddm-greeter")
   (auth
    (list
     ;; Load environment from /etc/environment and ~/.pam_environment
     (pam-entry
      (control "required")
      (module "pam_env.so"))
     ;; Always let the greeter start without authentication
     (pam-entry
      (control "required")
      (module "pam_permit.so"))))
   (account
    (list
     ;; No action required for account management
     (pam-entry
      (control "required")
      (module "pam_permit.so"))))
   (password
    (list
     ;; Can't change password
     (pam-entry
      (control "required")
      (module "pam_deny.so"))))
   (session
    (list
     ;; Setup session
     (pam-entry
      (control "required")
      (module "pam_unix.so"))))))

(define (sddm-autologin-pam-service config)
  "Return a PAM service for @command{sddm-autologin}"
  (pam-service
   (name "sddm-autologin")
   (auth
    (list
     (pam-entry
      (control "requisite")
      (module "pam_nologin.so"))
     (pam-entry
      (control "required")
      (module "pam_succeed_if.so")
      (arguments (list (string-append "uid >= "
                                      (number->string (sddm-configuration-minimum-uid config)))
                       "quiet")))
     (pam-entry
      (control "required")
      (module "pam_permit.so"))))
   (account
    (list
     (pam-entry
      (control "include")
      (module "sddm"))))
   (password
    (list
     (pam-entry
      (control "required")
      (module "pam_deny.so"))))
   (session
    (list
     (pam-entry
      (control "include")
      (module "sddm"))))))

(define (sddm-pam-services config)
  (list (sddm-pam-service config)
        (sddm-greeter-pam-service)
        (sddm-autologin-pam-service config)))

(define %sddm-accounts
  (list (user-group (name "sddm") (system? #t))
        (user-account
         (name "sddm")
         (group "sddm")
         (system? #t)
         (comment "SDDM user")
         (home-directory "/var/lib/sddm")
         (shell (file-append shadow "/sbin/nologin")))))

;; Add default themes to profile
(define sddm-profile-service
  (compose list sddm-configuration-sddm))

(define sddm-service-type
  (handle-xorg-configuration sddm-configuration
    (service-type (name 'sddm)
                  (extensions
                    (list (service-extension shepherd-root-service-type
                                             sddm-shepherd-service)
                          (service-extension etc-service-type
                                             sddm-etc-service)
                          (service-extension pam-root-service-type
                                             sddm-pam-services)
                          (service-extension account-service-type
                                             (const %sddm-accounts))
                          (service-extension profile-service-type
                                             sddm-profile-service)))
                  (default-value (sddm-configuration))
                  (description
                   "Run SDDM, a display and log-in manager for X11 and
Wayland."))))

(define-deprecated (sddm-service #:optional (config (sddm-configuration)))
  sddm-service-type
  "Run the @uref{https://github.com/sddm/sddm,SDDM display manager}
with the given @var{config}, a @code{<sddm-configuration>} object."
  (service sddm-service-type config))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 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 security-token)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages base)
  #:use-module (gnu packages security-token)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (pcscd-configuration
            pcscd-configuration?
            pcscd-configuration-pcsc-lite
            pcscd-configuration-usb-drivers
            pcscd-service-type))

;;;
;;; PC/SC Smart Card Daemon
;;;

(define-record-type* <pcscd-configuration>
  pcscd-configuration make-pcscd-configuration pcscd-configuration?
  (pcsc-lite pcscd-configuration-pcsc-lite
             (default pcsc-lite))
  (usb-drivers pcscd-configuration-usb-drivers
               (default (list ccid))))

(define pcscd-shepherd-service
  (match-lambda
    (($ <pcscd-configuration> pcsc-lite)
     (with-imported-modules (source-module-closure
                             '((gnu build shepherd)))
       (shepherd-service
        (documentation "PC/SC Smart Card Daemon")
        (provision '(pcscd))
        (requirement '(syslogd))
        (modules '((gnu build shepherd)))
        (start #~(lambda _
                   (let ((socket "/run/pcscd/pcscd.comm"))
                     (when (file-exists? socket)
                       (delete-file socket)))
                   (fork+exec-command
                    (list #$(file-append pcsc-lite "/sbin/pcscd")
                          "--foreground")
                    #:log-file "/var/log/pcscd.log")))
        (stop #~(make-kill-destructor)))))))

(define pcscd-activation
  (match-lambda
    (($ <pcscd-configuration> pcsc-lite usb-drivers)
     (with-imported-modules (source-module-closure
                             '((guix build utils)))
       #~(begin
           (use-modules (guix build utils))
           ;; XXX: We can't use (guix utils) because it requires a
           ;; dynamically-linked Guile, hence the duplicate switch-symlinks.
           (define (switch-symlinks link target)
             (let ((pivot (string-append link ".new")))
               (symlink target pivot)
               (rename-file pivot link)))
           (mkdir-p "/var/lib")
           (switch-symlinks "/var/lib/pcsc"
                            #$(directory-union
                               "pcsc"
                               (map (cut file-append <> "/pcsc")
                                    usb-drivers))))))))

(define pcscd-service-type
  (service-type
   (name 'pcscd)
   (description
    "Run @command{pcscd}, the PC/SC smart card daemon.")
   (extensions
    (list (service-extension shepherd-root-service-type
                             (compose list pcscd-shepherd-service))
          (service-extension activation-service-type
                             pcscd-activation)))
   (default-value (pcscd-configuration))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Carlo Zancanaro <carlo@zancanaro.id.au>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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 shepherd)
  #:use-module (guix ui)
  #:use-module (guix sets)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix records)
  #:use-module (guix derivations)                 ;imported-modules, etc.
  #:use-module (guix utils)
  #:use-module (gnu services)
  #:use-module (gnu services herd)
  #:use-module (gnu packages admin)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (shepherd-configuration
            shepherd-configuration?
            shepherd-configuration-shepherd
            shepherd-configuration-services

            shepherd-root-service-type
            %shepherd-root-service
            shepherd-service-type

            shepherd-service
            shepherd-service?
            shepherd-service-documentation
            shepherd-service-provision
            shepherd-service-canonical-name
            shepherd-service-requirement
            shepherd-service-one-shot?
            shepherd-service-respawn?
            shepherd-service-start
            shepherd-service-stop
            shepherd-service-auto-start?
            shepherd-service-modules

            shepherd-action
            shepherd-action?
            shepherd-action-name
            shepherd-action-documentation
            shepherd-action-procedure

            %default-modules

            shepherd-service-file

            shepherd-service-lookup-procedure
            shepherd-service-back-edges
            shepherd-service-upgrade

            user-processes-service-type

            assert-valid-graph))

;;; Commentary:
;;;
;;; Instantiating system services as a shepherd configuration file.
;;;
;;; Code:

(define-record-type* <shepherd-configuration>
  shepherd-configuration make-shepherd-configuration
  shepherd-configuration?
  (shepherd shepherd-configuration-shepherd
            (default shepherd)) ; package
  (services shepherd-configuration-services
            (default '()))) ; list of <shepherd-service>

(define (shepherd-boot-gexp config)
  "Return a gexp starting the shepherd service."
  (let ((shepherd (shepherd-configuration-shepherd config))
        (services (shepherd-configuration-services config)))
  #~(begin
      ;; Keep track of the booted system.
      (false-if-exception (delete-file "/run/booted-system"))

      ;; Make /run/booted-system, an indirect GC root, point to the store item
      ;; /run/current-system points to.  Use 'canonicalize-path' rather than
      ;; 'readlink' to make sure we get the store item.
      (symlink (canonicalize-path "/run/current-system")
               "/run/booted-system")

      ;; Close any remaining open file descriptors to be on the safe
      ;; side.  This must be the very last thing we do, because
      ;; Guile has internal FDs such as 'sleep_pipe' that need to be
      ;; alive.
      (let loop ((fd 3))
        (when (< fd 1024)
          (false-if-exception (close-fdes fd))
          (loop (+ 1 fd))))

      ;; Start shepherd.
      (execl #$(file-append shepherd "/bin/shepherd")
             "shepherd" "--config"
             #$(shepherd-configuration-file services shepherd)))))

(define shepherd-packages
  (compose list shepherd-configuration-shepherd))

(define shepherd-root-service-type
  (service-type
   (name 'shepherd-root)
   ;; Extending the root shepherd service (aka. PID 1) happens by
   ;; concatenating the list of services provided by the extensions.
   (compose concatenate)
   (extend (lambda (config extra-services)
             (shepherd-configuration
               (inherit config)
               (services (append (shepherd-configuration-services config)
                                 extra-services)))))
   (extensions (list (service-extension boot-service-type
                                        shepherd-boot-gexp)
                     (service-extension profile-service-type
                                        shepherd-packages)))
   (default-value (shepherd-configuration))
   (description
    "Run the GNU Shepherd as PID 1---i.e., the operating system's first
process.  The Shepherd takes care of managing services such as daemons by
ensuring they are started and stopped in the right order.")))

(define %shepherd-root-service
  ;; The root shepherd service, aka. PID 1.  Its parameter is a
  ;; <shepherd-configuration>.
  (service shepherd-root-service-type))

(define-syntax shepherd-service-type
  (syntax-rules (description)
    "Return a <service-type> denoting a simple shepherd service--i.e., the type
for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else.  When
DEFAULT is given, use it as the service's default value."
    ((_ service-name proc default (description text))
     (service-type
      (name service-name)
      (extensions
       (list (service-extension shepherd-root-service-type
                                (compose list proc))))
      (default-value default)
      (description text)))
    ((_ service-name proc (description text))
     (service-type
      (name service-name)
      (extensions
       (list (service-extension shepherd-root-service-type
                                (compose list proc))))
      (description text)))))

(define %default-imported-modules
  ;; Default set of modules imported for a service's consumption.
  '((guix build utils)
    (guix build syscalls)))

(define %default-modules
  ;; Default set of modules visible in a service's file.
  `((shepherd service)
    (oop goops)
    ((guix build utils) #:hide (delete))
    (guix build syscalls)))

(define-record-type* <shepherd-service>
  shepherd-service make-shepherd-service
  shepherd-service?
  (documentation shepherd-service-documentation        ;string
                 (default "[No documentation.]"))
  (provision     shepherd-service-provision)           ;list of symbols
  (requirement   shepherd-service-requirement          ;list of symbols
                 (default '()))
  (one-shot?     shepherd-service-one-shot?            ;Boolean
                 (default #f))
  (respawn?      shepherd-service-respawn?             ;Boolean
                 (default #t))
  (start         shepherd-service-start)               ;g-expression (procedure)
  (stop          shepherd-service-stop                 ;g-expression (procedure)
                 (default #~(const #f)))
  (actions       shepherd-service-actions              ;list of <shepherd-action>
                 (default '()))
  (auto-start?   shepherd-service-auto-start?          ;Boolean
                 (default #t))
  (modules       shepherd-service-modules              ;list of module names
                 (default %default-modules)))

(define-record-type* <shepherd-action>
  shepherd-action make-shepherd-action
  shepherd-action?
  (name          shepherd-action-name)            ;symbol
  (procedure     shepherd-action-procedure)       ;gexp
  (documentation shepherd-action-documentation))  ;string

(define (shepherd-service-canonical-name service)
  "Return the 'canonical name' of SERVICE."
  (first (shepherd-service-provision service)))

(define (assert-valid-graph services)
  "Raise an error if SERVICES does not define a valid shepherd service graph,
for instance if a service requires a nonexistent service, or if more than one
service uses a given name.

These are constraints that shepherd's 'register-service' verifies but we'd
better verify them here statically than wait until PID 1 halts with an
assertion failure."
  (define provisions
    ;; The set of provisions (symbols).  Bail out if a symbol is given more
    ;; than once.
    (fold (lambda (service set)
            (define (assert-unique symbol)
              (when (set-contains? set symbol)
                (raise (condition
                        (&message
                         (message
                          (format #f (G_ "service '~a' provided more than once")
                                  symbol)))))))

            (for-each assert-unique (shepherd-service-provision service))
            (fold set-insert set (shepherd-service-provision service)))
          (setq 'shepherd)
          services))

  (define (assert-satisfied-requirements service)
    ;; Bail out if the requirements of SERVICE aren't satisfied.
    (for-each (lambda (requirement)
                (unless (set-contains? provisions requirement)
                  (raise (condition
                          (&message
                           (message
                            (format #f (G_ "service '~a' requires '~a', \
which is not provided by any service")
                                    (match (shepherd-service-provision service)
                                      ((head . _) head)
                                      (_          service))
                                    requirement)))))))
              (shepherd-service-requirement service)))

  (for-each assert-satisfied-requirements services))

(define %store-characters
  ;; Valid store characters; see 'checkStoreName' in the daemon.
  (string->char-set
   "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))

(define (shepherd-service-file-name service)
  "Return the file name where the initialization code for SERVICE is to be
stored."
  (let ((provisions (string-join (map symbol->string
                                      (shepherd-service-provision service)))))
    (string-append "shepherd-"
                   (string-map (lambda (chr)
                                 (if (char-set-contains? %store-characters chr)
                                     chr
                                     #\-))
                               provisions)
                   ".scm")))

(define (shepherd-service-file service)
  "Return a file defining SERVICE."
  (scheme-file (shepherd-service-file-name service)
               (with-imported-modules %default-imported-modules
                 #~(begin
                     (use-modules #$@(shepherd-service-modules service))

                     (make <service>
                       #:docstring '#$(shepherd-service-documentation service)
                       #:provides '#$(shepherd-service-provision service)
                       #:requires '#$(shepherd-service-requirement service)

                       ;; The 'one-shot?' slot is new in Shepherd 0.6.0.
                       ;; Older versions ignore it.
                       #:one-shot? '#$(shepherd-service-one-shot? service)

                       #:respawn? '#$(shepherd-service-respawn? service)
                       #:start #$(shepherd-service-start service)
                       #:stop #$(shepherd-service-stop service)
                       #:actions
                       (make-actions
                        #$@(map (match-lambda
                                  (($ <shepherd-action> name proc doc)
                                   #~(#$name #$doc #$proc)))
                                (shepherd-service-actions service))))))))

(define (scm->go file shepherd)
  "Compile FILE, which contains code to be loaded by shepherd's config file,
and return the resulting '.go' file. SHEPHERD is used as shepherd package."
  (let-system (system target)
    (with-extensions (list shepherd)
      (computed-file (string-append (basename (scheme-file-name file) ".scm")
                                    ".go")
                     #~(begin
                         (use-modules (system base compile)
                                      (system base target))

                         ;; Do the same as the Shepherd's 'load-in-user-module'.
                         (let ((env (make-fresh-user-module)))
                           (module-use! env (resolve-interface '(oop goops)))
                           (module-use! env (resolve-interface '(shepherd service)))
                           (with-target #$(or target #~%host-type)
                             (lambda _
                               (compile-file #$file #:output-file #$output
                                             #:env env)))))

                     ;; It's faster to build locally than to download.
                     #:options '(#:local-build? #t
                                 #:substitutable? #f)))))

(define (shepherd-configuration-file services shepherd)
  "Return the shepherd configuration file for SERVICES.  SHEPHERD is used
as shepherd package."
  (assert-valid-graph services)

  (let ((files (map shepherd-service-file services))
        (scm->go (cute scm->go <> shepherd)))
    (define config
      #~(begin
          (use-modules (srfi srfi-34)
                       (system repl error-handling))

          ;; Specify the default environment visible to all the services.
          ;; Without this statement, all the environment variables of PID 1
          ;; are inherited by child services.
          (default-environment-variables
            '("PATH=/run/current-system/profile/bin"))

          ;; Booting off a DVD, especially on a slow machine, can make
          ;; everything slow.  Thus, increase the timeout compared to the
          ;; default 5s in the Shepherd 0.7.0.  See
          ;; <https://bugs.gnu.org/40572>.
          (default-pid-file-timeout 30)

          ;; Arrange to spawn a REPL if something goes wrong.  This is better
          ;; than a kernel panic.
          (call-with-error-handling
            (lambda ()
              (apply register-services
                     (parameterize ((current-warning-port
                                     (%make-void-port "w")))
                       (map load-compiled '#$(map scm->go files))))))

          (format #t "starting services...~%")
          (for-each (lambda (service)
                      ;; In the Shepherd 0.3 the 'start' method can raise
                      ;; '&action-runtime-error' if it fails, so protect
                      ;; against it.  (XXX: 'action-runtime-error?' is not
                      ;; exported is 0.3, hence 'service-error?'.)
                      (guard (c ((service-error? c)
                                 (format (current-error-port)
                                         "failed to start service '~a'~%"
                                         service)))
                        (start service)))
                    '#$(append-map shepherd-service-provision
                                   (filter shepherd-service-auto-start?
                                           services)))

          ;; Hang up stdin.  At this point, we assume that 'start' methods
          ;; that required user interaction on the console (e.g.,
          ;; 'cryptsetup open' invocations, post-fsck emergency REPL) have
          ;; completed.  User interaction becomes impossible after this
          ;; call; this avoids situations where services wrongfully lead
          ;; PID 1 to read from stdin (the console), which users may not
          ;; have access to (see <https://bugs.gnu.org/23697>).
          (redirect-port (open-input-file "/dev/null")
                         (current-input-port))))

    (scheme-file "shepherd.conf" config)))

(define* (shepherd-service-lookup-procedure services
                                            #:optional
                                            (provision
                                             shepherd-service-provision))
  "Return a procedure that, when passed a symbol, return the item among
SERVICES that provides this symbol.  PROVISION must be a one-argument
procedure that takes a service and returns the list of symbols it provides."
  (let ((services (fold (lambda (service result)
                          (fold (cut vhash-consq <> service <>)
                                result
                                (provision service)))
                        vlist-null
                        services)))
    (lambda (name)
      (match (vhash-assq name services)
        ((_ . service) service)
        (#f            #f)))))

(define* (shepherd-service-back-edges services
                                      #:key
                                      (provision shepherd-service-provision)
                                      (requirement shepherd-service-requirement))
  "Return a procedure that, when given a <shepherd-service> from SERVICES,
returns the list of <shepherd-service> that depend on it.

Use PROVISION and REQUIREMENT as one-argument procedures that return the
symbols provided/required by a service."
  (define provision->service
    (shepherd-service-lookup-procedure services provision))

  (define edges
    (fold (lambda (service edges)
            (fold (lambda (requirement edges)
                    (vhash-consq (provision->service requirement) service
                                 edges))
                  edges
                  (requirement service)))
          vlist-null
          services))

  (lambda (service)
    (vhash-foldq* cons '() service edges)))

(define (shepherd-service-upgrade live target)
  "Return two values: the subset of LIVE (a list of <live-service>) that needs
to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that
need to be restarted to complete their upgrade."
  (define (essential? service)
    (memq (first (live-service-provision service))
          '(root shepherd)))

  (define lookup-target
    (shepherd-service-lookup-procedure target
                                       shepherd-service-provision))

  (define lookup-live
    (shepherd-service-lookup-procedure live
                                       live-service-provision))

  (define (running? service)
    (and=> (lookup-live (shepherd-service-canonical-name service))
           live-service-running))

  (define live-service-dependents
    (shepherd-service-back-edges live
                                 #:provision live-service-provision
                                 #:requirement live-service-requirement))

  (define (obsolete? service)
    (match (lookup-target (first (live-service-provision service)))
      (#f (every obsolete? (live-service-dependents service)))
      (_  #f)))

  (define to-restart
    ;; Restart services that are currently running.
    (filter running? target))

  (define to-unload
    ;; Unload services that are no longer required.
    (remove essential? (filter obsolete? live)))

  (values to-unload to-restart))

;;;
;;; User processes.
;;;

(define %do-not-kill-file
  ;; Name of the file listing PIDs of processes that must survive when halting
  ;; the system.  Typical example is user-space file systems.
  "/etc/shepherd/do-not-kill")

(define (user-processes-shepherd-service requirements)
  "Return the 'user-processes' Shepherd service with dependencies on
REQUIREMENTS (a list of service names).

This is a synchronization point used to make sure user processes and daemons
get started only after crucial initial services have been started---file
system mounts, etc.  This is similar to the 'sysvinit' target in systemd."
  (define grace-delay
    ;; Delay after sending SIGTERM and before sending SIGKILL.
    4)

  (list (shepherd-service
         (documentation "When stopped, terminate all user processes.")
         (provision '(user-processes))
         (requirement requirements)
         (start #~(const #t))
         (stop #~(lambda _
                   (define (kill-except omit signal)
                     ;; Kill all the processes with SIGNAL except those listed
                     ;; in OMIT and the current process.
                     (let ((omit (cons (getpid) omit)))
                       (for-each (lambda (pid)
                                   (unless (memv pid omit)
                                     (false-if-exception
                                      (kill pid signal))))
                                 (processes))))

                   (define omitted-pids
                     ;; List of PIDs that must not be killed.
                     (if (file-exists? #$%do-not-kill-file)
                         (map string->number
                              (call-with-input-file #$%do-not-kill-file
                                (compose string-tokenize
                                         (@ (ice-9 rdelim) read-string))))
                         '()))

                   (define (now)
                     (car (gettimeofday)))

                   (define (sleep* n)
                     ;; Really sleep N seconds.
                     ;; Work around <http://bugs.gnu.org/19581>.
                     (define start (now))
                     (let loop ((elapsed 0))
                       (when (> n elapsed)
                         (sleep (- n elapsed))
                         (loop (- (now) start)))))

                   (define lset= (@ (srfi srfi-1) lset=))

                   (display "sending all processes the TERM signal\n")

                   (if (null? omitted-pids)
                       (begin
                         ;; Easy: terminate all of them.
                         (kill -1 SIGTERM)
                         (sleep* #$grace-delay)
                         (kill -1 SIGKILL))
                       (begin
                         ;; Kill them all except OMITTED-PIDS.  XXX: We would
                         ;; like to (kill -1 SIGSTOP) to get a fixed list of
                         ;; processes, like 'killall5' does, but that seems
                         ;; unreliable.
                         (kill-except omitted-pids SIGTERM)
                         (sleep* #$grace-delay)
                         (kill-except omitted-pids SIGKILL)
                         (delete-file #$%do-not-kill-file)))

                   (let wait ()
                     ;; Reap children, if any, so that we don't end up with
                     ;; zombies and enter an infinite loop.
                     (let reap-children ()
                       (define result
                         (false-if-exception
                          (waitpid WAIT_ANY (if (null? omitted-pids)
                                                0
                                                WNOHANG))))

                       (when (and (pair? result)
                                  (not (zero? (car result))))
                         (reap-children)))

                     (let ((pids (processes)))
                       (unless (lset= = pids (cons 1 omitted-pids))
                         (format #t "waiting for process termination\
 (processes left: ~s)~%"
                                 pids)
                         (sleep* 2)
                         (wait))))

                   (display "all processes have been terminated\n")
                   #f))
         (respawn? #f))))

(define user-processes-service-type
  (service-type
   (name 'user-processes)
   (extensions (list (service-extension shepherd-root-service-type
                                        user-processes-shepherd-service)))
   (compose concatenate)
   (extend append)

   ;; The value is the list of Shepherd services 'user-processes' depends on.
   ;; Extensions can add new services to this list.
   (default-value '())

   (description "The @code{user-processes} service is responsible for
terminating all the processes so that the root file system can be re-mounted
read-only, just before rebooting/halting.  Processes still running after a few
seconds after @code{SIGTERM} has been sent are terminated with
@code{SIGKILL}.")))

;;; shepherd.scm ends here