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

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

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


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 #~(string-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:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;;
;;; 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)
  #: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 or maldives
  (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-server-path       sddm-configuration-xorg-server-path
                          (default (xorg-start-command)))
  (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))
  (xserver-arguments      sddm-configuration-xserver-arguments
                          (default "-nolisten tcp"))

  ;; [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="           (sddm-configuration-xorg-server-path 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="      (sddm-configuration-xserver-arguments 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 '(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)
  "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 "uid >= 1000" "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)
  "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 "uid >= 1000" "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)
        (sddm-greeter-pam-service)
        (sddm-autologin-pam-service)))

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

(define* (sddm-service #:optional (config (sddm-configuration)))
  "Run the @uref{https://github.com/sddm/sddm,SSDM 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 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Carlo Zancanaro <carlo@zancanaro.id.au>
;;;
;;; 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 (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-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
            %containerized-shepherd-service

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

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

(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)
    (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 '()))
  (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)
                       #: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 (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))

          ;; Arrange to spawn a REPL if something goes wrong.  This is better
          ;; than a kernel panic.
          (call-with-error-handling
            (lambda ()
              (apply register-services (map primitive-load '#$files))

              ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around
              ;; it.
              (setenv "PATH" "/run/current-system/profile/bin")

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

    (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 %containerized-shepherd-service
  ;; XXX: This service works around a bug in the Shepherd 0.5.0: shepherd
  ;; calls reboot(2) (via 'disable-reboot-on-ctrl-alt-del') when it starts,
  ;; but in a container that fails with EINVAL.  This was fixed in Shepherd
  ;; commit 92e806bac1abaeeaf5d60f0ab50d1ae85ba6a62f.
  (simple-service 'containerized-shepherd
                  shepherd-root-service-type
                  (list (shepherd-service
                         (provision '(containerized-shepherd))
                         (start #~(lambda ()
                                    (set! (@@ (shepherd)
                                              disable-reboot-on-ctrl-alt-del)
                                      (const #t))
                                    #t))))))

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

;;; shepherd.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 sound)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #: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 (gnu packages linux)
  #:use-module (gnu packages pulseaudio)
  #:use-module (ice-9 match)
  #:export (alsa-configuration
            alsa-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.")))

;;; 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} deamons
from @var{spice-vdagent} to enable guest window resizing and
clipboard sharing."
  (service spice-vdagent-service-type config))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016 Julien Lepiller <julien@lepiller.eu>
;;; 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 ssh)
  #:use-module (gnu packages ssh)
  #:use-module (gnu packages admin)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix modules)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (lsh-configuration
            lsh-configuration?
            lsh-service
            lsh-service-type

            openssh-configuration
            openssh-configuration?
            openssh-service-type

            dropbear-configuration
            dropbear-configuration?
            dropbear-service-type
            dropbear-service))

;;; Commentary:
;;;
;;; This module implements secure shell (SSH) services.
;;;
;;; Code:

(define-record-type* <lsh-configuration>
  lsh-configuration make-lsh-configuration
  lsh-configuration?
  (lsh lsh-configuration-lsh
       (default lsh))
  (daemonic? lsh-configuration-daemonic?)
  (host-key lsh-configuration-host-key)
  (interfaces lsh-configuration-interfaces)
  (port-number lsh-configuration-port-number)
  (allow-empty-passwords? lsh-configuration-allow-empty-passwords?)
  (root-login? lsh-configuration-root-login?)
  (syslog-output? lsh-configuration-syslog-output?)
  (pid-file? lsh-configuration-pid-file?)
  (pid-file lsh-configuration-pid-file)
  (x11-forwarding? lsh-configuration-x11-forwarding?)
  (tcp/ip-forwarding? lsh-configuration-tcp/ip-forwarding?)
  (password-authentication? lsh-configuration-password-authentication?)
  (public-key-authentication? lsh-configuration-public-key-authentication?)
  (initialize? lsh-configuration-initialize?))

(define %yarrow-seed
  "/var/spool/lsh/yarrow-seed-file")

(define (lsh-initialization lsh host-key)
  "Return the gexp to initialize the LSH service for HOST-KEY."
  #~(begin
      (unless (file-exists? #$%yarrow-seed)
        (system* (string-append #$lsh "/bin/lsh-make-seed")
                 "--sloppy" "-o" #$%yarrow-seed))

      (unless (file-exists? #$host-key)
        (mkdir-p (dirname #$host-key))
        (format #t "creating SSH host key '~a'...~%" #$host-key)

        ;; FIXME: We're just doing a simple pipeline, but 'system' cannot be
        ;; used yet because /bin/sh might be dangling; factorize this somehow.
        (let* ((in+out (pipe))
               (keygen (primitive-fork)))
          (case keygen
            ((0)
             (close-port (car in+out))
             (close-fdes 1)
             (dup2 (fileno (cdr in+out)) 1)
             (execl (string-append #$lsh "/bin/lsh-keygen")
                    "lsh-keygen" "--server"))
            (else
             (let ((write-key (primitive-fork)))
               (case write-key
                 ((0)
                  (close-port (cdr in+out))
                  (close-fdes 0)
                  (dup2 (fileno (car in+out)) 0)
                  (execl (string-append #$lsh "/bin/lsh-writekey")
                         "lsh-writekey" "--server" "-o" #$host-key))
                 (else
                  (close-port (car in+out))
                  (close-port (cdr in+out))
                  (waitpid keygen)
                  (waitpid write-key))))))))))

(define (lsh-activation config)
  "Return the activation gexp for CONFIG."
  #~(begin
      (use-modules (guix build utils))
      (mkdir-p "/var/spool/lsh")
      #$(if (lsh-configuration-initialize? config)
            (lsh-initialization (lsh-configuration-lsh config)
                                (lsh-configuration-host-key config))
            #t)))

(define (lsh-shepherd-service config)
  "Return a <shepherd-service> for lsh with CONFIG."
  (define lsh (lsh-configuration-lsh config))
  (define pid-file (lsh-configuration-pid-file config))
  (define pid-file? (lsh-configuration-pid-file? config))
  (define daemonic? (lsh-configuration-daemonic? config))
  (define interfaces (lsh-configuration-interfaces config))

  (define lsh-command
    (append
     (cons (file-append lsh "/sbin/lshd")
           (if daemonic?
               (let ((syslog (if (lsh-configuration-syslog-output? config)
                                 '()
                                 (list "--no-syslog"))))
                 (cons "--daemonic"
                       (if pid-file?
                           (cons #~(string-append "--pid-file=" #$pid-file)
                                 syslog)
                           (cons "--no-pid-file" syslog))))
               (if pid-file?
                   (list #~(string-append "--pid-file=" #$pid-file))
                   '())))
     (cons* #~(string-append "--host-key="
                             #$(lsh-configuration-host-key config))
            #~(string-append "--password-helper=" #$lsh "/sbin/lsh-pam-checkpw")
            #~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server")
            "-p" (number->string (lsh-configuration-port-number config))
            (if (lsh-configuration-password-authentication? config)
                "--password" "--no-password")
            (if (lsh-configuration-public-key-authentication? config)
                "--publickey" "--no-publickey")
            (if (lsh-configuration-root-login? config)
                "--root-login" "--no-root-login")
            (if (lsh-configuration-x11-forwarding? config)
                "--x11-forward" "--no-x11-forward")
            (if (lsh-configuration-tcp/ip-forwarding? config)
                "--tcpip-forward" "--no-tcpip-forward")
            (if (null? interfaces)
                '()
                (map (cut string-append "--interface=" <>)
                     interfaces)))))

  (define requires
    (if (and daemonic? (lsh-configuration-syslog-output? config))
        '(networking syslogd)
        '(networking)))

  (list (shepherd-service
         (documentation "GNU lsh SSH server")
         (provision '(ssh-daemon))
         (requirement requires)
         (start #~(make-forkexec-constructor (list #$@lsh-command)))
         (stop  #~(make-kill-destructor)))))

(define (lsh-pam-services config)
  "Return a list of <pam-services> for lshd with CONFIG."
  (list (unix-pam-service
         "lshd"
         #:allow-empty-passwords?
         (lsh-configuration-allow-empty-passwords? config))))

(define lsh-service-type
  (service-type (name 'lsh)
                (description
                 "Run the GNU@tie{}lsh secure shell (SSH) daemon,
@command{lshd}.")
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          lsh-shepherd-service)
                       (service-extension pam-root-service-type
                                          lsh-pam-services)
                       (service-extension activation-service-type
                                          lsh-activation)))))

(define* (lsh-service #:key
                      (lsh lsh)
                      (daemonic? #t)
                      (host-key "/etc/lsh/host-key")
                      (interfaces '())
                      (port-number 22)
                      (allow-empty-passwords? #f)
                      (root-login? #f)
                      (syslog-output? #t)
                      (pid-file? #f)
                      (pid-file "/var/run/lshd.pid")
                      (x11-forwarding? #t)
                      (tcp/ip-forwarding? #t)
                      (password-authentication? #t)
                      (public-key-authentication? #t)
                      (initialize? #t))
  "Run the @command{lshd} program from @var{lsh} to listen on port @var{port-number}.
@var{host-key} must designate a file containing the host key, and readable
only by root.

When @var{daemonic?} is true, @command{lshd} will detach from the
controlling terminal and log its output to syslogd, unless one sets
@var{syslog-output?} to false.  Obviously, it also makes lsh-service
depend on existence of syslogd service.  When @var{pid-file?} is true,
@command{lshd} writes its PID to the file called @var{pid-file}.

When @var{initialize?} is true, automatically create the seed and host key
upon service activation if they do not exist yet.  This may take long and
require interaction.

When @var{initialize?} is false, it is up to the user to initialize the
randomness generator (@pxref{lsh-make-seed,,, lsh, LSH Manual}), and to create
a key pair with the private key stored in file @var{host-key} (@pxref{lshd
basics,,, lsh, LSH Manual}).

When @var{interfaces} is empty, lshd listens for connections on all the
network interfaces; otherwise, @var{interfaces} must be a list of host names
or addresses.

@var{allow-empty-passwords?} specifies whether to accept log-ins with empty
passwords, and @var{root-login?} specifies whether to accept log-ins as
root.

The other options should be self-descriptive."
  (service lsh-service-type
           (lsh-configuration (lsh lsh) (daemonic? daemonic?)
                              (host-key host-key) (interfaces interfaces)
                              (port-number port-number)
                              (allow-empty-passwords? allow-empty-passwords?)
                              (root-login? root-login?)
                              (syslog-output? syslog-output?)
                              (pid-file? pid-file?) (pid-file pid-file)
                              (x11-forwarding? x11-forwarding?)
                              (tcp/ip-forwarding? tcp/ip-forwarding?)
                              (password-authentication?
                               password-authentication?)
                              (public-key-authentication?
                               public-key-authentication?)
                              (initialize? initialize?))))

;;;
;;; OpenSSH.
;;;

(define-record-type* <openssh-configuration>
  openssh-configuration make-openssh-configuration
  openssh-configuration?
  ;; <package>
  (openssh               openssh-configuration-openssh
                         (default openssh))
  ;; string
  (pid-file              openssh-configuration-pid-file
                         (default "/var/run/sshd.pid"))
  ;; integer
  (port-number           openssh-configuration-port-number
                         (default 22))
  ;; Boolean | 'without-password
  (permit-root-login     openssh-configuration-permit-root-login
                         (default #f))
  ;; Boolean
  (allow-empty-passwords? openssh-configuration-allow-empty-passwords?
                          (default #f))
  ;; Boolean
  (password-authentication? openssh-configuration-password-authentication?
                            (default #t))
  ;; Boolean
  (public-key-authentication? openssh-configuration-public-key-authentication?
                              (default #t))
  ;; Boolean
  (x11-forwarding?       openssh-configuration-x11-forwarding?
                         (default #f))

  ;; Boolean
  (allow-agent-forwarding? openssh-configuration-allow-agent-forwarding?
                           (default #t))

  ;; Boolean
  (allow-tcp-forwarding? openssh-configuration-allow-tcp-forwarding?
                         (default #t))

  ;; Boolean
  (gateway-ports? openssh-configuration-gateway-ports?
                         (default #f))

  ;; Boolean
  (challenge-response-authentication? openssh-challenge-response-authentication?
                                      (default #f))
  ;; Boolean
  (use-pam?              openssh-configuration-use-pam?
                         (default #t))
  ;; Boolean
  (print-last-log?       openssh-configuration-print-last-log?
                         (default #t))
  ;; list of two-element lists
  (subsystems            openssh-configuration-subsystems
                         (default '(("sftp" "internal-sftp"))))

  ;; list of strings
  (accepted-environment  openssh-configuration-accepted-environment
                         (default '()))

  ;; symbol
  (log-level             openssh-configuration-log-level
                         (default 'info))

  ;; list of user-name/file-like tuples
  (authorized-keys       openssh-authorized-keys
                         (default '()))

  ;; Boolean
  ;; XXX: This should really be handled in an orthogonal way, for instance as
  ;; proposed in <https://bugs.gnu.org/27155>.  Keep it internal/undocumented
  ;; for now.
  (%auto-start?          openssh-auto-start?
                         (default #t)))

(define %openssh-accounts
  (list (user-group (name "sshd") (system? #t))
        (user-account
          (name "sshd")
          (group "sshd")
          (system? #t)
          (comment "sshd privilege separation user")
          (home-directory "/var/run/sshd")
          (shell #~(string-append #$shadow "/sbin/nologin")))))

(define (openssh-activation config)
  "Return the activation GEXP for CONFIG."
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))

        (define (touch file-name)
          (call-with-output-file file-name (const #t)))

        ;; Make sure /etc/ssh can be read by the 'sshd' user.
        (mkdir-p "/etc/ssh")
        (chmod "/etc/ssh" #o755)
        (mkdir-p (dirname #$(openssh-configuration-pid-file config)))

        ;; 'sshd' complains if the authorized-key directory and its parents
        ;; are group-writable, which rules out /gnu/store.  Thus we copy the
        ;; authorized-key directory to /etc.
        (catch 'system-error
          (lambda ()
            (delete-file-recursively "/etc/authorized_keys.d"))
          (lambda args
            (unless (= ENOENT (system-error-errno args))
              (apply throw args))))
        (copy-recursively #$(authorized-key-directory
                             (openssh-authorized-keys config))
                          "/etc/ssh/authorized_keys.d")

        (chmod "/etc/ssh/authorized_keys.d" #o555)

        (let ((lastlog "/var/log/lastlog"))
          (when #$(openssh-configuration-print-last-log? config)
            (unless (file-exists? lastlog)
              (touch lastlog))))

        ;; Generate missing host keys.
        (system* (string-append #$(openssh-configuration-openssh config)
                                "/bin/ssh-keygen") "-A"))))

(define (authorized-key-directory keys)
  "Return a directory containing the authorized keys specified in KEYS, a list
of user-name/file-like tuples."
  (define build
    (with-imported-modules (source-module-closure '((guix build utils)))
      #~(begin
          (use-modules (ice-9 match) (srfi srfi-26)
                       (guix build utils))

          (mkdir #$output)
          (for-each (match-lambda
                      ((user keys ...)
                       (let ((file (string-append #$output "/" user)))
                         (call-with-output-file file
                           (lambda (port)
                             (for-each (lambda (key)
                                         (call-with-input-file key
                                           (cut dump-port <> port)))
                                       keys))))))
                    '#$keys))))

  (computed-file "openssh-authorized-keys" build))

(define (openssh-config-file config)
  "Return the sshd configuration file corresponding to CONFIG."
  (computed-file
   "sshd_config"
   #~(begin
       (use-modules (ice-9 match))
       (call-with-output-file #$output
         (lambda (port)
           (display "# Generated by 'openssh-service'.\n" port)
           (format port "Port ~a\n"
                   #$(number->string
                      (openssh-configuration-port-number config)))
           (format port "PermitRootLogin ~a\n"
                   #$(match (openssh-configuration-permit-root-login config)
                       (#t "yes")
                       (#f "no")
                       ('without-password "without-password")))
           (format port "PermitEmptyPasswords ~a\n"
                   #$(if (openssh-configuration-allow-empty-passwords? config)
                         "yes" "no"))
           (format port "PasswordAuthentication ~a\n"
                   #$(if (openssh-configuration-password-authentication? config)
                         "yes" "no"))
           (format port "PubkeyAuthentication ~a\n"
                   #$(if (openssh-configuration-public-key-authentication?
                          config)
                         "yes" "no"))
           (format port "X11Forwarding ~a\n"
                   #$(if (openssh-configuration-x11-forwarding? config)
                         "yes" "no"))
           (format port "AllowAgentForwarding ~a\n"
                   #$(if (openssh-configuration-allow-agent-forwarding? config)
                         "yes" "no"))
           (format port "AllowTcpForwarding ~a\n"
                   #$(if (openssh-configuration-allow-tcp-forwarding? config)
                         "yes" "no"))
           (format port "GatewayPorts ~a\n"
                   #$(if (openssh-configuration-gateway-ports? config)
                         "yes" "no"))
           (format port "PidFile ~a\n"
                   #$(openssh-configuration-pid-file config))
           (format port "ChallengeResponseAuthentication ~a\n"
                   #$(if (openssh-challenge-response-authentication? config)
                         "yes" "no"))
           (format port "UsePAM ~a\n"
                   #$(if (openssh-configuration-use-pam? config)
                         "yes" "no"))
           (format port "PrintLastLog ~a\n"
                   #$(if (openssh-configuration-print-last-log? config)
                         "yes" "no"))
           (format port "LogLevel ~a\n"
                   #$(string-upcase
                      (symbol->string
                       (openssh-configuration-log-level config))))

           ;; Add '/etc/authorized_keys.d/%u', which we populate.
           (format port "AuthorizedKeysFile \
 .ssh/authorized_keys .ssh/authorized_keys2 /etc/ssh/authorized_keys.d/%u\n")

           (for-each (lambda (s) (format port "AcceptEnv ~a\n" s))
                     '#$(openssh-configuration-accepted-environment config))

           (for-each
            (match-lambda
              ((name command) (format port "Subsystem\t~a\t~a\n" name command)))
            '#$(openssh-configuration-subsystems config))
           #t)))))

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

  (define pid-file
    (openssh-configuration-pid-file config))

  (define openssh-command
    #~(list (string-append #$(openssh-configuration-openssh config) "/sbin/sshd")
            "-D" "-f" #$(openssh-config-file config)))

  (list (shepherd-service
         (documentation "OpenSSH server.")
         (requirement '(syslogd loopback))
         (provision '(ssh-daemon))
         (start #~(make-forkexec-constructor #$openssh-command
                                             #:pid-file #$pid-file))
         (stop #~(make-kill-destructor))
         (auto-start? (openssh-auto-start? config)))))

(define (openssh-pam-services config)
  "Return a list of <pam-services> for sshd with CONFIG."
  (list (unix-pam-service
         "sshd"
         #:allow-empty-passwords?
         (openssh-configuration-allow-empty-passwords? config))))

(define (extend-openssh-authorized-keys config keys)
  "Extend CONFIG with the extra authorized keys listed in KEYS."
  (openssh-configuration
   (inherit config)
   (authorized-keys
    (append (openssh-authorized-keys config) keys))))

(define openssh-service-type
  (service-type (name 'openssh)
                (description
                 "Run the OpenSSH secure shell (SSH) server, @command{sshd}.")
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          openssh-shepherd-service)
                       (service-extension pam-root-service-type
                                          openssh-pam-services)
                       (service-extension activation-service-type
                                          openssh-activation)
                       (service-extension account-service-type
                                          (const %openssh-accounts))))
                (compose concatenate)
                (extend extend-openssh-authorized-keys)
                (default-value (openssh-configuration))))

;;;
;;; Dropbear.
;;;

(define-record-type* <dropbear-configuration>
  dropbear-configuration make-dropbear-configuration
  dropbear-configuration?
  (dropbear               dropbear-configuration-dropbear
                          (default dropbear))
  (port-number            dropbear-configuration-port-number
                          (default 22))
  (syslog-output?         dropbear-configuration-syslog-output?
                          (default #t))
  (pid-file               dropbear-configuration-pid-file
                          (default "/var/run/dropbear.pid"))
  (root-login?            dropbear-configuration-root-login?
                          (default #f))
  (allow-empty-passwords? dropbear-configuration-allow-empty-passwords?
                          (default #f))
  (password-authentication? dropbear-configuration-password-authentication?
                            (default #t)))

(define (dropbear-activation config)
  "Return the activation gexp for CONFIG."
  #~(begin
      (use-modules (guix build utils))
      (mkdir-p "/etc/dropbear")))

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

  (define pid-file
    (dropbear-configuration-pid-file config))

  (define dropbear-command
    #~(list (string-append #$dropbear "/sbin/dropbear")

            ;; '-R' allows host keys to be automatically generated upon first
            ;; connection, at a time when /dev/urandom is more likely securely
            ;; seeded.
            "-F" "-R"

            "-p" #$(number->string (dropbear-configuration-port-number config))
            "-P" #$pid-file
            #$@(if (dropbear-configuration-syslog-output? config) '() '("-E"))
            #$@(if (dropbear-configuration-root-login? config) '() '("-w"))
            #$@(if (dropbear-configuration-password-authentication? config)
                   '()
                   '("-s" "-g"))
            #$@(if (dropbear-configuration-allow-empty-passwords? config)
                   '("-B")
                   '())))

  (define requires
    (if (dropbear-configuration-syslog-output? config)
        '(networking syslogd) '(networking)))

  (list (shepherd-service
         (documentation "Dropbear SSH server.")
         (requirement requires)
         (provision '(ssh-daemon))
         (start #~(make-forkexec-constructor #$dropbear-command
                                             #:pid-file #$pid-file))
         (stop #~(make-kill-destructor)))))

(define dropbear-service-type
  (service-type (name 'dropbear)
                (description
                 "Run the Dropbear secure shell (SSH) server.")
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          dropbear-shepherd-service)
                       (service-extension activation-service-type
                                          dropbear-activation)))))

(define* (dropbear-service #:optional (config (dropbear-configuration)))
  "Run the @uref{https://matt.ucc.asn.au/dropbear/dropbear.html,Dropbear SSH
daemon} with the given @var{config}, a @code{<dropbear-configuration>}
object."
  (service dropbear-service-type config))

;;; ssh.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <iyzsong@member.fsf.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 sysctl)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages linux)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (sysctl-configuration
            sysctl-service-type))

;;;
;;; System Control Service.
;;;

(define-record-type* <sysctl-configuration>
  sysctl-configuration make-sysctl-configuration
  sysctl-configuration?
  (sysctl   sysctl-configuration-sysctl    ; path of the 'sysctl' command
            (default (file-append procps "/sbin/sysctl")))
  (settings sysctl-configuration-settings  ; alist of string pairs
            (default '())))

(define (sysctl-configuration-settings->sysctl.conf settings)
  "Return a file for @command{sysctl} to set kernel parameters as specified by
@var{settings}."
  (apply mixed-text-file "sysctl.conf"
         (append-map (match-lambda
                       ((key . value)
                        (list key "=" value "\n")))
                     settings)))

(define sysctl-shepherd-service
  (match-lambda
    (($ <sysctl-configuration> sysctl settings)
     (let ((sysctl.conf
            (sysctl-configuration-settings->sysctl.conf settings)))
       (shepherd-service
        (documentation "Configure kernel parameters at boot.")
        (provision '(sysctl))
        (start #~(lambda _
                   (zero? (system* #$sysctl "--load" #$sysctl.conf))))
        (stop #~(const #t))
        (respawn? #f))))))

(define sysctl-service-type
  (service-type
   (name 'sysctl)
   (extensions
    (list (service-extension shepherd-root-service-type
                             (compose list sysctl-shepherd-service))))
   (compose concatenate)
   (extend (lambda (config settings)
             (sysctl-configuration
              (inherit config)
              (settings (append (sysctl-configuration-settings config)
                                settings)))))
   (default-value (sysctl-configuration))))