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))))

license: mit


code:
(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))
         (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>
;;;
;;; 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 _
                   (invoke #$(file-append pcsc-lite "/sbin/pcscd"))
                   (call-with-input-file "/var/run/pcscd/pcscd.pid" read)))
        (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 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>
;;;
;;; 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-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))

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

(define (shepherd-boot-gexp services)
  #~(begin
      ;; Keep track of the booted system.
      (false-if-exception (delete-file "/run/booted-system"))
      (symlink (readlink "/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))))

(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 append)
   (extensions (list (service-extension boot-service-type
                                        shepherd-boot-gexp)
                     (service-extension profile-service-type
                                        (const (list shepherd)))))
   (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 list of
  ;; <shepherd-service> objects.
  (service shepherd-root-service-type '()))

(define-syntax shepherd-service-type
  (syntax-rules ()
    "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)
     (service-type
      (name service-name)
      (extensions
       (list (service-extension shepherd-root-service-type
                                (compose list proc))))
      (default-value default)))
    ((_ service-name proc)
     (service-type
      (name service-name)
      (extensions
       (list (service-extension shepherd-root-service-type
                                (compose list proc))))))))

(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 (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 (match-lambda
                                 (#\/ #\-)
                                 (#\  #\-)
                                 (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)
  "Compile FILE, which contains code to be loaded by shepherd's config file,
and return the resulting '.go' file."
  (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)
  "Return the shepherd configuration file for SERVICES."
  (assert-valid-graph services)

  (let ((files (map shepherd-service-file services)))
    (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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Leo Prikler <leo.prikler@student.tugraz.at>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services sound)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (gnu packages audio)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages pulseaudio)
  #:use-module (ice-9 match)
  #:export (alsa-configuration
            alsa-service-type

            pulseaudio-configuration
            pulseaudio-service-type

            ladspa-configuration
            ladspa-service-type))

;;; Commentary:
;;;
;;; Sound services.
;;;
;;; Code:

;;;
;;; ALSA
;;;

(define-record-type* <alsa-configuration>
  alsa-configuration make-alsa-configuration alsa-configuration?
  (alsa-plugins alsa-configuration-alsa-plugins ;<package>
                (default alsa-plugins))
  (pulseaudio?   alsa-configuration-pulseaudio? ;boolean
                 (default #t))
  (extra-options alsa-configuration-extra-options ;string
                 (default "")))

(define alsa-config-file
  ;; Return the ALSA configuration file.
  (match-lambda
    (($ <alsa-configuration> alsa-plugins pulseaudio? extra-options)
     (apply mixed-text-file "asound.conf"
            `("# Generated by 'alsa-service'.\n\n"
              ,@(if pulseaudio?
                    `("# Use PulseAudio by default
pcm_type.pulse {
  lib \"" ,#~(string-append #$alsa-plugins:pulseaudio
                            "/lib/alsa-lib/libasound_module_pcm_pulse.so") "\"
}

ctl_type.pulse {
  lib \"" ,#~(string-append #$alsa-plugins:pulseaudio
                            "/lib/alsa-lib/libasound_module_ctl_pulse.so") "\"
}

pcm.!default {
  type pulse
  fallback \"sysdefault\"
  hint {
    show on
    description \"Default ALSA Output (currently PulseAudio Sound Server)\"
  }
}

ctl.!default {
  type pulse
  fallback \"sysdefault\"
}\n\n")
                    '())
              ,extra-options)))))

(define (alsa-etc-service config)
  (list `("asound.conf" ,(alsa-config-file config))))

(define alsa-service-type
  (service-type
   (name 'alsa)
   (extensions
    (list (service-extension etc-service-type alsa-etc-service)))
   (default-value (alsa-configuration))
   (description "Configure low-level Linux sound support, ALSA.")))

;;;
;;; PulseAudio
;;;

(define-record-type* <pulseaudio-configuration>
  pulseaudio-configuration make-pulseaudio-configuration
  pulseaudio-configuration?
  (client-conf pulseaudio-client-conf
               (default '()))
  (daemon-conf pulseaudio-daemon-conf
               ;; Flat volumes may cause unpleasant experiences to users
               ;; when applications inadvertently max out the system volume
               ;; (see e.g. <https://bugs.gnu.org/38172>).
               (default '((flat-volumes . no))))
  (script-file pulseaudio-script-file
               (default (file-append pulseaudio "/etc/pulse/default.pa")))
  (system-script-file pulseaudio-system-script-file
                      (default
                        (file-append pulseaudio "/etc/pulse/system.pa"))))

(define (pulseaudio-conf-entry arg)
  (match arg
    ((key . value)
     (format #f "~a = ~s~%" key value))
    ((? string? _)
     (string-append arg "\n"))))

(define pulseaudio-environment
  (match-lambda
    (($ <pulseaudio-configuration> client-conf daemon-conf default-script-file)
     `(("PULSE_CONFIG" . ,(apply mixed-text-file "daemon.conf"
                                 "default-script-file = " default-script-file "\n"
                                 (map pulseaudio-conf-entry daemon-conf)))
       ("PULSE_CLIENTCONFIG" . ,(apply mixed-text-file "client.conf"
                                       (map pulseaudio-conf-entry client-conf)))))))

(define pulseaudio-etc
  (match-lambda
    (($ <pulseaudio-configuration> _ _ default-script-file system-script-file)
     `(("pulse"
        ,(file-union
          "pulse"
          `(("default.pa" ,default-script-file)
            ("system.pa" ,system-script-file))))))))

(define pulseaudio-service-type
  (service-type
   (name 'pulseaudio)
   (extensions
    (list (service-extension session-environment-service-type
                             pulseaudio-environment)
          (service-extension etc-service-type pulseaudio-etc)))
   (default-value (pulseaudio-configuration))
   (description "Configure PulseAudio sound support.")))

;;;
;;; LADSPA
;;;

(define-record-type* <ladspa-configuration>
  ladspa-configuration make-ladspa-configuration
  ladspa-configuration?
  (plugins ladspa-plugins (default '())))

(define (ladspa-environment config)
  ;; Define this variable in the global environment such that
  ;; pulseaudio swh-plugins (and similar LADSPA plugins) work.
  `(("LADSPA_PATH" .
     (string-join
      ',(map (lambda (package) (file-append package "/lib/ladspa"))
             (ladspa-plugins config))
      ":"))))

(define ladspa-service-type
  (service-type
   (name 'ladspa)
   (extensions
    (list (service-extension session-environment-service-type
                             ladspa-environment)))
   (default-value (ladspa-configuration))
   (description "Configure LADSPA plugins.")))

;;; sound.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services spice)
  #:use-module (gnu packages spice)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:export (spice-vdagent-configuration
            spice-vdagent-configuration?
            spice-vdagent-service-type
            spice-vdagent-service))

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

(define (spice-vdagent-activation config)
  "Return the activation gexp for CONFIG."
  #~(begin
      (use-modules (guix build utils))
      (mkdir-p "/var/run/spice-vdagentd")))

(define (spice-vdagent-shepherd-service config)
  "Return a <shepherd-service> for spice-vdagentd with CONFIG."
  (define spice-vdagent (spice-vdagent-configuration-spice-vdagent config))

  (define spice-vdagentd-command
    (list
      (file-append spice-vdagent "/sbin/spice-vdagentd")
      "-x"))

  (list
    (shepherd-service
      (documentation "Spice vdagentd service")
      (requirement '(udev))
      (provision '(spice-vdagentd))
      (start #~(make-forkexec-constructor '#$spice-vdagentd-command))
      (stop #~(make-kill-destructor)))))

(define spice-vdagent-profile
  (compose list spice-vdagent-configuration-spice-vdagent))

(define spice-vdagent-service-type
  (service-type (name 'spice-vdagent)
    (extensions
      (list (service-extension shepherd-root-service-type
                               spice-vdagent-shepherd-service)
            (service-extension activation-service-type
                               spice-vdagent-activation)
            (service-extension profile-service-type
                               spice-vdagent-profile)))))

(define* (spice-vdagent-service
          #:optional (config (spice-vdagent-configuration)))
  "Start the @command{vdagentd} and @command{vdagent} daemons
from @var{spice-vdagent} to enable guest window resizing and
clipboard sharing."
  (service spice-vdagent-service-type config))